Fix caml_modify on local allocations (#40)

asmcomp/cmm_helpers.ml

@@ -744,12 +744,10 @@ let unboxed_float_array_ref arr ofs dbg =
 let float_array_ref arr ofs dbg =
   box_float dbg (unboxed_float_array_ref arr ofs dbg)
 
+(* FIXME local arrays *)
 let addr_array_set arr ofs newval dbg =
   Cop(Cextcall("caml_modify", typ_void, [], false),
       [array_indexing log2_size_addr arr ofs dbg; newval], dbg)
-let addr_array_initialize arr ofs newval dbg =
-  Cop(Cextcall("caml_initialize", typ_void, [], false),
-      [array_indexing log2_size_addr arr ofs dbg; newval], dbg)
 let int_array_set arr ofs newval dbg =
   Cop(Cstore (Word_int, Lambda.Assignment),
     [array_indexing log2_size_addr arr ofs dbg; newval], dbg)
@@ -2215,16 +2213,17 @@ type binary_primitive = expression -> expression -> Debuginfo.t -> expression
 
 (* Helper for compilation of initialization and assignment operations *)
 
-type assignment_kind = Caml_modify | Caml_initialize | Simple
+type assignment_kind = Caml_modify | Caml_modify_local | Simple
 
 let assignment_kind
     (ptr: Lambda.immediate_or_pointer)
     (init: Lambda.initialization_or_assignment) =
   match init, ptr with
   | Assignment, Pointer -> Caml_modify
-  | Heap_initialization, Pointer -> Caml_initialize
-  | Assignment, Immediate
-  | Heap_initialization, Immediate
+  | Local_assignment, Pointer -> Caml_modify_local
+  | Heap_initialization, _ ->
+     Misc.fatal_error "Cmm_helpers: Lambda.Heap_initialization unsupported"
+  | (Assignment | Local_assignment), Immediate
   | Root_initialization, (Immediate | Pointer) -> Simple
 
 let setfield n ptr init arg1 arg2 dbg =
@@ -2234,10 +2233,10 @@ let setfield n ptr init arg1 arg2 dbg =
         (Cop(Cextcall("caml_modify", typ_void, [], false),
              [field_address arg1 n dbg; arg2],
              dbg))
-  | Caml_initialize ->
+  | Caml_modify_local ->
       return_unit dbg
-        (Cop(Cextcall("caml_initialize", typ_void, [], false),
-             [field_address arg1 n dbg; arg2],
+        (Cop(Cextcall("caml_modify_local", typ_void, [], false),
+             [arg1; Cconst_int (n,dbg); arg2],
              dbg))
   | Simple ->
       return_unit dbg (set_field arg1 n arg2 init dbg)
@@ -2422,10 +2421,11 @@ type ternary_primitive =
 
 let setfield_computed ptr init arg1 arg2 arg3 dbg =
   match assignment_kind ptr init with
+  (* FIXME local *)
   | Caml_modify ->
       return_unit dbg (addr_array_set arg1 arg2 arg3 dbg)
-  | Caml_initialize ->
-      return_unit dbg (addr_array_initialize arg1 arg2 arg3 dbg)
+  | Caml_modify_local ->
+      return_unit dbg (addr_array_set arg1 arg2 arg3 dbg)
   | Simple ->
       return_unit dbg (int_array_set arg1 arg2 arg3 dbg)
 

asmcomp/cmm_helpers.mli

@@ -261,8 +261,6 @@ val unboxed_float_array_ref :
 val float_array_ref : expression -> expression -> Debuginfo.t -> expression
 val addr_array_set :
   expression -> expression -> expression -> Debuginfo.t -> expression
-val addr_array_initialize :
-  expression -> expression -> expression -> Debuginfo.t -> expression
 val int_array_set :
   expression -> expression -> expression -> Debuginfo.t -> expression
 val float_array_set :
@@ -451,8 +449,6 @@ val bswap16 : unary_primitive
 
 type binary_primitive = expression -> expression -> Debuginfo.t -> expression
 
-type assignment_kind = Caml_modify | Caml_initialize | Simple
-
 (** [setfield offset value_is_ptr init ptr value dbg] *)
 val setfield :
   int -> Lambda.immediate_or_pointer -> Lambda.initialization_or_assignment ->

asmcomp/printcmm.ml

@@ -128,6 +128,7 @@ let operation d = function
       | Lambda.Heap_initialization -> "(heap-init)"
       | Lambda.Root_initialization -> "(root-init)"
       | Lambda.Assignment -> ""
+      | Local_assignment -> "(local)"
     in
     Printf.sprintf "store %s%s" (chunk c) init
   | Caddi -> "+"

asmcomp/selectgen.ml

@@ -472,7 +472,7 @@ method select_operation op args _dbg =
         match init with
         | Lambda.Root_initialization -> false
         | Lambda.Heap_initialization -> false
-        | Lambda.Assignment -> true
+        | Lambda.Assignment | Lambda.Local_assignment -> true
       in
       if chunk = Word_int || chunk = Word_val then begin
         let (op, newarg2) = self#select_store is_assign addr arg2 in

lambda/lambda.ml

@@ -32,6 +32,7 @@ type immediate_or_pointer =
 
 type initialization_or_assignment =
   | Assignment
+  | Local_assignment
   | Heap_initialization
   | Root_initialization
 

lambda/lambda.mli

@@ -33,6 +33,7 @@ type immediate_or_pointer =
 
 type initialization_or_assignment =
   | Assignment
+  | Local_assignment (* mutations of blocks that may be locally allocated *)
   (* Initialization of in heap values, like [caml_initialize] C primitive.  The
      field should not have been read before and initialization should happen
      only once. *)

lambda/printlambda.ml

@@ -181,6 +181,7 @@ let primitive ppf = function
         | Heap_initialization -> "(heap-init)"
         | Root_initialization -> "(root-init)"
         | Assignment -> ""
+        | Local_assignment -> "(local)"
       in
       fprintf ppf "setfield_%s%s %i" instr init n
   | Psetfield_computed (ptr, init) ->
@@ -194,6 +195,7 @@ let primitive ppf = function
         | Heap_initialization -> "(heap-init)"
         | Root_initialization -> "(root-init)"
         | Assignment -> ""
+        | Local_assignment -> "(local)"
       in
       fprintf ppf "setfield_%s%s_computed" instr init
   | Pfloatfield n -> fprintf ppf "floatfield %i" n
@@ -203,6 +205,7 @@ let primitive ppf = function
         | Heap_initialization -> "(heap-init)"
         | Root_initialization -> "(root-init)"
         | Assignment -> ""
+        | Local_assignment -> "(local)"
       in
       fprintf ppf "setfloatfield%s %i" init n
   | Pduprecord (rep, size) -> fprintf ppf "duprecord %a %i" record_rep rep size

lambda/translcore.ml

@@ -409,15 +409,21 @@ and transl_exp0 ~in_new_scope ~scopes e =
                  of_location ~scopes e.exp_loc)
       end
   | Texp_setfield(arg, _, lbl, newval) ->
+      let mode =
+        let arg_mode = Types.Value_mode.regional_to_local_alloc arg.exp_mode in
+        match Types.Alloc_mode.constrain_lower arg_mode with
+        | Global -> Assignment
+        | Local -> Local_assignment
+      in
       let access =
         match lbl.lbl_repres with
           Record_regular
         | Record_inlined _ ->
-          Psetfield(lbl.lbl_pos, maybe_pointer newval, Assignment)
+          Psetfield(lbl.lbl_pos, maybe_pointer newval, mode)
         | Record_unboxed _ -> assert false
-        | Record_float -> Psetfloatfield (lbl.lbl_pos, Assignment)
+        | Record_float -> Psetfloatfield (lbl.lbl_pos, mode)
         | Record_extension _ ->
-          Psetfield (lbl.lbl_pos + 1, maybe_pointer newval, Assignment)
+          Psetfield (lbl.lbl_pos + 1, maybe_pointer newval, mode)
       in
       Lprim(access, [transl_exp ~scopes arg; transl_exp ~scopes newval],
             of_location ~scopes e.exp_loc)

lambda/translprim.ml

@@ -125,7 +125,7 @@ let primitives_table =
     "%loc_FUNCTION", Loc Loc_FUNCTION;
     "%field0", Primitive ((Pfield 0), 1);
     "%field1", Primitive ((Pfield 1), 1);
-    "%setfield0", Primitive ((Psetfield(0, Pointer, Assignment)), 2);
+    "%setfield0", Primitive ((Psetfield(0, Pointer, Local_assignment (* FIXME *))), 2);
     "%makeblock", Primitive ((Pmakeblock(0, Immutable, None, Alloc_heap)), 1);
     "%makemutable", Primitive ((Pmakeblock(0, Mutable, None, Alloc_heap)), 1);
     "%makelocalmutable",

middle_end/closure/closure.ml

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

middle_end/flambda/inlining_cost.ml

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

middle_end/printclambda_primitives.ml

@@ -78,6 +78,7 @@ let primitive ppf (prim:Clambda_primitives.primitive) =
         | Heap_initialization -> "(heap-init)"
         | Root_initialization -> "(root-init)"
         | Assignment -> ""
+        | Local_assignment -> "(local)"
       in
       fprintf ppf "setfield_%s%s %i" instr init n
   | Psetfield_computed (ptr, init) ->
@@ -91,6 +92,7 @@ let primitive ppf (prim:Clambda_primitives.primitive) =
         | Heap_initialization -> "(heap-init)"
         | Root_initialization -> "(root-init)"
         | Assignment -> ""
+        | Local_assignment -> "(local)"
       in
       fprintf ppf "setfield_%s%s_computed" instr init
   | Pfloatfield n -> fprintf ppf "floatfield %i" n
@@ -100,6 +102,7 @@ let primitive ppf (prim:Clambda_primitives.primitive) =
         | Heap_initialization -> "(heap-init)"
         | Root_initialization -> "(root-init)"
         | Assignment -> ""
+        | Local_assignment -> "(local)"
       in
       fprintf ppf "setfloatfield%s %i" init n
   | Pduprecord (rep, size) ->

runtime/memory.c

@@ -677,6 +677,19 @@ CAMLexport CAMLweakdef void caml_modify (value *fp, value val)
   }
 }
 
