Distinguish root and heap values in Lambda.Initialization

asmcomp/closure.ml

@@ -109,8 +109,8 @@ let prim_size prim args =
   | Pfield _ -> 1
   | Psetfield(_f, isptr, init) ->
     begin match init with
-    | Initialization -> 1  (* never causes a write barrier hit *)
-    | Assignment ->
+    | Root_initialization -> 1  (* never causes a write barrier hit *)
+    | Assignment | Heap_initialization ->
       match isptr with
       | Pointer -> 4
       | Immediate -> 1

asmcomp/cmmgen.ml

@@ -682,7 +682,12 @@ let make_alloc_generic set_fn dbg tag wordsize args =
   end
 
 let make_alloc dbg tag args =
-  make_alloc_generic addr_array_set dbg tag (List.length args) args
+  let addr_array_init arr ofs newval dbg =
+    Cop(Cextcall("caml_initialize", typ_void, false, None),
+        [array_indexing log2_size_addr arr ofs dbg; newval], dbg)
+  in
+  make_alloc_generic addr_array_init dbg tag (List.length args) args
+
 let make_float_alloc dbg tag args =
   make_alloc_generic float_array_set dbg tag
                      (List.length args * size_float / size_addr) args
@@ -2018,8 +2023,14 @@ and transl_prim_2 env p arg1 arg2 dbg =
                         [field_address (transl env arg1) n dbg;
                          transl env arg2],
                         dbg))
+      | Heap_initialization, Pointer ->
+        return_unit(Cop(Cextcall("caml_initialize", typ_void, false, None),
+                        [field_address (transl env arg1) n dbg;
+                         transl env arg2],
+                        dbg))
       | Assignment, Immediate
-      | Initialization, (Immediate | Pointer) ->
+      | Heap_initialization, Immediate
+      | Root_initialization, (Immediate | Pointer) ->
         return_unit(set_field (transl env arg1) n (transl env arg2) init dbg)
       end
   | Psetfloatfield (n, init) ->

asmcomp/flambda_to_clambda.ml

@@ -571,7 +571,7 @@ let to_clambda_initialize_symbol t env symbol fields : Clambda.ulambda =
   let build_setfield (index, field) : Clambda.ulambda =
     (* Note that this will never cause a write barrier hit, owing to
        the [Initialization]. *)
