Initial support for value slots not of value kind: closure, flambda & flambda2

Author: Ekdohibs

backend/cmmgen.ml

@@ -156,8 +156,9 @@ type rhs_kind =
 let rec expr_size env = function
   | Uvar id ->
       begin try V.find_same id env with Not_found -> RHS_nonrec end
-  | Uclosure(fundecls, clos_vars) ->
-      RHS_block (fundecls_size fundecls + List.length clos_vars)
+  | Uclosure { functions ; not_scanned_slots ; scanned_slots } ->
+      RHS_block (fundecls_size functions + List.length not_scanned_slots
+        + List.length scanned_slots)
   | Ulet(_str, _kind, id, exp, body) ->
       expr_size (V.add (VP.var id) (expr_size env exp) env) body
   | Uletrec(bindings, body) ->
@@ -426,18 +427,18 @@ let rec transl env e =
       end
   | Uconst sc ->
       transl_constant Debuginfo.none sc
-  | Uclosure(fundecls, []) ->
+  | Uclosure { functions ; not_scanned_slots = [] ; scanned_slots = [] } ->
       let sym = Compilenv.new_const_symbol() in
-      Cmmgen_state.add_constant sym (Const_closure (Local, fundecls, []));
-      List.iter (fun f -> Cmmgen_state.add_function f) fundecls;
+      Cmmgen_state.add_constant sym (Const_closure (Local, functions, []));
+      List.iter (fun f -> Cmmgen_state.add_function f) functions;
       let dbg =
-        match fundecls with
+        match functions with
         | [] -> Debuginfo.none
         | fundecl::_ -> fundecl.dbg
       in
       Cconst_symbol (sym, dbg)
-  | Uclosure(fundecls, clos_vars) ->
-      let startenv = fundecls_size fundecls in
+  | Uclosure { functions ; not_scanned_slots ; scanned_slots } ->
+      let startenv = fundecls_size functions + List.length not_scanned_slots in
       let mode =
         Option.get @@
         List.fold_left (fun s { mode; dbg; _ } ->
@@ -447,10 +448,10 @@ let rec transl env e =
              if not (Lambda.eq_mode mode m') then
                Misc.fatal_errorf "Inconsistent modes in let rec at %s"
                  (Debuginfo.to_string dbg);
-             s) None fundecls in
+             s) None functions in
       let rec transl_fundecls pos = function
           [] ->
-            List.map (transl env) clos_vars
+            List.map (transl env) (not_scanned_slots @ scanned_slots)
         | f :: rem ->
             let is_last = match rem with [] -> true | _::_ -> false in
             Cmmgen_state.add_function f;
@@ -474,11 +475,11 @@ let rec transl env e =
             else alloc_infix_header pos f.dbg :: without_header
       in
       let dbg =
-        match fundecls with
+        match functions with
         | [] -> Debuginfo.none
         | fundecl::_ -> fundecl.dbg
       in
-      make_alloc ~mode dbg Obj.closure_tag (transl_fundecls 0 fundecls)
+      make_alloc ~mode dbg Obj.closure_tag (transl_fundecls 0 functions)
   | Uoffset(arg, offset) ->
       (* produces a valid Caml value, pointing just after an infix header *)
       let ptr = transl env arg in

middle_end/clambda.ml

@@ -52,7 +52,11 @@ and ulambda =
       function_label * ulambda list * Lambda.probe * apply_kind * Debuginfo.t
   | Ugeneric_apply of
       ulambda * ulambda list * apply_kind * Debuginfo.t
-  | Uclosure of ufunction list * ulambda list
+  | Uclosure of {
+      functions : ufunction list ;
+      not_scanned_slots : ulambda list ;
+      scanned_slots : ulambda list ;
+    }
   | Uoffset of ulambda * int
   | Ulet of mutable_flag * value_kind * Backend_var.With_provenance.t
       * ulambda * ulambda

middle_end/clambda.mli

@@ -63,7 +63,11 @@ and ulambda =
       function_label * ulambda list * Lambda.probe * apply_kind * Debuginfo.t
   | Ugeneric_apply of
       ulambda * ulambda list * apply_kind * Debuginfo.t
-  | Uclosure of ufunction list * ulambda list
+  | Uclosure of {
+      functions : ufunction list ;
+      not_scanned_slots : ulambda list ;
+      scanned_slots : ulambda list
+    }
   | Uoffset of ulambda * int
   | Ulet of mutable_flag * value_kind * Backend_var.With_provenance.t
       * ulambda * ulambda