+/* This version of [caml_modify] may additionally be used to mutate
+   locally-allocated objects. (This version is used by mutations
+   generated from OCaml code when the value being modified may be
+   locally allocated) */
+CAMLexport void caml_modify_local (value obj, intnat i, value val)
+{
+  if (Color_hd(Hd_val(obj)) == Local_unmarked) {
+    Field(obj, i) = val;
+  } else {
+    caml_modify(&Field(obj, i), val);
+  }
+}
+
 CAMLexport intnat caml_local_region_begin()
 {
   return Caml_state->local_sp;

runtime/minor_gc.c

@@ -375,6 +375,18 @@ static void verify_minor_heap()
       }
     }
   }
+  if (arena) {
+    value** r;
+    for (r = Caml_state->ref_table->base;
+         r < Caml_state->ref_table->ptr; r++) {
+      CAMLassert(!(arena->base <= (char*)*r &&
+                   (char*)*r < arena->base + arena->length));
+      if (Is_block(**r)) {
+        CAMLassert(!(arena->base <= (char*)**r &&
+                     (char*)**r < arena->base + arena->length));
+      }
+    }
+  }
 }
 #endif
 

testsuite/tests/translprim/ref_spec.compilers.reference

@@ -6,10 +6,11 @@
      cst_ref = (makemutable 0 0)
      gen_ref = (makemutable 0 0)
      flt_ref = (makemutable 0 (float) 0.))
