let rec

.depend

@@ -3200,27 +3200,6 @@ lambda/debuginfo.cmi : \
     parsing/location.cmi \
     typing/ident.cmi \
     parsing/asttypes.cmi
-lambda/dissect_letrec.cmo : \
-    typing/types.cmi \
-    lambda/printlambda.cmi \
-    typing/primitive.cmi \
-    utils/misc.cmi \
-    lambda/lambda.cmi \
-    typing/ident.cmi \
-    parsing/asttypes.cmi \
-    lambda/dissect_letrec.cmi
-lambda/dissect_letrec.cmx : \
-    typing/types.cmx \
-    lambda/printlambda.cmx \
-    typing/primitive.cmx \
-    utils/misc.cmx \
-    lambda/lambda.cmx \
-    typing/ident.cmx \
-    parsing/asttypes.cmi \
-    lambda/dissect_letrec.cmi
-lambda/dissect_letrec.cmi : \
-    lambda/lambda.cmi \
-    typing/ident.cmi
 lambda/lambda.cmo : \
     typing/types.cmi \
     typing/primitive.cmi \
@@ -3343,7 +3322,6 @@ lambda/simplif.cmo : \
     parsing/location.cmi \
     lambda/lambda.cmi \
     typing/ident.cmi \
-    lambda/dissect_letrec.cmi \
     lambda/debuginfo.cmi \
     utils/clflags.cmi \
     parsing/asttypes.cmi \
@@ -3354,7 +3332,6 @@ lambda/simplif.cmx : \
     parsing/location.cmx \
     lambda/lambda.cmx \
     typing/ident.cmx \
-    lambda/dissect_letrec.cmx \
     lambda/debuginfo.cmx \
     utils/clflags.cmx \
     parsing/asttypes.cmi \
@@ -3528,9 +3505,9 @@ lambda/translmod.cmo : \
     lambda/lambda.cmi \
     typing/ident.cmi \
     typing/env.cmi \
-    lambda/dissect_letrec.cmi \
     lambda/debuginfo.cmi \
     typing/ctype.cmi \
+    utils/config.cmi \
     utils/clflags.cmi \
     parsing/asttypes.cmi \
     lambda/translmod.cmi
@@ -3551,9 +3528,9 @@ lambda/translmod.cmx : \
     lambda/lambda.cmx \
     typing/ident.cmx \
     typing/env.cmx \
-    lambda/dissect_letrec.cmx \
     lambda/debuginfo.cmx \
     typing/ctype.cmx \
+    utils/config.cmx \
     utils/clflags.cmx \
     parsing/asttypes.cmi \
     lambda/translmod.cmi
@@ -5003,6 +4980,27 @@ middle_end/flambda/from_lambda/closure_conversion_aux.cmi : \
     middle_end/flambda/basic/code_id.cmi \
     middle_end/flambda/basic/closure_id.cmi \
     middle_end/flambda/naming/bindable_let_bound.cmi
+middle_end/flambda/from_lambda/dissect_letrec.cmo : \
+    typing/types.cmi \
+    lambda/printlambda.cmi \
+    typing/primitive.cmi \
+    utils/misc.cmi \
+    lambda/lambda.cmi \
+    typing/ident.cmi \
+    parsing/asttypes.cmi \
+    middle_end/flambda/from_lambda/dissect_letrec.cmi
+middle_end/flambda/from_lambda/dissect_letrec.cmx : \
+    typing/types.cmx \
+    lambda/printlambda.cmx \
+    typing/primitive.cmx \
+    utils/misc.cmx \
+    lambda/lambda.cmx \
+    typing/ident.cmx \
+    parsing/asttypes.cmi \
+    middle_end/flambda/from_lambda/dissect_letrec.cmi
+middle_end/flambda/from_lambda/dissect_letrec.cmi : \
+    lambda/lambda.cmi \
+    typing/ident.cmi
 middle_end/flambda/from_lambda/lambda_conversions.cmo : \
     middle_end/flambda/basic/trap_action.cmi \
     utils/targetint.cmi \