-    Uprim (Psetfield (index, Pointer, Initialization),
+    Uprim (Psetfield (index, Pointer, Root_initialization),
       [to_clambda_symbol env symbol; field],
       Debuginfo.none)
   in

asmcomp/printcmm.ml

@@ -70,7 +70,8 @@ let operation d = function
   | Cstore (c, init) ->
     let init =
       match init with
-      | Lambda.Initialization -> "(init)"
+      | Lambda.Heap_initialization -> "(heap-init)"
+      | Lambda.Root_initialization -> "(root-init)"
       | Lambda.Assignment -> ""
     in
     Printf.sprintf "store %s%s" (chunk c) init

asmcomp/selectgen.ml

@@ -304,7 +304,8 @@ method select_operation op args _dbg =
       let (addr, eloc) = self#select_addressing chunk arg1 in
       let is_assign =
         match init with
-        | Lambda.Initialization -> false
+        | Lambda.Root_initialization -> false
+        | Lambda.Heap_initialization -> false
         | Lambda.Assignment -> true
       in
       if chunk = Word_int || chunk = Word_val then begin

bytecomp/lambda.ml

@@ -39,8 +39,9 @@ type immediate_or_pointer =
   | Pointer
 
 type initialization_or_assignment =
-  | Initialization
   | Assignment
+  | Heap_initialization
+  | Root_initialization
 
 type is_safe =
   | Safe

bytecomp/lambda.mli

@@ -39,11 +39,14 @@ type immediate_or_pointer =
   | Pointer
 
 type initialization_or_assignment =
-  (* CR-someday mshinwell: For multicore, perhaps it might be necessary to
-     split [Initialization] into two cases, depending on whether the place
-     being initialized is in the heap or not. *)
-  | Initialization
   | Assignment
+  (* Initialization of in heap values, like [caml_initialize] C primitive.  The
+     field should not have been read before and initialization should happen
+     only once. *)
+  | Heap_initialization
+  (* Initialization of roots only. Compiles to a simple store.
+     No checks are done to preserve GC invariants.  *)
+  | Root_initialization
 
 type is_safe =
   | Safe

bytecomp/printlambda.ml

@@ -151,15 +151,17 @@ let primitive ppf = function
       in
       let init =
         match init with
-        | Initialization -> "(init)"
+        | Heap_initialization -> "(heap-init)"
+        | Root_initialization -> "(root-init)"
         | Assignment -> ""
       in
       fprintf ppf "setfield_%s%s %i" instr init n
   | Pfloatfield n -> fprintf ppf "floatfield %i" n
   | Psetfloatfield (n, init) ->
       let init =
         match init with
-        | Initialization -> "(init)"
+        | Heap_initialization -> "(heap-init)"
+        | Root_initialization -> "(root-init)"
         | Assignment -> ""
       in
       fprintf ppf "setfloatfield%s %i" init n

bytecomp/translmod.ml

@@ -925,7 +925,7 @@ let transl_store_structure glob map prims str =
     try
       let (pos, cc) = Ident.find_same id map in
       let init_val = apply_coercion loc Alias cc (Lvar id) in
-      Lprim(Psetfield(pos, Pointer, Initialization),
+      Lprim(Psetfield(pos, Pointer, Root_initialization),
             [Lprim(Pgetglobal glob, [], loc); init_val],
             loc)
     with Not_found ->
@@ -953,7 +953,7 @@ let transl_store_structure glob map prims str =
     List.fold_right (add_ident may_coerce) idlist subst
 
   and store_primitive (pos, prim) cont =
-    Lsequence(Lprim(Psetfield(pos, Pointer, Initialization),
+    Lsequence(Lprim(Psetfield(pos, Pointer, Root_initialization),
                     [Lprim(Pgetglobal glob, [], Location.none);
                      transl_primitive Location.none
                        prim.pc_desc prim.pc_env prim.pc_type None],
@@ -1209,7 +1209,7 @@ let transl_store_package component_names target_name coercion =
       (List.length component_names,
        make_sequence
          (fun pos id ->
-           Lprim(Psetfield(pos, Pointer, Initialization),
+           Lprim(Psetfield(pos, Pointer, Root_initialization),
                  [Lprim(Pgetglobal target_name, [], Location.none);
                   get_component id],
                  Location.none))
@@ -1226,7 +1226,7 @@ let transl_store_package component_names target_name coercion =
              apply_coercion Location.none Strict coercion components,
              make_sequence
                (fun pos _id ->
-                 Lprim(Psetfield(pos, Pointer, Initialization),
+                 Lprim(Psetfield(pos, Pointer, Root_initialization),
                        [Lprim(Pgetglobal target_name, [], Location.none);
                         Lprim(Pfield pos, [Lvar blk], Location.none)],
                        Location.none))

bytecomp/translobj.ml

@@ -140,7 +140,7 @@ let transl_store_label_init glob size f arg =
     if !method_count = 0 then (size, expr) else
     (size+1,
      Lsequence(
-     Lprim(Psetfield(size, Pointer, Initialization),
+     Lprim(Psetfield(size, Pointer, Root_initialization),
            [Lprim(Pgetglobal glob, [], Location.none);
             Lprim (Pccall prim_makearray,
                    [int !method_count; int 0],

byterun/memory.c

@@ -630,7 +630,7 @@ CAMLexport void caml_adjust_gc_speed (mlsize_t res, mlsize_t max)
 /* PR#6084 workaround: define it as a weak symbol */
 CAMLexport CAMLweakdef void caml_initialize (value *fp, value val)
 {
-  CAMLassert(Is_in_heap(fp));
+  CAMLassert(Is_in_heap_or_young(fp));
   *fp = val;
   if (Is_block (val) && Is_young (val)) {
     add_to_ref_table (&caml_ref_table, fp);

middle_end/inlining_cost.ml

@@ -27,8 +27,8 @@ let prim_size (prim : Lambda.primitive) args =
   | Pfield _ -> 1
   | Psetfield (_, isptr, init) ->
     begin match init with
-    | Initialization -> 1  (* never causes a write barrier hit *)
-    | Assignment ->
+    | Root_initialization -> 1  (* never causes a write barrier hit *)
+    | Assignment | Heap_initialization ->
       match isptr with
       | Pointer -> 4
       | Immediate -> 1