anil.recoil.org
My working unpac repository
1(**************************************************************************)
2(* *)
3(* OCaml *)
4(* *)
5(* Vincent Laviron, OCamlPro *)
6(* *)
7(* Copyright 2023 OCamlPro SAS *)
8(* *)
9(* All rights reserved. This file is distributed under the terms of *)
10(* the GNU Lesser General Public License version 2.1, with the *)
11(* special exception on linking described in the file LICENSE. *)
12(* *)
13(**************************************************************************)
14
15(** Compilation of generic recursive definitions *)
16
17(** The surface language allows a wide range of recursive definitions, but
18 Lambda only allows syntactic functions in recursive bindings.
19 This file implements the translation from generic definitions to Lambda.
20
21 The first step occurs during typechecking, in [Value_rec_check]:
22 [Dynamic] bindings need to be compiled as normal let bindings. This file
23 mostly deals with the [Static] bindings.
24
25 The three phases in this module are the following:
26
27 - Sizing: we first classify the definitions by their size, which determines
28 the compilation strategy for each binding.
29
30 - Function lifting: we then apply a transformation from general function
31 definitions to syntactic functions accepted by [Lletrec].
32 Examples:
33 {[
34 let rec f x = f x (* Syntactic *)
35 let rec f = fun x -> f x (* Syntactic *)
36 let rec f = let g x = f x in g (* Not syntactic *)
37 let rec f = let a = ... in (fun x -> f x) (* Not syntactic *)
38 ]}
39
40 - Compilation: we finally combine all of this to produce a Lambda term
41 for the recursive bindings.
42*)
43
44open Lambda
45
46(** Allocation and backpatching primitives *)
47
48let alloc_prim =
49 Primitive.simple ~name:"caml_alloc_dummy" ~arity:1 ~alloc:true
50
51let alloc_float_record_prim =
52 Primitive.simple ~name:"caml_alloc_dummy_float" ~arity:1 ~alloc:true
53
54let alloc_lazy_prim =
55 Primitive.simple ~name:"caml_alloc_dummy_lazy" ~arity:1 ~alloc:true
56
57let update_prim =
58 (* Note: [alloc] could be false, but it probably doesn't matter *)
59 Primitive.simple ~name:"caml_update_dummy" ~arity:2 ~alloc:true
60
61let update_lazy_prim =
62 Primitive.simple ~name:"caml_update_dummy_lazy" ~arity:2 ~alloc:true
63
64
65(** {1. Sizing} *)
66
67(* Simple blocks *)
68type block_size =
69 | Regular_block of int
70 | Float_record of int
71 | Lazy_block
72
73type size =
74 | Unreachable
75 (** Non-returning expressions, like [raise exn].
76 In [Value_rec_check], they would be classified as [Dynamic],
77 but some of those appear during translation to Lambda.
78 For example, in [let rec f = let [| x |] = ... in fun y -> x + y]
79 the inner let binding gets translated to code that raises
80 [Match_failure] for non-matching branches.
81 Tracking [Unreachable] explicitly allows us to recover the size
82 of the only non-raising branch. *)
83 | Constant
84 (** Constant values.
85 Can be either an integer-like constant ([0], ['a'], [None],
86 the empty list or the unit constructor), or a structured constant
87 (["hello"], [Some 1], ...).
88
89 Integer constants cannot be pre-allocated, so need their own
90 classification and compilation scheme (See {!Compilation} below).
91 Structured constants could fit into the [Block] category, but we
92 choose to reuse the [constant] classification to avoid sorting
93 through the [Lconst] definitions.
94 It also generates slightly better code. *)
95 | Function
96 (** Function definitions.
97 This includes more than just obvious, syntactic function definitions;
98 see {!Function Lifting} for details. *)
99 | Block of block_size
100 (** Allocated values of a fixed size.
101 This corresponds to expressions ending in a single obvious allocation,
102 but also some more complex expressions where the block is bound to
103 an intermediate variable before being returned.
104 *)
105
106type binding_size = (lambda_with_env, size) Lazy_backtrack.t
107and lambda_with_env = {
108 lambda : lambda;
109 env : binding_size Ident.Map.t;
110}
111
112let dynamic_size () =
113 Misc.fatal_error "letrec: No size found for Static binding"
114
115(* [join_sizes] is used to compute the size of an expression with multiple
116 branches. Such expressions are normally classified as [Dynamic] by
117 [Value_rec_check], so the default behaviour is a compile-time failure.
118 However, for partial pattern-matching (typically in let bindings)
119 the compiler will later add a branch for the failing cases, and this
120 is handled here with the [Unreachable] case.
121 Note that the current compilation scheme would work if we allowed the
122 [Constant] and [Block] cases to be joined, but [Function] needs to be
123 a single function. *)
124let join_sizes size1 size2 =
125 match size1, size2 with
126 | Unreachable, size | size, Unreachable -> size
127 | _, _ -> dynamic_size ()
128
129(* We need to recognize the Pmakeblock that we transformed into
130 primitive calls, to support size compilation in nested recursive
131 definitions. Consider this example from Vincent Laviron:
132 {[let f a =
133 let rec x =
134 let rec y = Some a in y
135 in x
136 ]}
137
138 [let rec y = Some a in y] gets compiled to
139 {[let y = caml_alloc_dummy 1 in
140 caml_update_dummy(y, ...);
141 y]}
142 and we need to recognize from this definition that this
143 value has known size [1].
144*)
145let find_size_of_alloc_prim prim args =
146 let same_as other_prim =
147 let open Primitive in
148 String.equal prim.prim_name other_prim.prim_name
149 in
150 let int_arg = match args with
151 | [Lconst (Const_int n)] -> Some n
152 | _ -> None
153 in
154 if same_as alloc_prim then
155 Option.map (fun n -> Regular_block n) int_arg
156 else if same_as alloc_float_record_prim then
157 Option.map (fun n -> Float_record n) int_arg
158 else if same_as alloc_lazy_prim then
159 Some Lazy_block
160 else None
161
162let compute_static_size lam =
163 let rec compute_expression_size env lam =
164 match lam with
165 | Lvar v ->
166 begin match Ident.Map.find_opt v env with
167 | None ->
168 dynamic_size ()
169 | Some binding_size ->
170 Lazy_backtrack.force
171 (fun { lambda; env } -> compute_expression_size env lambda)
172 binding_size
173 end
174 | Lmutvar _ -> dynamic_size ()
175 | Lconst _ -> Constant
176 | Lapply _ -> dynamic_size ()
177 | Lfunction _ -> Function
178 | Llet (_, _, id, def, body) ->
179 let env =
180 Ident.Map.add id (Lazy_backtrack.create { lambda = def; env }) env
181 in
182 compute_expression_size env body
183 | Lmutlet(_, _, _, body) ->
184 compute_expression_size env body
185 | Lletrec (bindings, body) ->
186 let env =
187 List.fold_left (fun env_acc { id; def = _ } ->
188 Ident.Map.add id (Lazy_backtrack.create_forced Function) env_acc)
189 env bindings
190 in
191 compute_expression_size env body
192 | Lprim (p, args, _) ->
193 size_of_primitive env p args
194 | Lswitch (_, sw, _) ->
195 let fail_case =
196 match sw.sw_failaction with
197 | None -> []
198 | Some fail -> [0 (* ignored *), fail]
199 in
200 compute_and_join_sizes_switch env [sw.sw_consts; sw.sw_blocks; fail_case]
201 | Lstringswitch (_, cases, fail, _) ->
202 let fail_case =
203 match fail with
204 | None -> []
205 | Some fail -> ["" (* ignored *), fail]
206 in
207 compute_and_join_sizes_switch env [cases; fail_case]
208 | Lstaticraise _ -> Unreachable
209 | Lstaticcatch (body, _, handler)
210 | Ltrywith (body, _, handler) ->
211 compute_and_join_sizes env [body; handler]
212 | Lifthenelse (_cond, ifso, ifnot) ->
213 compute_and_join_sizes env [ifso; ifnot]
214 | Lsequence (_, e) ->
215 compute_expression_size env e
216 | Lwhile _
217 | Lfor _
218 | Lassign _ -> Constant
219 | Lsend _ -> dynamic_size ()
220 | Levent (e, _) ->
221 compute_expression_size env e
222 | Lifused _ -> Constant
223 and compute_and_join_sizes env branches =
224 List.fold_left (fun size branch ->
225 join_sizes size (compute_expression_size env branch))
226 Unreachable branches
227 and compute_and_join_sizes_switch :
228 type a. binding_size Ident.Map.t -> (a * lambda) list list -> size =
229 fun env all_cases ->
230 List.fold_left (fun size cases ->
231 List.fold_left (fun size (_key, action) ->
232 join_sizes size (compute_expression_size env action))
233 size cases)
234 Unreachable all_cases
235 and size_of_primitive env p args =
236 match p with
237 | Pignore
238 | Psetfield _
239 | Psetfield_computed _
240 | Psetfloatfield _
241 | Poffsetint _
242 | Poffsetref _
243 | Pbytessetu
244 | Pbytessets
245 | Parraysetu _
246 | Parraysets _
247 | Pbigarrayset _
248 | Pbytes_set_16 _
249 | Pbytes_set_32 _
250 | Pbytes_set_64 _
251 | Pbigstring_set_16 _
252 | Pbigstring_set_32 _
253 | Pbigstring_set_64 _
254 | Ppoll ->
255 (* Unit-returning primitives. Most of these are only generated from
256 external declarations and not special-cased by [Value_rec_check],
257 but it doesn't hurt to be consistent. *)
258 Constant
259
260 | Pduprecord (repres, size) ->
261 begin match repres with
262 | Record_regular | Record_inlined _ | Record_extension _ ->
263 Block (Regular_block size)
264 | Record_float ->
265 Block (Float_record size)
266 | Record_unboxed _ ->
267 Misc.fatal_error "size_of_primitive"
268 end
269 | Pmakeblock _ ->
270 (* The block shape is unfortunately an option, so we rely on the
271 number of arguments instead.
272 Note that flat float arrays/records use Pmakearray, so we don't need
273 to check the tag here. *)
274 Block (Regular_block (List.length args))
275 | Pmakelazyblock _ ->
276 Block Lazy_block
277 | Pmakearray (kind, _) ->
278 let size = List.length args in
279 begin match kind with
280 | Pgenarray | Paddrarray | Pintarray ->
281 Block (Regular_block size)
282 | Pfloatarray ->
283 Block (Float_record size)
284 end
285 | Pduparray _ ->
286 (* The size has to be recovered from the size of the argument *)
287 begin match args with
288 | [arg] ->
289 compute_expression_size env arg
290 | [] | _ :: _ :: _ ->
291 Misc.fatal_error "size_of_primitive"
292 end
293
294 | Praise _ ->
295 Unreachable
296
297 | Pctconst _ ->
298 (* These primitives are not special-cased by [Value_rec_check],
299 so we should never end up here; but these are constants anyway. *)
300 Constant
301
302 | Pccall prim ->
303 begin match find_size_of_alloc_prim prim args with
304 | Some size -> Block size
305 | None -> dynamic_size ()
306 end
307
308 | Pbytes_to_string
309 | Pbytes_of_string
310 | Pgetglobal _
311 | Psetglobal _
312 | Pfield _
313 | Pfield_computed
314 | Pfloatfield _
315 | Prunstack
316 | Pperform
317 | Presume
318 | Preperform
319 | Psequand | Psequor | Pnot
320 | Pnegint | Paddint | Psubint | Pmulint
321 | Pdivint _ | Pmodint _
322 | Pandint | Porint | Pxorint
323 | Plslint | Plsrint | Pasrint
324 | Pintcomp _
325 | Pcompare_ints | Pcompare_floats | Pcompare_bints _
326 | Pintoffloat | Pfloatofint
327 | Pnegfloat | Pabsfloat
328 | Paddfloat | Psubfloat | Pmulfloat | Pdivfloat
329 | Pfloatcomp _
330 | Pstringlength | Pstringrefu | Pstringrefs
331 | Pbyteslength | Pbytesrefu | Pbytesrefs
332 | Parraylength _
333 | Parrayrefu _
334 | Parrayrefs _
335 | Pisint
336 | Pisout
337 | Pbintofint _
338 | Pintofbint _
339 | Pcvtbint _
340 | Pnegbint _
341 | Paddbint _
342 | Psubbint _
343 | Pmulbint _
344 | Pdivbint _
345 | Pmodbint _
346 | Pandbint _
347 | Porbint _
348 | Pxorbint _
349 | Plslbint _
350 | Plsrbint _
351 | Pasrbint _
352 | Pbintcomp _
353 | Pbigarrayref _
354 | Pbigarraydim _
355 | Pstring_load_16 _
356 | Pstring_load_32 _
357 | Pstring_load_64 _
358 | Pbytes_load_16 _
359 | Pbytes_load_32 _
360 | Pbytes_load_64 _
361 | Pbigstring_load_16 _
362 | Pbigstring_load_32 _
363 | Pbigstring_load_64 _
364 | Pbswap16
365 | Pbbswap _
366 | Pint_as_pointer
367 | Patomic_load
368 | Popaque
369 | Pdls_get ->
370 dynamic_size ()
371 in
372 compute_expression_size Ident.Map.empty lam
373
374let lfunction_with_body { kind; params; return; body = _; attr; loc } body =
375 lfunction' ~kind ~params ~return ~body ~attr ~loc
376
377(** {1. Function Lifting} *)
378
379(* The compiler allows recursive definitions of functions that are not
380 syntactic functions:
381 {[
382 let rec f_syntactic_function = fun x ->
383 f_syntactic_function x
384
385 let rec g_needs_lift =
386 let () = ... in
387 (fun x -> g_needs_lift (foo x))
388
389 let rec h_needs_lift_and_closure =
390 let v = ref 0 in
391 (fun x -> incr v; h_needs_lift_and_closure (bar x))
392
393 let rec i_needs_lift_and_eta =
394 let aux x = i_needs_lift_and_eta (baz x) in
395 aux
396 ]}
397
398 We need to translate those using only syntactic functions or blocks.
399 For some functions, we only need to lift a syntactic function in tail
400 position from its surrounding context:
401 {[
402 let rec g_context =
403 let () = ... in
404 ()
405 and g_lifted = fun x ->
406 g_lifted (foo x)
407 ]}
408
409 In general the function may refer to local variables, so we perform
410 a local closure conversion before lifting:
411 {[
412 let rec h_context =
413 let v = ref 0 in
414 { v }
415 and h_lifted = fun x ->
416 incr h_context.v;
417 h_lifted (bar x)
418 ]}
419 Note that the closure environment computed from the context is passed as a
420 mutually recursive definition, that is, a free variable, and not as an
421 additional function parameter (which is customary for closure conversion).
422
423 Finally, when the tail expression is a variable, we perform an eta-expansion
424 to get a syntactic function, that we can then close and lift:
425 {[
426 let rec i_context =
427 let aux x = i_lifted (baz x) in
428 { aux }
429 and i_lifted = fun x -> i_context.aux x
430 ]}
431*)
432
433type lifted_function =
434 { lfun : Lambda.lfunction;
435 free_vars_block_size : int;
436 }
437
438type 'a split_result =
439 | Unreachable
440 | Reachable of lifted_function * 'a
441
442let ( let+ ) res f =
443 match res with
444 | Unreachable -> Unreachable
445 | Reachable (func, lam) -> Reachable (func, f lam)
446
447(* The closure blocks are immutable.
448 (Note: It is usually safe to declare immutable blocks as mutable,
449 but in this case the blocks might be empty and declaring them as Mutable
450 would cause errors later.) *)
451let lifted_block_mut : Asttypes.mutable_flag = Immutable
452
453let no_loc = Debuginfo.Scoped_location.Loc_unknown
454
455let rec split_static_function block_var local_idents lam :
456 Lambda.lambda split_result =
457 match lam with
458 | Lvar v ->
459 (* Eta-expand *)
460 (* Note: knowing the arity might let us generate slightly better code *)
461 let param = Ident.create_local "let_rec_param" in
462 let ap_func =
463 Lprim (Pfield (0, Pointer, lifted_block_mut), [Lvar block_var], no_loc)
464 in
465 let body =
466 Lapply {
467 ap_func;
468 ap_args = [Lvar param];
469 ap_loc = no_loc;
470 ap_tailcall = Default_tailcall;
471 ap_inlined = Default_inline;
472 ap_specialised = Default_specialise;
473 }
474 in
475 let wrapper =
476 lfunction'
477 ~kind:Curried
478 ~params:[param, Pgenval]
479 ~return:Pgenval
480 ~body
481 ~attr:default_stub_attribute
482 ~loc:no_loc
483 in
484 let lifted = { lfun = wrapper; free_vars_block_size = 1 } in
485 Reachable (lifted,
486 Lprim (Pmakeblock (0, lifted_block_mut, None), [Lvar v], no_loc))
487 | Lfunction lfun ->
488 let free_vars = Lambda.free_variables lfun.body in
489 let local_free_vars = Ident.Set.inter free_vars local_idents in
490 let free_vars_block_size, subst, block_fields_rev =
491 Ident.Set.fold (fun var (i, subst, fields) ->
492 let access =
493 Lprim (Pfield (i, Pointer, lifted_block_mut),
494 [Lvar block_var],
495 no_loc)
496 in
497 (succ i, Ident.Map.add var access subst, Lvar var :: fields))
498 local_free_vars (0, Ident.Map.empty, [])
499 in
500 (* Note: When there are no local free variables, we don't need the
501 substitution and we don't need to generate code for pre-allocating
502 and backpatching a block of size 0.
503 However, the general scheme also works and it's unlikely to be
504 noticeably worse, so we use it for simplicity. *)
505 let new_fun =
506 lfunction_with_body lfun
507 (Lambda.subst (fun _ _ env -> env) subst lfun.body)
508 in
509 let lifted = { lfun = new_fun; free_vars_block_size } in
510 let block =
511 Lprim (Pmakeblock (0, lifted_block_mut, None),
512 List.rev block_fields_rev,
513 no_loc)
514 in
515 Reachable (lifted, block)
516 | Llet (lkind, vkind, var, def, body) ->
517 let+ body =
518 split_static_function block_var (Ident.Set.add var local_idents) body
519 in
520 Llet (lkind, vkind, var, def, body)
521 | Lmutlet (vkind, var, def, body) ->
522 let+ body =
523 split_static_function block_var (Ident.Set.add var local_idents) body
524 in
525 Lmutlet (vkind, var, def, body)
526 | Lletrec (bindings, body) ->
527 let local_idents =
528 List.fold_left (fun ids { id } -> Ident.Set.add id ids)
529 local_idents bindings
530 in
531 let+ body =
532 split_static_function block_var local_idents body
533 in
534 Lletrec (bindings, body)
535 | Lprim (Praise _, _, _) -> Unreachable
536 | Lstaticraise _ -> Unreachable
537 | Lswitch (arg, sw, loc) ->
538 let sw_consts_res = rebuild_arms block_var local_idents sw.sw_consts in
539 let sw_blocks_res = rebuild_arms block_var local_idents sw.sw_blocks in
540 let sw_failaction_res =
541 Option.map (split_static_function block_var local_idents) sw.sw_failaction
542 in
543 begin match sw_consts_res, sw_blocks_res, sw_failaction_res with
544 | Unreachable, Unreachable, (None | Some Unreachable) -> Unreachable
545 | Reachable (lfun, sw_consts), Unreachable, (None | Some Unreachable) ->
546 Reachable (lfun, Lswitch (arg, { sw with sw_consts }, loc))
547 | Unreachable, Reachable (lfun, sw_blocks), (None | Some Unreachable) ->
548 Reachable (lfun, Lswitch (arg, { sw with sw_blocks }, loc))
549 | Unreachable, Unreachable, Some (Reachable (lfun, failaction)) ->
550 let switch =
551 Lswitch (arg, { sw with sw_failaction = Some failaction }, loc)
552 in
553 Reachable (lfun, switch)
554 | Reachable _, Reachable _, _ | Reachable _, _, Some (Reachable _)
555 | _, Reachable _, Some (Reachable _) ->
556 Misc.fatal_error "letrec: multiple functions"
557 end
558 | Lstringswitch (arg, arms, failaction, loc) ->
559 let arms_res = rebuild_arms block_var local_idents arms in
560 let failaction_res =
561 Option.map (split_static_function block_var local_idents) failaction
562 in
563 begin match arms_res, failaction_res with
564 | Unreachable, (None | Some Unreachable) -> Unreachable
565 | Reachable (lfun, arms), (None | Some Unreachable) ->
566 Reachable (lfun, Lstringswitch (arg, arms, failaction, loc))
567 | Unreachable, Some (Reachable (lfun, failaction)) ->
568 Reachable (lfun, Lstringswitch (arg, arms, Some failaction, loc))
569 | Reachable _, Some (Reachable _) ->
570 Misc.fatal_error "letrec: multiple functions"
571 end
572 | Lstaticcatch (body, (nfail, params), handler) ->
573 let body_res = split_static_function block_var local_idents body in
574 let handler_res =
575 let local_idents =
576 List.fold_left (fun vars (var, _) -> Ident.Set.add var vars)
577 local_idents params
578 in
579 split_static_function block_var local_idents handler
580 in
581 begin match body_res, handler_res with
582 | Unreachable, Unreachable -> Unreachable
583 | Reachable (lfun, body), Unreachable ->
584 Reachable (lfun, Lstaticcatch (body, (nfail, params), handler))
585 | Unreachable, Reachable (lfun, handler) ->
586 Reachable (lfun, Lstaticcatch (body, (nfail, params), handler))
587 | Reachable _, Reachable _ ->
588 Misc.fatal_error "letrec: multiple functions"
589 end
590 | Ltrywith (body, exn_var, handler) ->
591 let body_res = split_static_function block_var local_idents body in
592 let handler_res =
593 split_static_function block_var
594 (Ident.Set.add exn_var local_idents) handler
595 in
596 begin match body_res, handler_res with
597 | Unreachable, Unreachable -> Unreachable
598 | Reachable (lfun, body), Unreachable ->
599 Reachable (lfun, Ltrywith (body, exn_var, handler))
600 | Unreachable, Reachable (lfun, handler) ->
601 Reachable (lfun, Ltrywith (body, exn_var, handler))
602 | Reachable _, Reachable _ ->
603 Misc.fatal_error "letrec: multiple functions"
604 end
605 | Lifthenelse (cond, ifso, ifnot) ->
606 let ifso_res = split_static_function block_var local_idents ifso in
607 let ifnot_res = split_static_function block_var local_idents ifnot in
608 begin match ifso_res, ifnot_res with
609 | Unreachable, Unreachable -> Unreachable
610 | Reachable (lfun, ifso), Unreachable ->
611 Reachable (lfun, Lifthenelse (cond, ifso, ifnot))
612 | Unreachable, Reachable (lfun, ifnot) ->
613 Reachable (lfun, Lifthenelse (cond, ifso, ifnot))
614 | Reachable _, Reachable _ ->
615 Misc.fatal_error "letrec: multiple functions"
616 end
617 | Lsequence (e1, e2) ->
618 let+ e2 = split_static_function block_var local_idents e2 in
619 Lsequence (e1, e2)
620 | Levent (lam, lev) ->
621 let+ lam = split_static_function block_var local_idents lam in
622 Levent (lam, lev)
623 | Lmutvar _
624 | Lconst _
625 | Lapply _
626 | Lprim _
627 | Lwhile _
628 | Lfor _
629 | Lassign _
630 | Lsend _
631 | Lifused _ -> Misc.fatal_error "letrec binding is not a static function"
632and rebuild_arms :
633 type a. _ -> _ -> (a * Lambda.lambda) list ->
634 (a * Lambda.lambda) list split_result =
635 fun block_var local_idents arms ->
636 match arms with
637 | [] -> Unreachable
638 | (i, lam) :: arms ->
639 let res = rebuild_arms block_var local_idents arms in
640 let lam_res = split_static_function block_var local_idents lam in
641 match lam_res, res with
642 | Unreachable, Unreachable -> Unreachable
643 | Reachable (lfun, lam), Unreachable ->
644 Reachable (lfun, (i, lam) :: arms)
645 | Unreachable, Reachable (lfun, arms) ->
646 Reachable (lfun, (i, lam) :: arms)
647 | Reachable _, Reachable _ ->
648 Misc.fatal_error "letrec: multiple functions"
649
650(** {1. Compilation} *)
651
652(** The bindings are split into three categories.
653 Static bindings are the ones that we can pre-allocate and backpatch later.
654 Function bindings are syntactic functions.
655 Dynamic bindings are non-recursive expressions.
656
657 The evaluation order is as follows:
658 - Evaluate all dynamic bindings
659 - Pre-allocate all static bindings
660 - Define all functions
661 - Backpatch all static bindings
662
663 Constants (and unreachable expressions) end up in the dynamic category,
664 because we substitute all occurrences of recursive variables in their
665 definition by a dummy expression, making them non-recursive.
666
667 This is correct because:
668 - [Value_rec_check] ensured that they never dereference the value of
669 those recursive variables
670 - their final value cannot depend on them either.
671
672 Functions that are not already in syntactic form also generate an additional
673 binding for the context. This binding fits into the static category.
674
675 Example input:
676 {[
677 let rec a x =
678 (* syntactic function *)
679 b x
680 and b =
681 (* non-syntactic function *)
682 let tbl = Hashtbl.make 17 in
683 fun x -> ... (tbl, c, a) ...
684 and c =
685 (* block *)
686 Some (d, default)
687 and d =
688 (* 'dynamic' value (not recursive *)
689 Array.make 5 0
690 and default =
691 (* constant, with (spurious) use
692 of a recursive neighbor *)
693 let _ = a in
694 42
695 ]}
696
697 Example output:
698 {[
699 (* Dynamic bindings *)
700 let d = Array.make 5 0
701 let default =
702 let _ = *dummy_rec_value* in
703 42
704
705 (* Pre-allocations *)
706 let c = caml_alloc_dummy 2
707 let b_context = caml_alloc_dummy 1
708
709 (* Functions *)
710 let rec a x = b x
711 and b =
712 fun x -> ... (b_context.tbl, c, a) ...
713
714 (* Backpatching *)
715 let () =
716 caml_update_dummy c (Some (d, default));
717 caml_update_dummy b_context
718 (let tbl = Hashtbl.make 17 in
719 { tbl })
720 ]}
721
722 Note on performance for non-syntactic functions:
723 The compiler would previously pre-allocate and backpatch function
724 closures. The new approach is designed to avoid back-patching
725 closures -- besides, we could not pre-allocate at this point in the
726 compiler pipeline, as the closure size will only be determined later.
727
728 For non-syntactic functions with local free variables, we now store the
729 local free variables in a block, which incurs an additional indirection
730 whenever a local variable is accessed by the function. On the other hand,
731 we generate regular function definitions, so the rest of the compiler
732 can either inline them or generate direct calls, and use the compact
733 representation for mutually recursive closures.
734 *)
735
736type rec_bindings =
737 { static : (Ident.t * block_size * Lambda.lambda) list;
738 functions : (Ident.t * Lambda.lfunction) list;
739 dynamic : (Ident.t * Lambda.lambda) list;
740 }
741
742let empty_bindings =
743 { static = [];
744 functions = [];
745 dynamic = [];
746 }
747
748(** Allocation and backpatching code *)
749
750let compile_indirect newval =
751 let indirect = Lambda.transl_prim "CamlinternalLazy" "indirect" in
752 Lapply {
753 ap_func = indirect;
754 ap_args = [newval];
755 ap_loc = no_loc;
756 ap_tailcall = Default_tailcall;
757 ap_inlined = Default_inline;
758 ap_specialised = Default_specialise;
759 }
760
761let compile_alloc size =
762 let alloc prim size =
763 Lprim (Pccall prim,
764 [Lconst (Lambda.const_int size)],
765 no_loc)
766 in
767 (* if you add new allocation primitives below,
768 you should update {!find_size_of_alloc_prim} as well. *)
769 match size with
770 | Regular_block size ->
771 alloc alloc_prim size
772 | Float_record size ->
773 alloc alloc_float_record_prim size
774 | Lazy_block ->
775 Lprim(Pccall alloc_lazy_prim,
776 [Lambda.lambda_unit],
777 no_loc)
778
779let compile_update size dummy newval =
780 let prim, newval =
781 match size with
782 | Regular_block _ | Float_record _ ->
783 update_prim, newval
784 | Lazy_block ->
785 (* Consider the following example from Vincent Laviron:
786 {[let rec v =
787 let l = lazy (expensive computation) in
788 let () = maybe_force_in_another_domain l in
789 l
790 ]}
791
792 The naive/simple compilation scheme would do
793 a [caml_update_dummy_lazy(v, l)], and the dummy-update code
794 could run concurrently with another domain forcing [l].
795
796 To avoid this issue, lazy blocks get updated via
797 [caml_update_dummy_lazy(dummy, CamlinternalLazy.indirect newval)],
798 where [CamlinternalLazy.indirect] returns a fresh/local thunk
799 that is not getting forced concurrently (whereas [newval]
800 might be).
801 *)
802 update_lazy_prim,
803 begin match newval with
804 | Lprim(Pmakelazyblock _, _, _) ->
805 (* No need to wrap the thunk if was just constructed.
806 This removes indirections on terms defined as lazy thunks
807 at the toplevel: [let rec x = lazy ...] *)
808 newval
809 | _ -> compile_indirect newval
810 end
811 in
812 Lprim (Pccall prim, [dummy; newval],
813 no_loc)
814
815(** Compilation function *)
816
817let compile_letrec input_bindings body =
818 let subst_for_constants =
819 List.fold_left (fun subst (id, _, _) ->
820 Ident.Map.add id Lambda.dummy_constant subst)
821 Ident.Map.empty input_bindings
822 in
823 let all_bindings_rev =
824 List.fold_left (fun rev_bindings (id, rkind, def) ->
825 match (rkind : Value_rec_types.recursive_binding_kind) with
826 | Dynamic ->
827 { rev_bindings with dynamic = (id, def) :: rev_bindings.dynamic }
828 | Static ->
829 let size = compute_static_size def in
830 begin match size with
831 | Constant | Unreachable ->
832 (* The result never escapes any recursive variables, so as we know
833 it doesn't inspect them either we can just bind the recursive
834 variables to dummy values and evaluate the definition normally.
835 *)
836 let def =
837 Lambda.subst (fun _ _ env -> env) subst_for_constants def
838 in
839 { rev_bindings with dynamic = (id, def) :: rev_bindings.dynamic }
840 | Block size ->
841 { rev_bindings with
842 static = (id, size, def) :: rev_bindings.static }
843 | Function ->
844 begin match def with
845 | Lfunction lfun ->
846 { rev_bindings with
847 functions = (id, lfun) :: rev_bindings.functions
848 }
849 | _ ->
850 let ctx_id = Ident.create_local "letrec_function_context" in
851 begin match split_static_function ctx_id Ident.Set.empty def with
852 | Unreachable ->
853 Misc.fatal_error "letrec: no function for binding"
854 | Reachable ({ lfun; free_vars_block_size }, lam) ->
855 let functions = (id, lfun) :: rev_bindings.functions in
856 let static =
857 (ctx_id, Regular_block free_vars_block_size, lam) ::
858 rev_bindings.static
859 in
860 { rev_bindings with functions; static }
861 end
862 end
863 end)
864 empty_bindings input_bindings
865 in
866 let body_with_patches =
867 List.fold_left (fun body (id, size, lam) ->
868 Lsequence (compile_update size (Lvar id) lam, body)
869 ) body (all_bindings_rev.static)
870 in
871 let body_with_functions =
872 match all_bindings_rev.functions with
873 | [] -> body_with_patches
874 | bindings_rev ->
875 let function_bindings =
876 List.rev_map (fun (id, lfun) ->
877 { id; def = lfun })
878 bindings_rev
879 in
880 Lletrec (function_bindings, body_with_patches)
881 in
882 let body_with_dynamic_values =
883 List.fold_left (fun body (id, lam) ->
884 Llet(Strict, Pgenval, id, lam, body))
885 body_with_functions all_bindings_rev.dynamic
886 in
887 let body_with_pre_allocations =
888 List.fold_left (fun body (id, size, _lam) ->
889 let alloc = compile_alloc size in
890 Llet(Strict, Pgenval, id, alloc, body))
891 body_with_dynamic_values all_bindings_rev.static
892 in
893 body_with_pre_allocations