@@ -5058,12 +5056,12 @@ middle_end/flambda/from_lambda/lambda_to_flambda.cmo : \
     lambda/lambda.cmi \
     typing/ident.cmi \
     middle_end/flambda/terms/flambda_unit.cmi \
+    middle_end/flambda/from_lambda/dissect_letrec.cmi \
     middle_end/flambda/basic/continuation.cmi \
     middle_end/flambda/compilenv_deps/compilation_unit.cmi \
     middle_end/flambda/basic/closure_id.cmi \
     middle_end/flambda/from_lambda/closure_conversion_aux.cmi \
     middle_end/flambda/from_lambda/closure_conversion.cmi \
-    utils/clflags.cmi \
     parsing/asttypes.cmi \
     middle_end/flambda/from_lambda/lambda_to_flambda.cmi
 middle_end/flambda/from_lambda/lambda_to_flambda.cmx : \
@@ -5082,12 +5080,12 @@ middle_end/flambda/from_lambda/lambda_to_flambda.cmx : \
     lambda/lambda.cmx \
     typing/ident.cmx \
     middle_end/flambda/terms/flambda_unit.cmx \
+    middle_end/flambda/from_lambda/dissect_letrec.cmx \
     middle_end/flambda/basic/continuation.cmx \
     middle_end/flambda/compilenv_deps/compilation_unit.cmx \
     middle_end/flambda/basic/closure_id.cmx \
     middle_end/flambda/from_lambda/closure_conversion_aux.cmx \
     middle_end/flambda/from_lambda/closure_conversion.cmx \
-    utils/clflags.cmx \
     parsing/asttypes.cmi \
     middle_end/flambda/from_lambda/lambda_to_flambda.cmi
 middle_end/flambda/from_lambda/lambda_to_flambda.cmi : \

compilerlibs/Makefile.compilerlibs

@@ -76,7 +76,6 @@ LAMBDA=lambda/tag.cmo lambda/debuginfo.cmo \
   lambda/switch.cmo lambda/matching.cmo \
   lambda/translobj.cmo lambda/translattribute.cmo \
   lambda/translprim.cmo lambda/translcore.cmo \
-  lambda/dissect_letrec.cmo \
   lambda/translclass.cmo lambda/translmod.cmo \
   lambda/simplif.cmo lambda/runtimedef.cmo
 LAMBDA_CMI=
@@ -368,6 +367,7 @@ MIDDLE_END_FLAMBDA_FROM_LAMBDA=\
   middle_end/flambda/from_lambda/lambda_to_flambda_primitives_helpers.cmo \
   middle_end/flambda/from_lambda/lambda_to_flambda_primitives.cmo \
   middle_end/flambda/from_lambda/closure_conversion.cmo \
+  middle_end/flambda/from_lambda/dissect_letrec.cmo \
   middle_end/flambda/from_lambda/lambda_to_flambda.cmo
 
 

dune

@@ -80,7 +80,6 @@
    ;; lambda/
    debuginfo lambda matching printlambda runtimedef simplif switch
    translattribute translclass translcore translmod translobj translprim tag
-   dissect_letrec
 
    ;; bytecomp/
    meta opcodes bytesections dll symtable

lambda/simplif.ml

@@ -563,14 +563,8 @@ let simplify_lets lam =
       | _ -> mklet StrictOpt kind v (simplif l1) (simplif l2)
       end
   | Llet(str, kind, v, l1, l2) -> mklet str kind v (simplif l1) (simplif l2)
-  | Lletrec(bindings, body) -> begin
-      match Dissect_letrec.dissect_letrec ~bindings ~body with
-      | Dissect_letrec.Unchanged ->
-          Lletrec(List.map (fun (v, l) -> (v, simplif l)) bindings,
-                  simplif body)
-      | Dissect_letrec.Dissected expr ->
-          simplif expr
-    end
+  | Lletrec(bindings, body) ->
+      Lletrec(List.map (fun (v, l) -> (v, simplif l)) bindings, simplif body)
   | Lprim(p, ll, loc) -> Lprim(p, List.map simplif ll, loc)
   | Lswitch(l, sw, loc) ->
       let new_l = simplif l