-    (seq (setfield_imm 0 int_ref 2) (setfield_imm 0 var_ref 66)
-      (setfield_ptr 0 vargen_ref [0: 66 0]) (setfield_ptr 0 vargen_ref 67)
-      (setfield_imm 0 cst_ref 1) (setfield_ptr 0 gen_ref [0: "foo"])
-      (setfield_ptr 0 gen_ref 0) (setfield_ptr 0 flt_ref 1.)
+    (seq (setfield_imm(local) 0 int_ref 2) (setfield_imm(local) 0 var_ref 66)
+      (setfield_ptr(local) 0 vargen_ref [0: 66 0])
+      (setfield_ptr(local) 0 vargen_ref 67) (setfield_imm(local) 0 cst_ref 1)
+      (setfield_ptr(local) 0 gen_ref [0: "foo"])
+      (setfield_ptr(local) 0 gen_ref 0) (setfield_ptr(local) 0 flt_ref 1.)
       (let
         (int_rec = (makemutable 0 (*,int) 0 1)
          var_rec = (makemutable 0 0 65)
@@ -24,14 +25,21 @@
           (setfield_ptr 1 gen_rec [0: "foo"]) (setfield_ptr 1 gen_rec 0)
           (setfield_ptr 1 flt_rec 1.) (setfloatfield 1 flt_rec' 1.)
           (let
-            (set_open_poly = (function r[->L] y[->L] (setfield_ptr 0 r y))
-             set_open_poly = (function r[->L] y[->L] (setfield_imm 0 r y))
-             set_open_poly = (function r[->L] y[->L] (setfield_imm 0 r y))
-             set_open_poly = (function r[->L] y[->L] (setfield_imm 0 r y))
-             set_open_poly = (function r[->L] y[->L] (setfield_ptr 0 r y))
-             set_open_poly = (function r[->L] y[->L] (setfield_ptr 0 r y))
-             set_open_poly = (function r[->L] y[->L] (setfield_ptr 0 r y))
-             set_open_poly = (function r y (setfield_ptr 0 r y)))
+            (set_open_poly =
+               (function r[->L] y[->L] (setfield_ptr(local) 0 r y))
+             set_open_poly =
+               (function r[->L] y[->L] (setfield_imm(local) 0 r y))
+             set_open_poly =
+               (function r[->L] y[->L] (setfield_imm(local) 0 r y))
+             set_open_poly =
+               (function r[->L] y[->L] (setfield_imm(local) 0 r y))
+             set_open_poly =
+               (function r[->L] y[->L] (setfield_ptr(local) 0 r y))
+             set_open_poly =
+               (function r[->L] y[->L] (setfield_ptr(local) 0 r y))
+             set_open_poly =
+               (function r[->L] y[->L] (setfield_ptr(local) 0 r y))
+             set_open_poly = (function r y (setfield_ptr(local) 0 r y)))
             (makeblock 0 int_ref var_ref vargen_ref cst_ref gen_ref flt_ref
               int_rec var_rec vargen_rec cst_rec gen_rec flt_rec flt_rec'
               set_open_poly)))))))

testsuite/tests/typing-local/mutate.ml

@@ -0,0 +1,10 @@
+(* TEST *)
+let[@inline never] f (g : local_ _ -> unit) n =
+  let r = local_ { contents = ref 0 } in
+  g r;
+  r.contents <- ref n;
+  Gc.minor ();
+  r.contents.contents
+
+let _ =
+  Printf.printf "%d\n" (f (fun _ -> ()) 42)

testsuite/tests/typing-local/mutate.reference

@@ -0,0 +1 @@
+42