1 (**************************************************************************)
2 (* *)
3 (* OCaml *)
4 (* *)
5 (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
6 (* *)
7 (* Copyright 1996 Institut National de Recherche en Informatique et *)
8 (* en Automatique. *)
9 (* *)
10 (* All rights reserved. This file is distributed under the terms of *)
11 (* the GNU Lesser General Public License version 2.1, with the *)
12 (* special exception on linking described in the file LICENSE. *)
13 (* *)
14 (**************************************************************************)
15
16 (* bytegen.ml : translation of lambda terms to lists of instructions. *)
17
18 open Misc
19 open Asttypes
20 open Primitive
21 open Types
22 open Lambda
23 open Switch
24 open Instruct
25
26 (**** Label generation ****)
27
28 let label_counter = ref 0
29
30 let new_label () =
31 incr label_counter; !label_counter
32
33 (**** Operations on compilation environments. ****)
34
35 let empty_env =
36 { ce_stack = Ident.empty; ce_heap = Ident.empty; ce_rec = Ident.empty }
37
38 (* Add a stack-allocated variable *)
39
40 let add_var id pos env =
41 { ce_stack = Ident.add id pos env.ce_stack;
42 ce_heap = env.ce_heap;
43 ce_rec = env.ce_rec }
44
45 let rec add_vars idlist pos env =
46 match idlist with
47 [] -> env
48 | id :: rem -> add_vars rem (pos + 1) (add_var id pos env)
49
50 (**** Examination of the continuation ****)
51
52 (* Return a label to the beginning of the given continuation.
53 If the sequence starts with a branch, use the target of that branch
54 as the label, thus avoiding a jump to a jump. *)
55
56 let label_code = function
57 Kbranch lbl :: _ as cont -> (lbl, cont)
58 | Klabel lbl :: _ as cont -> (lbl, cont)
59 | cont -> let lbl = new_label() in (lbl, Klabel lbl :: cont)
60
61 (* Return a branch to the continuation. That is, an instruction that,
62 when executed, branches to the continuation or performs what the
63 continuation performs. We avoid generating branches to branches and
64 branches to returns. *)
65
66 let rec make_branch_2 lbl n cont =
67 function
68 Kreturn m :: _ -> (Kreturn (n + m), cont)
69 | Klabel _ :: c -> make_branch_2 lbl n cont c
70 | Kpop m :: c -> make_branch_2 lbl (n + m) cont c
71 | _ ->
72 match lbl with
73 Some lbl -> (Kbranch lbl, cont)
74 | None -> let lbl = new_label() in (Kbranch lbl, Klabel lbl :: cont)
75
76 let make_branch cont =
77 match cont with
78 (Kbranch _ as branch) :: _ -> (branch, cont)
79 | (Kreturn _ as return) :: _ -> (return, cont)
80 | Kraise k :: _ -> (Kraise k, cont)
81 | Klabel lbl :: _ -> make_branch_2 (Some lbl) 0 cont cont
82 | _ -> make_branch_2 (None) 0 cont cont
83
84 (* Avoid a branch to a label that follows immediately *)
85
86 let branch_to label cont = match cont with
87 | Klabel label0::_ when label = label0 -> cont
88 | _ -> Kbranch label::cont
89
90 (* Discard all instructions up to the next label.
91 This function is to be applied to the continuation before adding a
92 non-terminating instruction (branch, raise, return) in front of it. *)
93
94 let rec discard_dead_code = function
95 [] -> []
96 | (Klabel _ | Krestart | Ksetglobal _) :: _ as cont -> cont
97 | _ :: cont -> discard_dead_code cont
98
99 (* Check if we're in tailcall position *)
100
101 let rec is_tailcall = function
102 Kreturn _ :: _ -> true
103 | Klabel _ :: c -> is_tailcall c
104 | Kpop _ :: c -> is_tailcall c
105 | _ -> false
106
107 (* Add a Kpop N instruction in front of a continuation *)
108
109 let rec add_pop n cont =
110 if n = 0 then cont else
111 match cont with
112 Kpop m :: cont -> add_pop (n + m) cont
113 | Kreturn m :: cont -> Kreturn(n + m) :: cont
114 | Kraise _ :: _ -> cont
115 | _ -> Kpop n :: cont
116
117 (* Add the constant "unit" in front of a continuation *)
118
119 let add_const_unit = function
120 (Kacc _ | Kconst _ | Kgetglobal _ | Kpush_retaddr _) :: _ as cont -> cont
121 | cont -> Kconst const_unit :: cont
122
123 let rec push_dummies n k = match n with
124 | 0 -> k
125 | _ -> Kconst const_unit::Kpush::push_dummies (n-1) k
126
127
128 (**** Auxiliary for compiling "let rec" ****)
129
130 type rhs_kind =
131 | RHS_block of int
132 | RHS_infix of { blocksize : int; offset : int }
133 | RHS_floatblock of int
134 | RHS_nonrec
135 | RHS_function of int * int
136 ;;
137
138 let rec check_recordwith_updates id e =
139 match e with
140 | Lsequence (Lprim ((Psetfield _ | Psetfloatfield _), [Lvar id2; _], _), cont)
141 -> id2 = id && check_recordwith_updates id cont
142 | Lvar id2 -> id2 = id
143 | _ -> false
144 ;;
145
146 let rec size_of_lambda env = function
147 | Lvar id ->
148 begin try Ident.find_same id env with Not_found -> RHS_nonrec end
149 | Lfunction{params} as funct ->
150 RHS_function (1 + Ident.Set.cardinal(free_variables funct),
151 List.length params)
152 | Llet (Strict, _k, id, Lprim (Pduprecord (kind, size), _, _), body)
153 when check_recordwith_updates id body ->
154 begin match kind with
155 | Record_regular | Record_inlined _ -> RHS_block size
156 | Record_unboxed _ -> assert false
157 | Record_float -> RHS_floatblock size
158 | Record_extension _ -> RHS_block (size + 1)
159 end
160 | Llet(_str, _k, id, arg, body) ->
161 size_of_lambda (Ident.add id (size_of_lambda env arg) env) body
162 (* See the Lletrec case of comp_expr *)
163 | Lletrec(bindings, body) when
164 List.for_all (function (_, Lfunction _) -> true | _ -> false) bindings ->
165 (* let rec of functions *)
166 let fv =
167 Ident.Set.elements (free_variables (Lletrec(bindings, lambda_unit))) in
168 (* See Instruct(CLOSUREREC) in interp.c *)
169 let blocksize = List.length bindings * 2 - 1 + List.length fv in
170 let offsets = List.mapi (fun i (id, _e) -> (id, i * 2)) bindings in
171 let env = List.fold_right (fun (id, offset) env ->
172 Ident.add id (RHS_infix { blocksize; offset }) env) offsets env in
173 size_of_lambda env body
174 | Lletrec(bindings, body) ->
175 let env = List.fold_right
176 (fun (id, e) env -> Ident.add id (size_of_lambda env e) env)
177 bindings env
178 in
179 size_of_lambda env body
180 | Lprim(Pmakeblock _, args, _) -> RHS_block (List.length args)
181 | Lprim (Pmakearray ((Paddrarray|Pintarray), _), args, _) ->
182 RHS_block (List.length args)
183 | Lprim (Pmakearray (Pfloatarray, _), args, _) ->
184 RHS_floatblock (List.length args)
185 | Lprim (Pmakearray (Pgenarray, _), _, _) ->
186 (* Pgenarray is excluded from recursive bindings by the
187 check in Translcore.check_recursive_lambda *)
188 RHS_nonrec
189 | Lprim (Pduprecord ((Record_regular | Record_inlined _), size), _, _) ->
190 RHS_block size
191 | Lprim (Pduprecord (Record_unboxed _, _), _, _) ->
192 assert false
193 | Lprim (Pduprecord (Record_extension _, size), _, _) ->
194 RHS_block (size + 1)
195 | Lprim (Pduprecord (Record_float, size), _, _) -> RHS_floatblock size
196 | Levent (lam, _) -> size_of_lambda env lam
197 | Lsequence (_lam, lam') -> size_of_lambda env lam'
198 | _ -> RHS_nonrec
199
200 (**** Merging consecutive events ****)
201
202 let copy_event ev kind info repr =
203 { ev_pos = 0; (* patched in emitcode *)
204 ev_module = ev.ev_module;
205 ev_loc = ev.ev_loc;
206 ev_kind = kind;
207 ev_info = info;
208 ev_typenv = ev.ev_typenv;
209 ev_typsubst = ev.ev_typsubst;
210 ev_compenv = ev.ev_compenv;
211 ev_stacksize = ev.ev_stacksize;
212 ev_repr = repr }
213
214 let merge_infos ev ev' =
215 match ev.ev_info, ev'.ev_info with
216 Event_other, info -> info
217 | info, Event_other -> info
218 | _ -> fatal_error "Bytegen.merge_infos"
219
220 let merge_repr ev ev' =
221 match ev.ev_repr, ev'.ev_repr with
222 Event_none, x -> x
223 | x, Event_none -> x
224 | Event_parent r, Event_child r' when r == r' && !r = 1 -> Event_none
225 | Event_child r, Event_parent r' when r == r' -> Event_parent r
226 | _, _ -> fatal_error "Bytegen.merge_repr"
227
228 let merge_events ev ev' =
229 let (maj, min) =
230 match ev.ev_kind, ev'.ev_kind with
231 (* Discard pseudo-events *)
232 Event_pseudo, _ -> ev', ev
233 | _, Event_pseudo -> ev, ev'
234 (* Keep following event, supposedly more informative *)
235 | Event_before, (Event_after _ | Event_before) -> ev', ev
236 (* Discard following events, supposedly less informative *)
237 | Event_after _, (Event_after _ | Event_before) -> ev, ev'
238 in
239 copy_event maj maj.ev_kind (merge_infos maj min) (merge_repr maj min)
240
241 let weaken_event ev cont =
242 match ev.ev_kind with
243 Event_after _ ->
244 begin match cont with
245 Kpush :: Kevent ({ev_repr = Event_none} as ev') :: c ->
246 begin match ev.ev_info with
247 Event_return _ ->
248 (* Weaken event *)
249 let repr = ref 1 in
250 let ev =
251 copy_event ev Event_pseudo ev.ev_info (Event_parent repr)
252 and ev' =
253 copy_event ev' ev'.ev_kind ev'.ev_info (Event_child repr)
254 in
255 Kevent ev :: Kpush :: Kevent ev' :: c
256 | _ ->
257 (* Only keep following event, equivalent *)
258 cont
259 end
260 | _ ->
261 Kevent ev :: cont
262 end
263 | _ ->
264 Kevent ev :: cont
265
266 let add_event ev =
267 function
268 Kevent ev' :: cont -> weaken_event (merge_events ev ev') cont
269 | cont -> weaken_event ev cont
270
271 (**** Compilation of a lambda expression ****)
272
273 let try_blocks = ref [] (* list of stack size for each nested try block *)
274
275 (* association staticraise numbers -> (lbl,size of stack, try_blocks *)
276
277 let sz_static_raises = ref []
278
279 let push_static_raise i lbl_handler sz =
280 sz_static_raises := (i, (lbl_handler, sz, !try_blocks)) :: !sz_static_raises
281
282 let find_raise_label i =
283 try
284 List.assoc i !sz_static_raises
285 with
286 | Not_found ->
287 Misc.fatal_error
288 ("exit("^Int.to_string i^") outside appropriated catch")
289
290 (* Will the translation of l lead to a jump to label ? *)
291 let code_as_jump l sz = match l with
292 | Lstaticraise (i,[]) ->
293 let label,size,tb = find_raise_label i in
294 if sz = size && tb == !try_blocks then
295 Some label
296 else
297 None
298 | _ -> None
299
300 (* Function bodies that remain to be compiled *)
301
302 type function_to_compile =
303 { params: Ident.t list; (* function parameters *)
304 body: lambda; (* the function body *)
305 label: label; (* the label of the function entry *)
306 free_vars: Ident.t list; (* free variables of the function *)
307 num_defs: int; (* number of mutually recursive definitions *)
308 rec_vars: Ident.t list; (* mutually recursive fn names *)
309 rec_pos: int } (* rank in recursive definition *)
310
311 let functions_to_compile = (Stack.create () : function_to_compile Stack.t)
312
313 (* Name of current compilation unit (for debugging events) *)
314
315 let compunit_name = ref ""
316
317 (* Maximal stack size reached during the current function body *)
318
319 let max_stack_used = ref 0
320
321
322 (* Sequence of string tests *)
323
324
325 (* Translate a primitive to a bytecode instruction (possibly a call to a C
326 function) *)
327
328 let comp_bint_primitive bi suff args =
329 let pref =
330 match bi with Pnativeint -> "caml_nativeint_"
331 | Pint32 -> "caml_int32_"
332 | Pint64 -> "caml_int64_" in
333 Kccall(pref ^ suff, List.length args)
334
335 let comp_primitive p args =
336 match p with
337 Pgetglobal id -> Kgetglobal id
338 | Psetglobal id -> Ksetglobal id
339 | Pintcomp cmp -> Kintcomp cmp
340 | Pmakeblock(tag, _mut, _) -> Kmakeblock(List.length args, tag)
341 | Pfield n -> Kgetfield n
342 | Pfield_computed -> Kgetvectitem
343 | Psetfield(n, _ptr, _init) -> Ksetfield n
344 | Psetfield_computed(_ptr, _init) -> Ksetvectitem
345 | Pfloatfield n -> Kgetfloatfield n
346 | Psetfloatfield (n, _init) -> Ksetfloatfield n
347 | Pduprecord _ -> Kccall("caml_obj_dup", 1)
348 | Pccall p -> Kccall(p.prim_name, p.prim_arity)
349 | Pnegint -> Knegint
350 | Paddint -> Kaddint
351 | Psubint -> Ksubint
352 | Pmulint -> Kmulint
353 | Pdivint _ -> Kdivint
354 | Pmodint _ -> Kmodint
355 | Pandint -> Kandint
356 | Porint -> Korint
357 | Pxorint -> Kxorint
358 | Plslint -> Klslint
359 | Plsrint -> Klsrint
360 | Pasrint -> Kasrint
361 | Poffsetint n -> Koffsetint n
362 | Poffsetref n -> Koffsetref n
363 | Pintoffloat -> Kccall("caml_int_of_float", 1)
364 | Pfloatofint -> Kccall("caml_float_of_int", 1)
365 | Pnegfloat -> Kccall("caml_neg_float", 1)
366 | Pabsfloat -> Kccall("caml_abs_float", 1)
367 | Paddfloat -> Kccall("caml_add_float", 2)
368 | Psubfloat -> Kccall("caml_sub_float", 2)
369 | Pmulfloat -> Kccall("caml_mul_float", 2)
370 | Pdivfloat -> Kccall("caml_div_float", 2)
371 | Pstringlength -> Kccall("caml_ml_string_length", 1)
372 | Pbyteslength -> Kccall("caml_ml_bytes_length", 1)
373 | Pstringrefs -> Kccall("caml_string_get", 2)
374 | Pbytesrefs -> Kccall("caml_bytes_get", 2)
375 | Pbytessets -> Kccall("caml_bytes_set", 3)
376 | Pstringrefu -> Kgetstringchar
377 | Pbytesrefu -> Kgetbyteschar
378 | Pbytessetu -> Ksetbyteschar
379 | Pstring_load_16(_) -> Kccall("caml_string_get16", 2)
380 | Pstring_load_32(_) -> Kccall("caml_string_get32", 2)
381 | Pstring_load_64(_) -> Kccall("caml_string_get64", 2)
382 | Pbytes_set_16(_) -> Kccall("caml_bytes_set16", 3)
383 | Pbytes_set_32(_) -> Kccall("caml_bytes_set32", 3)
384 | Pbytes_set_64(_) -> Kccall("caml_bytes_set64", 3)
385 | Pbytes_load_16(_) -> Kccall("caml_bytes_get16", 2)
386 | Pbytes_load_32(_) -> Kccall("caml_bytes_get32", 2)
387 | Pbytes_load_64(_) -> Kccall("caml_bytes_get64", 2)
388 | Parraylength _ -> Kvectlength
389 | Parrayrefs Pgenarray -> Kccall("caml_array_get", 2)
390 | Parrayrefs Pfloatarray -> Kccall("caml_floatarray_get", 2)
391 | Parrayrefs _ -> Kccall("caml_array_get_addr", 2)
392 | Parraysets Pgenarray -> Kccall("caml_array_set", 3)
393 | Parraysets Pfloatarray -> Kccall("caml_floatarray_set", 3)
394 | Parraysets _ -> Kccall("caml_array_set_addr", 3)
395 | Parrayrefu Pgenarray -> Kccall("caml_array_unsafe_get", 2)
396 | Parrayrefu Pfloatarray -> Kccall("caml_floatarray_unsafe_get", 2)
397 | Parrayrefu _ -> Kgetvectitem
398 | Parraysetu Pgenarray -> Kccall("caml_array_unsafe_set", 3)
399 | Parraysetu Pfloatarray -> Kccall("caml_floatarray_unsafe_set", 3)
400 | Parraysetu _ -> Ksetvectitem
401 | Pctconst c ->
402 let const_name = match c with
403 | Big_endian -> "big_endian"
404 | Word_size -> "word_size"
405 | Int_size -> "int_size"
406 | Max_wosize -> "max_wosize"
407 | Ostype_unix -> "ostype_unix"
408 | Ostype_win32 -> "ostype_win32"
409 | Ostype_cygwin -> "ostype_cygwin"
410 | Backend_type -> "backend_type" in
411 Kccall(Printf.sprintf "caml_sys_const_%s" const_name, 1)
412 | Pisint -> Kisint
413 | Pisout -> Kisout
414 | Pbintofint bi -> comp_bint_primitive bi "of_int" args
415 | Pintofbint bi -> comp_bint_primitive bi "to_int" args
416 | Pcvtbint(Pint32, Pnativeint) -> Kccall("caml_nativeint_of_int32", 1)
417 | Pcvtbint(Pnativeint, Pint32) -> Kccall("caml_nativeint_to_int32", 1)
418 | Pcvtbint(Pint32, Pint64) -> Kccall("caml_int64_of_int32", 1)
419 | Pcvtbint(Pint64, Pint32) -> Kccall("caml_int64_to_int32", 1)
420 | Pcvtbint(Pnativeint, Pint64) -> Kccall("caml_int64_of_nativeint", 1)
421 | Pcvtbint(Pint64, Pnativeint) -> Kccall("caml_int64_to_nativeint", 1)
422 | Pnegbint bi -> comp_bint_primitive bi "neg" args
423 | Paddbint bi -> comp_bint_primitive bi "add" args
424 | Psubbint bi -> comp_bint_primitive bi "sub" args
425 | Pmulbint bi -> comp_bint_primitive bi "mul" args
426 | Pdivbint { size = bi } -> comp_bint_primitive bi "div" args
427 | Pmodbint { size = bi } -> comp_bint_primitive bi "mod" args
428 | Pandbint bi -> comp_bint_primitive bi "and" args
429 | Porbint bi -> comp_bint_primitive bi "or" args
430 | Pxorbint bi -> comp_bint_primitive bi "xor" args
431 | Plslbint bi -> comp_bint_primitive bi "shift_left" args
432 | Plsrbint bi -> comp_bint_primitive bi "shift_right_unsigned" args
433 | Pasrbint bi -> comp_bint_primitive bi "shift_right" args
434 | Pbintcomp(_, Ceq) -> Kccall("caml_equal", 2)
435 | Pbintcomp(_, Cne) -> Kccall("caml_notequal", 2)
436 | Pbintcomp(_, Clt) -> Kccall("caml_lessthan", 2)
437 | Pbintcomp(_, Cgt) -> Kccall("caml_greaterthan", 2)
438 | Pbintcomp(_, Cle) -> Kccall("caml_lessequal", 2)
439 | Pbintcomp(_, Cge) -> Kccall("caml_greaterequal", 2)
440 | Pbigarrayref(_, n, _, _) -> Kccall("caml_ba_get_" ^ Int.to_string n, n + 1)
441 | Pbigarrayset(_, n, _, _) -> Kccall("caml_ba_set_" ^ Int.to_string n, n + 2)
442 | Pbigarraydim(n) -> Kccall("caml_ba_dim_" ^ Int.to_string n, 1)
443 | Pbigstring_load_16(_) -> Kccall("caml_ba_uint8_get16", 2)
444 | Pbigstring_load_32(_) -> Kccall("caml_ba_uint8_get32", 2)
445 | Pbigstring_load_64(_) -> Kccall("caml_ba_uint8_get64", 2)
446 | Pbigstring_set_16(_) -> Kccall("caml_ba_uint8_set16", 3)
447 | Pbigstring_set_32(_) -> Kccall("caml_ba_uint8_set32", 3)
448 | Pbigstring_set_64(_) -> Kccall("caml_ba_uint8_set64", 3)
449 | Pbswap16 -> Kccall("caml_bswap16", 1)
450 | Pbbswap(bi) -> comp_bint_primitive bi "bswap" args
451 | Pint_as_pointer -> Kccall("caml_int_as_pointer", 1)
452 | Pbytes_to_string -> Kccall("caml_string_of_bytes", 1)
453 | Pbytes_of_string -> Kccall("caml_bytes_of_string", 1)
454 | _ -> fatal_error "Bytegen.comp_primitive"
455
456 let is_immed n = immed_min <= n && n <= immed_max
457
458 module Storer =
459 Switch.Store
460 (struct type t = lambda type key = lambda
461 let compare_key = Stdlib.compare
462 let make_key = Lambda.make_key end)
463
464 (* Compile an expression.
465 The value of the expression is left in the accumulator.
466 env = compilation environment
467 exp = the lambda expression to compile
468 sz = current size of the stack frame
469 cont = list of instructions to execute afterwards
470 Result = list of instructions that evaluate exp, then perform cont. *)
471
472 let rec comp_expr env exp sz cont =
473 if sz > !max_stack_used then max_stack_used := sz;
474 match exp with
475 Lvar id ->
476 begin try
477 let pos = Ident.find_same id env.ce_stack in
478 Kacc(sz - pos) :: cont
479 with Not_found ->
480 try
481 let pos = Ident.find_same id env.ce_heap in
482 Kenvacc(pos) :: cont
483 with Not_found ->
484 try
485 let ofs = Ident.find_same id env.ce_rec in
486 Koffsetclosure(ofs) :: cont
487 with Not_found ->
488 fatal_error ("Bytegen.comp_expr: var " ^ Ident.unique_name id)
489 end
490 | Lconst cst ->
491 Kconst cst :: cont
492 | Lapply{ap_func = func; ap_args = args} ->
493 let nargs = List.length args in
494 if is_tailcall cont then begin
495 comp_args env args sz
496 (Kpush :: comp_expr env func (sz + nargs)
497 (Kappterm(nargs, sz + nargs) :: discard_dead_code cont))
498 end else begin
499 if nargs < 4 then
500 comp_args env args sz
501 (Kpush :: comp_expr env func (sz + nargs) (Kapply nargs :: cont))
502 else begin
503 let (lbl, cont1) = label_code cont in
504 Kpush_retaddr lbl ::
505 comp_args env args (sz + 3)
506 (Kpush :: comp_expr env func (sz + 3 + nargs)
507 (Kapply nargs :: cont1))
508 end
509 end
510 | Lsend(kind, met, obj, args, _) ->
511 let args = if kind = Cached then List.tl args else args in
512 let nargs = List.length args + 1 in
513 let getmethod, args' =
514 if kind = Self then (Kgetmethod, met::obj::args) else
515 match met with
516 Lconst(Const_base(Const_int n)) -> (Kgetpubmet n, obj::args)
517 | _ -> (Kgetdynmet, met::obj::args)
518 in
519 if is_tailcall cont then
520 comp_args env args' sz
521 (getmethod :: Kappterm(nargs, sz + nargs) :: discard_dead_code cont)
522 else
523 if nargs < 4 then
524 comp_args env args' sz
525 (getmethod :: Kapply nargs :: cont)
526 else begin
527 let (lbl, cont1) = label_code cont in
528 Kpush_retaddr lbl ::
529 comp_args env args' (sz + 3)
530 (getmethod :: Kapply nargs :: cont1)
531 end
532 | Lfunction{params; body} -> (* assume kind = Curried *)
533 let lbl = new_label() in
534 let fv = Ident.Set.elements(free_variables exp) in
535 let to_compile =
536 { params = List.map fst params; body = body; label = lbl;
537 free_vars = fv; num_defs = 1; rec_vars = []; rec_pos = 0 } in
538 Stack.push to_compile functions_to_compile;
539 comp_args env (List.map (fun n -> Lvar n) fv) sz
540 (Kclosure(lbl, List.length fv) :: cont)
541 | Llet(_str, _k, id, arg, body) ->
542 comp_expr env arg sz
543 (Kpush :: comp_expr (add_var id (sz+1) env) body (sz+1)
544 (add_pop 1 cont))
545 | Lletrec(decl, body) ->
546 let ndecl = List.length decl in
547 if List.for_all (function (_, Lfunction _) -> true | _ -> false)
548 decl then begin
549 (* let rec of functions *)
550 let fv =
551 Ident.Set.elements (free_variables (Lletrec(decl, lambda_unit))) in
552 let rec_idents = List.map (fun (id, _lam) -> id) decl in
553 let rec comp_fun pos = function
554 [] -> []
555 | (_id, Lfunction{params; body}) :: rem ->
556 let lbl = new_label() in
557 let to_compile =
558 { params = List.map fst params; body = body; label = lbl;
559 free_vars = fv; num_defs = ndecl; rec_vars = rec_idents;
560 rec_pos = pos} in
561 Stack.push to_compile functions_to_compile;
562 lbl :: comp_fun (pos + 1) rem
563 | _ -> assert false in
564 let lbls = comp_fun 0 decl in
565 comp_args env (List.map (fun n -> Lvar n) fv) sz
566 (Kclosurerec(lbls, List.length fv) ::
567 (comp_expr (add_vars rec_idents (sz+1) env) body (sz + ndecl)
568 (add_pop ndecl cont)))
569 end else begin
570 let decl_size =
571 List.map (fun (id, exp) -> (id, exp, size_of_lambda Ident.empty exp))
572 decl in
573 let rec comp_init new_env sz = function
574 | [] -> comp_nonrec new_env sz ndecl decl_size
575 | (id, _exp, RHS_floatblock blocksize) :: rem ->
576 Kconst(Const_base(Const_int blocksize)) ::
577 Kccall("caml_alloc_dummy_float", 1) :: Kpush ::
578 comp_init (add_var id (sz+1) new_env) (sz+1) rem
579 | (id, _exp, RHS_block blocksize) :: rem ->
580 Kconst(Const_base(Const_int blocksize)) ::
581 Kccall("caml_alloc_dummy", 1) :: Kpush ::
582 comp_init (add_var id (sz+1) new_env) (sz+1) rem
583 | (id, _exp, RHS_infix { blocksize; offset }) :: rem ->
584 Kconst(Const_base(Const_int offset)) ::
585 Kpush ::
586 Kconst(Const_base(Const_int blocksize)) ::
587 Kccall("caml_alloc_dummy_infix", 2) :: Kpush ::
588 comp_init (add_var id (sz+1) new_env) (sz+1) rem
589 | (id, _exp, RHS_function (blocksize,arity)) :: rem ->
590 Kconst(Const_base(Const_int arity)) ::
591 Kpush ::
592 Kconst(Const_base(Const_int blocksize)) ::
593 Kccall("caml_alloc_dummy_function", 2) :: Kpush ::
594 comp_init (add_var id (sz+1) new_env) (sz+1) rem
595 | (id, _exp, RHS_nonrec) :: rem ->
596 Kconst(Const_base(Const_int 0)) :: Kpush ::
597 comp_init (add_var id (sz+1) new_env) (sz+1) rem
598 and comp_nonrec new_env sz i = function
599 | [] -> comp_rec new_env sz ndecl decl_size
600 | (_id, _exp, (RHS_block _ | RHS_infix _ |
601 RHS_floatblock _ | RHS_function _))
602 :: rem ->
603 comp_nonrec new_env sz (i-1) rem
604 | (_id, exp, RHS_nonrec) :: rem ->
605 comp_expr new_env exp sz
606 (Kassign (i-1) :: comp_nonrec new_env sz (i-1) rem)
607 and comp_rec new_env sz i = function
608 | [] -> comp_expr new_env body sz (add_pop ndecl cont)
609 | (_id, exp, (RHS_block _ | RHS_infix _ |
610 RHS_floatblock _ | RHS_function _))
611 :: rem ->
612 comp_expr new_env exp sz
613 (Kpush :: Kacc i :: Kccall("caml_update_dummy", 2) ::
614 comp_rec new_env sz (i-1) rem)
615 | (_id, _exp, RHS_nonrec) :: rem ->
616 comp_rec new_env sz (i-1) rem
617 in
618 comp_init env sz decl_size
619 end
620 | Lprim((Pidentity | Popaque), [arg], _) ->
621 comp_expr env arg sz cont
622 | Lprim(Pignore, [arg], _) ->
623 comp_expr env arg sz (add_const_unit cont)
624 | Lprim(Pdirapply, [func;arg], loc)
625 | Lprim(Prevapply, [arg;func], loc) ->
626 let exp = Lapply{ap_should_be_tailcall=false;
627 ap_loc=loc;
628 ap_func=func;
629 ap_args=[arg];
630 ap_inlined=Default_inline;
631 ap_specialised=Default_specialise} in
632 comp_expr env exp sz cont
633 | Lprim(Pnot, [arg], _) ->
634 let newcont =
635 match cont with
636 Kbranchif lbl :: cont1 -> Kbranchifnot lbl :: cont1
637 | Kbranchifnot lbl :: cont1 -> Kbranchif lbl :: cont1
638 | _ -> Kboolnot :: cont in
639 comp_expr env arg sz newcont
640 | Lprim(Psequand, [exp1; exp2], _) ->
641 begin match cont with
642 Kbranchifnot lbl :: _ ->
643 comp_expr env exp1 sz (Kbranchifnot lbl ::
644 comp_expr env exp2 sz cont)
645 | Kbranchif lbl :: cont1 ->
646 let (lbl2, cont2) = label_code cont1 in
647 comp_expr env exp1 sz (Kbranchifnot lbl2 ::
648 comp_expr env exp2 sz (Kbranchif lbl :: cont2))
649 | _ ->
650 let (lbl, cont1) = label_code cont in
651 comp_expr env exp1 sz (Kstrictbranchifnot lbl ::
652 comp_expr env exp2 sz cont1)
653 end
654 | Lprim(Psequor, [exp1; exp2], _) ->
655 begin match cont with
656 Kbranchif lbl :: _ ->
657 comp_expr env exp1 sz (Kbranchif lbl ::
658 comp_expr env exp2 sz cont)
659 | Kbranchifnot lbl :: cont1 ->
660 let (lbl2, cont2) = label_code cont1 in
661 comp_expr env exp1 sz (Kbranchif lbl2 ::
662 comp_expr env exp2 sz (Kbranchifnot lbl :: cont2))
663 | _ ->
664 let (lbl, cont1) = label_code cont in
665 comp_expr env exp1 sz (Kstrictbranchif lbl ::
666 comp_expr env exp2 sz cont1)
667 end
668 | Lprim(Praise k, [arg], _) ->
669 comp_expr env arg sz (Kraise k :: discard_dead_code cont)
670 | Lprim(Paddint, [arg; Lconst(Const_base(Const_int n))], _)
671 when is_immed n ->
672 comp_expr env arg sz (Koffsetint n :: cont)
673 | Lprim(Psubint, [arg; Lconst(Const_base(Const_int n))], _)
674 when is_immed (-n) ->
675 comp_expr env arg sz (Koffsetint (-n) :: cont)
676 | Lprim (Poffsetint n, [arg], _)
677 when not (is_immed n) ->
678 comp_expr env arg sz
679 (Kpush::
680 Kconst (Const_base (Const_int n))::
681 Kaddint::cont)
682 | Lprim(Pmakearray (kind, _), args, _) ->
683 begin match kind with
684 Pintarray | Paddrarray ->
685 comp_args env args sz (Kmakeblock(List.length args, 0) :: cont)
686 | Pfloatarray ->
687 comp_args env args sz (Kmakefloatblock(List.length args) :: cont)
688 | Pgenarray ->
689 if args = []
690 then Kmakeblock(0, 0) :: cont
691 else comp_args env args sz
692 (Kmakeblock(List.length args, 0) ::
693 Kccall("caml_make_array", 1) :: cont)
694 end
695 | Lprim (Pduparray (kind, mutability),
696 [Lprim (Pmakearray (kind',_),args,_)], loc) ->
697 assert (kind = kind');
698 comp_expr env (Lprim (Pmakearray (kind, mutability), args, loc)) sz cont
699 | Lprim (Pduparray _, [arg], loc) ->
700 let prim_obj_dup =
701 Primitive.simple ~name:"caml_obj_dup" ~arity:1 ~alloc:true
702 in
703 comp_expr env (Lprim (Pccall prim_obj_dup, [arg], loc)) sz cont
704 | Lprim (Pduparray _, _, _) ->
705 Misc.fatal_error "Bytegen.comp_expr: Pduparray takes exactly one arg"
706 (* Integer first for enabling further optimization (cf. emitcode.ml) *)
707 | Lprim (Pintcomp c, [arg ; (Lconst _ as k)], _) ->
708 let p = Pintcomp (swap_integer_comparison c)
709 and args = [k ; arg] in
710 comp_args env args sz (comp_primitive p args :: cont)
711 | Lprim (Pfloatcomp cmp, args, _) ->
712 let cont =
713 match cmp with
714 | CFeq -> Kccall("caml_eq_float", 2) :: cont
715 | CFneq -> Kccall("caml_neq_float", 2) :: cont
716 | CFlt -> Kccall("caml_lt_float", 2) :: cont
717 | CFnlt -> Kccall("caml_lt_float", 2) :: Kboolnot :: cont
718 | CFgt -> Kccall("caml_gt_float", 2) :: cont
719 | CFngt -> Kccall("caml_gt_float", 2) :: Kboolnot :: cont
720 | CFle -> Kccall("caml_le_float", 2) :: cont
721 | CFnle -> Kccall("caml_le_float", 2) :: Kboolnot :: cont
722 | CFge -> Kccall("caml_ge_float", 2) :: cont
723 | CFnge -> Kccall("caml_ge_float", 2) :: Kboolnot :: cont
724 in
725 comp_args env args sz cont
726 | Lprim(p, args, _) ->
727 comp_args env args sz (comp_primitive p args :: cont)
728 | Lstaticcatch (body, (i, vars) , handler) ->
729 let vars = List.map fst vars in
730 let nvars = List.length vars in
731 let branch1, cont1 = make_branch cont in
732 let r =
733 if nvars <> 1 then begin (* general case *)
734 let lbl_handler, cont2 =
735 label_code
736 (comp_expr
737 (add_vars vars (sz+1) env)
738 handler (sz+nvars) (add_pop nvars cont1)) in
739 push_static_raise i lbl_handler (sz+nvars);
740 push_dummies nvars
741 (comp_expr env body (sz+nvars)
742 (add_pop nvars (branch1 :: cont2)))
743 end else begin (* small optimization for nvars = 1 *)
744 let var = match vars with [var] -> var | _ -> assert false in
745 let lbl_handler, cont2 =
746 label_code
747 (Kpush::comp_expr
748 (add_var var (sz+1) env)
749 handler (sz+1) (add_pop 1 cont1)) in
750 push_static_raise i lbl_handler sz;
751 comp_expr env body sz (branch1 :: cont2)
752 end in
753 sz_static_raises := List.tl !sz_static_raises ;
754 r
755 | Lstaticraise (i, args) ->
756 let cont = discard_dead_code cont in
757 let label,size,tb = find_raise_label i in
758 let cont = branch_to label cont in
759 let rec loop sz tbb =
760 if tb == tbb then add_pop (sz-size) cont
761 else match tbb with
762 | [] -> assert false
763 | try_sz :: tbb -> add_pop (sz-try_sz-4) (Kpoptrap :: loop try_sz tbb)
764 in
765 let cont = loop sz !try_blocks in
766 begin match args with
767 | [arg] -> (* optim, argument passed in accumulator *)
768 comp_expr env arg sz cont
769 | _ -> comp_exit_args env args sz size cont
770 end
771 | Ltrywith(body, id, handler) ->
772 let (branch1, cont1) = make_branch cont in
773 let lbl_handler = new_label() in
774 let body_cont =
775 Kpoptrap :: branch1 ::
776 Klabel lbl_handler :: Kpush ::
777 comp_expr (add_var id (sz+1) env) handler (sz+1) (add_pop 1 cont1)
778 in
779 try_blocks := sz :: !try_blocks;
780 let l = comp_expr env body (sz+4) body_cont in
781 try_blocks := List.tl !try_blocks;
782 Kpushtrap lbl_handler :: l
783 | Lifthenelse(cond, ifso, ifnot) ->
784 comp_binary_test env cond ifso ifnot sz cont
785 | Lsequence(exp1, exp2) ->
786 comp_expr env exp1 sz (comp_expr env exp2 sz cont)
787 | Lwhile(cond, body) ->
788 let lbl_loop = new_label() in
789 let lbl_test = new_label() in
790 Kbranch lbl_test :: Klabel lbl_loop :: Kcheck_signals ::
791 comp_expr env body sz
792 (Klabel lbl_test ::
793 comp_expr env cond sz (Kbranchif lbl_loop :: add_const_unit cont))
794 | Lfor(param, start, stop, dir, body) ->
795 let lbl_loop = new_label() in
796 let lbl_exit = new_label() in
797 let offset = match dir with Upto -> 1 | Downto -> -1 in
798 let comp = match dir with Upto -> Cgt | Downto -> Clt in
799 comp_expr env start sz
800 (Kpush :: comp_expr env stop (sz+1)
801 (Kpush :: Kpush :: Kacc 2 :: Kintcomp comp :: Kbranchif lbl_exit ::
802 Klabel lbl_loop :: Kcheck_signals ::
803 comp_expr (add_var param (sz+1) env) body (sz+2)
804 (Kacc 1 :: Kpush :: Koffsetint offset :: Kassign 2 ::
805 Kacc 1 :: Kintcomp Cne :: Kbranchif lbl_loop ::
806 Klabel lbl_exit :: add_const_unit (add_pop 2 cont))))
807 | Lswitch(arg, sw, _loc) ->
808 let (branch, cont1) = make_branch cont in
809 let c = ref (discard_dead_code cont1) in
810
811 (* Build indirection vectors *)
812 let store = Storer.mk_store () in
813 let act_consts = Array.make sw.sw_numconsts 0
814 and act_blocks = Array.make sw.sw_numblocks 0 in
815 begin match sw.sw_failaction with (* default is index 0 *)
816 | Some fail -> ignore (store.act_store () fail)
817 | None -> ()
818 end ;
819 List.iter
820 (fun (n, act) -> act_consts.(n) <- store.act_store () act) sw.sw_consts;
821 List.iter
822 (fun (n, act) -> act_blocks.(n) <- store.act_store () act) sw.sw_blocks;
823 (* Compile and label actions *)
824 let acts = store.act_get () in
825 (*
826 let a = store.act_get_shared () in
827 Array.iter
828 (function
829 | Switch.Shared (Lstaticraise _) -> ()
830 | Switch.Shared act ->
831 Printlambda.lambda Format.str_formatter act ;
832 Printf.eprintf "SHARE BYTE:\n%s\n" (Format.flush_str_formatter ())
833 | _ -> ())
834 a ;
835 *)
836 let lbls = Array.make (Array.length acts) 0 in
837 for i = Array.length acts-1 downto 0 do
838 let lbl,c1 = label_code (comp_expr env acts.(i) sz (branch :: !c)) in
839 lbls.(i) <- lbl ;
840 c := discard_dead_code c1
841 done ;
842
843 (* Build label vectors *)
844 let lbl_blocks = Array.make sw.sw_numblocks 0 in
845 for i = sw.sw_numblocks - 1 downto 0 do
846 lbl_blocks.(i) <- lbls.(act_blocks.(i))
847 done;
848 let lbl_consts = Array.make sw.sw_numconsts 0 in
849 for i = sw.sw_numconsts - 1 downto 0 do
850 lbl_consts.(i) <- lbls.(act_consts.(i))
851 done;
852 comp_expr env arg sz (Kswitch(lbl_consts, lbl_blocks) :: !c)
853 | Lstringswitch (arg,sw,d,loc) ->
854 comp_expr env (Matching.expand_stringswitch loc arg sw d) sz cont
855 | Lassign(id, expr) ->
856 begin try
857 let pos = Ident.find_same id env.ce_stack in
858 comp_expr env expr sz (Kassign(sz - pos) :: cont)
859 with Not_found ->
860 fatal_error "Bytegen.comp_expr: assign"
861 end
862 | Levent(lam, lev) ->
863 let event kind info =
864 { ev_pos = 0; (* patched in emitcode *)
865 ev_module = !compunit_name;
866 ev_loc = lev.lev_loc;
867 ev_kind = kind;
868 ev_info = info;
869 ev_typenv = Env.summary lev.lev_env;
870 ev_typsubst = Subst.identity;
871 ev_compenv = env;
872 ev_stacksize = sz;
873 ev_repr =
874 begin match lev.lev_repr with
875 None ->
876 Event_none
877 | Some ({contents = 1} as repr) when lev.lev_kind = Lev_function ->
878 Event_child repr
879 | Some ({contents = 1} as repr) ->
880 Event_parent repr
881 | Some repr when lev.lev_kind = Lev_function ->
882 Event_parent repr
883 | Some repr ->
884 Event_child repr
885 end }
886 in
887 begin match lev.lev_kind with
888 Lev_before ->
889 let c = comp_expr env lam sz cont in
890 let ev = event Event_before Event_other in
891 add_event ev c
892 | Lev_function ->
893 let c = comp_expr env lam sz cont in
894 let ev = event Event_pseudo Event_function in
895 add_event ev c
896 | Lev_pseudo ->
897 let c = comp_expr env lam sz cont in
898 let ev = event Event_pseudo Event_other in
899 add_event ev c
900 | Lev_after _ when is_tailcall cont -> (* don't destroy tail call opt *)
901 comp_expr env lam sz cont
902 | Lev_after ty ->
903 let info =
904 match lam with
905 Lapply{ap_args = args} -> Event_return (List.length args)
906 | Lsend(_, _, _, args, _) -> Event_return (List.length args + 1)
907 | _ -> Event_other
908 in
909 let ev = event (Event_after ty) info in
910 let cont1 = add_event ev cont in
911 comp_expr env lam sz cont1
912 | Lev_module_definition _ ->
913 comp_expr env lam sz cont
914 end
915 | Lifused (_, exp) ->
916 comp_expr env exp sz cont
917
918 (* Compile a list of arguments [e1; ...; eN] to a primitive operation.
919 The values of eN ... e2 are pushed on the stack, e2 at top of stack,
920 then e3, then ... The value of e1 is left in the accumulator. *)
921
922 and comp_args env argl sz cont =
923 comp_expr_list env (List.rev argl) sz cont
924
925 and comp_expr_list env exprl sz cont = match exprl with
926 [] -> cont
927 | [exp] -> comp_expr env exp sz cont
928 | exp :: rem ->
929 comp_expr env exp sz (Kpush :: comp_expr_list env rem (sz+1) cont)
930
931 and comp_exit_args env argl sz pos cont =
932 comp_expr_list_assign env (List.rev argl) sz pos cont
933
934 and comp_expr_list_assign env exprl sz pos cont = match exprl with
935 | [] -> cont
936 | exp :: rem ->
937 comp_expr env exp sz
938 (Kassign (sz-pos)::comp_expr_list_assign env rem sz (pos-1) cont)
939
940 (* Compile an if-then-else test. *)
941
942 and comp_binary_test env cond ifso ifnot sz cont =
943 let cont_cond =
944 if ifnot = Lconst const_unit then begin
945 let (lbl_end, cont1) = label_code cont in
946 Kstrictbranchifnot lbl_end :: comp_expr env ifso sz cont1
947 end else
948 match code_as_jump ifso sz with
949 | Some label ->
950 let cont = comp_expr env ifnot sz cont in
951 Kbranchif label :: cont
952 | _ ->
953 match code_as_jump ifnot sz with
954 | Some label ->
955 let cont = comp_expr env ifso sz cont in
956 Kbranchifnot label :: cont
957 | _ ->
958 let (branch_end, cont1) = make_branch cont in
959 let (lbl_not, cont2) = label_code(comp_expr env ifnot sz cont1) in
960 Kbranchifnot lbl_not ::
961 comp_expr env ifso sz (branch_end :: cont2) in
962
963 comp_expr env cond sz cont_cond
964
965 (**** Compilation of a code block (with tracking of stack usage) ****)
966
967 let comp_block env exp sz cont =
968 max_stack_used := 0;
969 let code = comp_expr env exp sz cont in
970 let used_safe = !max_stack_used + Config.stack_safety_margin in
971 if used_safe > Config.stack_threshold then
972 Kconst(Const_base(Const_int used_safe)) ::
973 Kccall("caml_ensure_stack_capacity", 1) ::
974 code
975 else
976 code
977
978 (**** Compilation of functions ****)
979
980 let comp_function tc cont =
981 let arity = List.length tc.params in
982 let rec positions pos delta = function
983 [] -> Ident.empty
984 | id :: rem -> Ident.add id pos (positions (pos + delta) delta rem) in
985 let env =
986 { ce_stack = positions arity (-1) tc.params;
987 ce_heap = positions (2 * (tc.num_defs - tc.rec_pos) - 1) 1 tc.free_vars;
988 ce_rec = positions (-2 * tc.rec_pos) 2 tc.rec_vars } in
989 let cont =
990 comp_block env tc.body arity (Kreturn arity :: cont) in
991 if arity > 1 then
992 Krestart :: Klabel tc.label :: Kgrab(arity - 1) :: cont
993 else
994 Klabel tc.label :: cont
995
996 let comp_remainder cont =
997 let c = ref cont in
998 begin try
999 while true do
1000 c := comp_function (Stack.pop functions_to_compile) !c
1001 done
1002 with Stack.Empty ->
1003 ()
1004 end;
1005 !c
1006
1007 (**** Compilation of a lambda phrase ****)
1008
1009 let compile_implementation modulename expr =
1010 Stack.clear functions_to_compile;
1011 label_counter := 0;
1012 sz_static_raises := [] ;
1013 compunit_name := modulename;
1014 let init_code = comp_block empty_env expr 0 [] in
1015 if Stack.length functions_to_compile > 0 then begin
1016 let lbl_init = new_label() in
1017 Kbranch lbl_init :: comp_remainder (Klabel lbl_init :: init_code)
1018 end else
1019 init_code
1020
1021 let compile_phrase expr =
1022 Stack.clear functions_to_compile;
1023 label_counter := 0;
1024 sz_static_raises := [] ;
1025 let init_code = comp_block empty_env expr 1 [Kreturn 1] in
1026 let fun_code = comp_remainder [] in
1027 (init_code, fun_code)
1028
1029 let reset () =
1030 label_counter := 0;
1031 sz_static_raises := [];
1032 compunit_name := "";
1033 Stack.clear functions_to_compile;
1034 max_stack_used := 0
1035