lambda/translmod.ml

@@ -228,6 +228,33 @@ let record_primitive = function
       primitive_declarations := p :: !primitive_declarations
   | _ -> ()
 
+(* Helper for compiling value "let rec".  This is only used for Flambda 2
+   at present, which uses the new [Dissect_letrec] module, planned to be
+   upstreamed.  At that point this helper can move into that module. *)
+
+let preallocate_letrec ~bindings ~body =
+  let caml_update_dummy_prim =
+    Primitive.simple ~name:"caml_update_dummy" ~arity:2 ~alloc:true
+  in
+  let update_dummy var expr =
+    Lprim (Pccall caml_update_dummy_prim, [Lvar var; expr], Loc_unknown)
+  in
+  let bindings = List.rev bindings in
+  let body_with_initialization =
+  List.fold_left
+    (fun body (id, def, _size) -> Lsequence (update_dummy id def, body))
+    body bindings
+  in
+  List.fold_left
+    (fun body (id, _def, size) ->
+       let desc =
+         Primitive.simple ~name:"caml_alloc_dummy" ~arity:1 ~alloc:true
+       in
+       let size : lambda = Lconst (Const_base (Const_int size)) in
+       Llet (Strict, Pgenval, id,
+             Lprim (Pccall desc, [size], Loc_unknown), body))
+    body_with_initialization bindings
+
 (* Utilities for compiling "module rec" definitions *)
 
 let mod_prim = Lambda.transl_prim "CamlinternalMod"
@@ -722,9 +749,13 @@ and transl_structure ~scopes loc fields cc rootpath final_env = function
             transl_structure ~scopes loc (List.rev_append ids fields)
               cc rootpath final_env rem
           in
-          Dissect_letrec.preallocate_letrec
-            ~bindings:class_bindings ~body,
-          size
+          if Config.flambda then
+            preallocate_letrec ~bindings:class_bindings ~body, size
+          else
+            let class_bindings =
+              List.map (fun (id, lam, _) -> id, lam) class_bindings
+            in
+            Lletrec(class_bindings, body), size
       | Tstr_include incl ->
           let ids = bound_value_identifiers incl.incl_type in
           let modl = incl.incl_mod in
@@ -1168,10 +1199,17 @@ let transl_store_structure ~scopes glob map prims aliases str =
                            (add_idents true ids subst) cont rem))
         | Tstr_class cl_list ->
             let (ids, class_bindings) = transl_class_bindings ~scopes cl_list in
+            let body = store_idents Loc_unknown ids in
             let lam =
-              Dissect_letrec.preallocate_letrec
-                ~bindings:class_bindings
-                ~body:(store_idents Loc_unknown ids)
+              if Config.flambda then
+                preallocate_letrec
+                  ~bindings:class_bindings
+                  ~body
+              else
+                let class_bindings =
+                  List.map (fun (id, lam, _) -> id, lam) class_bindings
+                in
+                Lletrec(class_bindings, body)
             in
             Lsequence(Lambda.subst no_env_update subst lam,
                       transl_store ~scopes rootpath (add_idents false ids subst)
@@ -1530,9 +1568,14 @@ let transl_toplevel_item ~scopes item =
          be a value named identically *)
       let (ids, class_bindings) = transl_class_bindings ~scopes cl_list in
       List.iter set_toplevel_unique_name ids;
-      Dissect_letrec.preallocate_letrec
-        ~bindings:class_bindings
-        ~body:(make_sequence toploop_setvalue_id ids)
+      let body = make_sequence toploop_setvalue_id ids in
+      if Config.flambda then
+        preallocate_letrec ~bindings:class_bindings ~body
+      else
+        let class_bindings =
+          List.map (fun (id, lam, _) -> id, lam) class_bindings
+        in
+        Lletrec(class_bindings, body)
   | Tstr_include incl ->
       let ids = bound_value_identifiers incl.incl_type in
       let modl = incl.incl_mod in

lambda/dissect_letrec.ml → middle_end/flambda/from_lambda/dissect_letrec.ml

@@ -573,20 +573,3 @@ let dissect_letrec ~bindings ~body =
     with Bug ->
       Misc.fatal_errorf "let-rec@.%a@."
         Printlambda.lambda (Lletrec (bindings, body))
-
-let preallocate_letrec ~bindings ~body =
-  let bindings = List.rev bindings in
-  let body_with_initialization =
-  List.fold_left
-    (fun body (id, def, _size) -> Lsequence (update_dummy id def, body))
-    body bindings
-  in
-  List.fold_left
-    (fun body (id, _def, size) ->
-       let desc =
-         Primitive.simple ~name:"caml_alloc_dummy" ~arity:1 ~alloc:true
-       in
-       let size : lambda = Lconst (Const_base (Const_int size)) in
-       Llet (Strict, Pgenval, id,
-             Lprim (Pccall desc, [size], Loc_unknown), body))
-    body_with_initialization bindings

lambda/dissect_letrec.mli → middle_end/flambda/from_lambda/dissect_letrec.mli

@@ -26,7 +26,3 @@ val dissect_letrec :
   dissected
 (** [dissect_letrec] assumes that bindings have not been dissected yet.
     In particular, that no arguments of function call are recursive. *)
-
-val preallocate_letrec :
-  bindings:(Ident.t * Lambda.lambda * int) list -> body:Lambda.lambda ->
-  Lambda.lambda

middle_end/flambda/from_lambda/lambda_to_flambda.ml

@@ -717,14 +717,18 @@ let rec cps_non_tail acc env ccenv (lam : L.lambda)
       ~handler:(fun acc env ccenv ->
         cps_non_tail acc env ccenv body k k_exn)
   | Lletrec (bindings, body) ->
-    let function_declarations =
-      cps_function_bindings env bindings
-    in
-    let body = fun acc ccenv ->
-      cps_non_tail acc env ccenv body k k_exn
-    in
-    CC.close_let_rec acc ccenv
-      ~function_declarations ~body
+    begin match Dissect_letrec.dissect_letrec ~bindings ~body with
+    | Unchanged ->
+      let function_declarations =
+        cps_function_bindings env bindings
+      in
+      let body = fun acc ccenv ->
+        cps_non_tail acc env ccenv body k k_exn
+      in
+      CC.close_let_rec acc ccenv
+        ~function_declarations ~body
+    | Dissected lam -> cps_non_tail acc env ccenv lam k k_exn
+    end
   | Lprim (prim, args, loc) ->
     begin match transform_primitive env prim args loc with
     | Primitive (prim, args, loc) ->
@@ -1073,14 +1077,18 @@ and cps_tail acc env ccenv (lam : L.lambda) (k : Continuation.t)
       ~handler:(fun acc env ccenv ->
         cps_tail acc env ccenv body k k_exn)
   | Lletrec (bindings, body) ->
-    let function_declarations =
-      cps_function_bindings env bindings
-    in
-    let body = fun acc ccenv ->
-      cps_tail acc env ccenv body k k_exn
-    in
-    CC.close_let_rec acc ccenv
-      ~function_declarations ~body
+    begin match Dissect_letrec.dissect_letrec ~bindings ~body with
+    | Unchanged ->
+      let function_declarations =
+        cps_function_bindings env bindings
+      in
+      let body = fun acc ccenv ->
+        cps_tail acc env ccenv body k k_exn
+      in
+      CC.close_let_rec acc ccenv
+        ~function_declarations ~body
+    | Dissected lam -> cps_tail acc env ccenv lam k k_exn
+    end
   | Lprim (prim, args, loc) ->
     begin match transform_primitive env prim args loc with
     | Primitive (prim, args, loc) ->