Skip to content

Commit 0527570

Browse files
stedolanstedolan
committed
Fix caml_modify on local allocations (#40)
1 parent e657e99 commit 0527570

File tree

17 files changed

+90
-35
lines changed

17 files changed

+90
-35
lines changed

‎asmcomp/cmm_helpers.ml

Lines changed: 12 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -744,12 +744,10 @@ let unboxed_float_array_ref arr ofs dbg =
744744
let float_array_ref arr ofs dbg =
745745
box_float dbg (unboxed_float_array_ref arr ofs dbg)
746746

747+
(* FIXME local arrays *)
747748
let addr_array_set arr ofs newval dbg =
748749
Cop(Cextcall("caml_modify", typ_void, [], false),
749750
[array_indexing log2_size_addr arr ofs dbg; newval], dbg)
750-
let addr_array_initialize arr ofs newval dbg =
751-
Cop(Cextcall("caml_initialize", typ_void, [], false),
752-
[array_indexing log2_size_addr arr ofs dbg; newval], dbg)
753751
let int_array_set arr ofs newval dbg =
754752
Cop(Cstore (Word_int, Lambda.Assignment),
755753
[array_indexing log2_size_addr arr ofs dbg; newval], dbg)
@@ -2215,16 +2213,17 @@ type binary_primitive = expression -> expression -> Debuginfo.t -> expression
22152213

22162214
(* Helper for compilation of initialization and assignment operations *)
22172215

2218-
type assignment_kind = Caml_modify | Caml_initialize | Simple
2216+
type assignment_kind = Caml_modify | Caml_modify_local | Simple
22192217

22202218
let assignment_kind
22212219
(ptr: Lambda.immediate_or_pointer)
22222220
(init: Lambda.initialization_or_assignment) =
22232221
match init, ptr with
22242222
| Assignment, Pointer -> Caml_modify
2225-
| Heap_initialization, Pointer -> Caml_initialize
2226-
| Assignment, Immediate
2227-
| Heap_initialization, Immediate
2223+
| Local_assignment, Pointer -> Caml_modify_local
2224+
| Heap_initialization, _ ->
2225+
Misc.fatal_error "Cmm_helpers: Lambda.Heap_initialization unsupported"
2226+
| (Assignment | Local_assignment), Immediate
22282227
| Root_initialization, (Immediate | Pointer) -> Simple
22292228

22302229
let setfield n ptr init arg1 arg2 dbg =
@@ -2234,10 +2233,10 @@ let setfield n ptr init arg1 arg2 dbg =
22342233
(Cop(Cextcall("caml_modify", typ_void, [], false),
22352234
[field_address arg1 n dbg; arg2],
22362235
dbg))
2237-
| Caml_initialize ->
2236+
| Caml_modify_local ->
22382237
return_unit dbg
2239-
(Cop(Cextcall("caml_initialize", typ_void, [], false),
2240-
[field_address arg1 n dbg; arg2],
2238+
(Cop(Cextcall("caml_modify_local", typ_void, [], false),
2239+
[arg1; Cconst_int (n,dbg); arg2],
22412240
dbg))
22422241
| Simple ->
22432242
return_unit dbg (set_field arg1 n arg2 init dbg)
@@ -2422,10 +2421,11 @@ type ternary_primitive =
24222421

24232422
let setfield_computed ptr init arg1 arg2 arg3 dbg =
24242423
match assignment_kind ptr init with
2424+
(* FIXME local *)
24252425
| Caml_modify ->
24262426
return_unit dbg (addr_array_set arg1 arg2 arg3 dbg)
2427-
| Caml_initialize ->
2428-
return_unit dbg (addr_array_initialize arg1 arg2 arg3 dbg)
2427+
| Caml_modify_local ->
2428+
return_unit dbg (addr_array_set arg1 arg2 arg3 dbg)
24292429
| Simple ->
24302430
return_unit dbg (int_array_set arg1 arg2 arg3 dbg)
24312431

‎asmcomp/cmm_helpers.mli

Lines changed: 0 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -261,8 +261,6 @@ val unboxed_float_array_ref :
261261
val float_array_ref : expression -> expression -> Debuginfo.t -> expression
262262
val addr_array_set :
263263
expression -> expression -> expression -> Debuginfo.t -> expression
264-
val addr_array_initialize :
265-
expression -> expression -> expression -> Debuginfo.t -> expression
266264
val int_array_set :
267265
expression -> expression -> expression -> Debuginfo.t -> expression
268266
val float_array_set :
@@ -451,8 +449,6 @@ val bswap16 : unary_primitive
451449

452450
type binary_primitive = expression -> expression -> Debuginfo.t -> expression
453451

454-
type assignment_kind = Caml_modify | Caml_initialize | Simple
455-
456452
(** [setfield offset value_is_ptr init ptr value dbg] *)
457453
val setfield :
458454
int -> Lambda.immediate_or_pointer -> Lambda.initialization_or_assignment ->

‎asmcomp/printcmm.ml

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -128,6 +128,7 @@ let operation d = function
128128
| Lambda.Heap_initialization -> "(heap-init)"
129129
| Lambda.Root_initialization -> "(root-init)"
130130
| Lambda.Assignment -> ""
131+
| Local_assignment -> "(local)"
131132
in
132133
Printf.sprintf "store %s%s" (chunk c) init
133134
| Caddi -> "+"

‎asmcomp/selectgen.ml

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -472,7 +472,7 @@ method select_operation op args _dbg =
472472
match init with
473473
| Lambda.Root_initialization -> false
474474
| Lambda.Heap_initialization -> false
475-
| Lambda.Assignment -> true
475+
| Lambda.Assignment | Lambda.Local_assignment -> true
476476
in
477477
if chunk = Word_int || chunk = Word_val then begin
478478
let (op, newarg2) = self#select_store is_assign addr arg2 in

‎lambda/lambda.ml

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -32,6 +32,7 @@ type immediate_or_pointer =
3232

3333
type initialization_or_assignment =
3434
| Assignment
35+
| Local_assignment
3536
| Heap_initialization
3637
| Root_initialization
3738

‎lambda/lambda.mli

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -33,6 +33,7 @@ type immediate_or_pointer =
3333

3434
type initialization_or_assignment =
3535
| Assignment
36+
| Local_assignment (* mutations of blocks that may be locally allocated *)
3637
(* Initialization of in heap values, like [caml_initialize] C primitive. The
3738
field should not have been read before and initialization should happen
3839
only once. *)

‎lambda/printlambda.ml

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -181,6 +181,7 @@ let primitive ppf = function
181181
| Heap_initialization -> "(heap-init)"
182182
| Root_initialization -> "(root-init)"
183183
| Assignment -> ""
184+
| Local_assignment -> "(local)"
184185
in
185186
fprintf ppf "setfield_%s%s %i" instr init n
186187
| Psetfield_computed (ptr, init) ->
@@ -194,6 +195,7 @@ let primitive ppf = function
194195
| Heap_initialization -> "(heap-init)"
195196
| Root_initialization -> "(root-init)"
196197
| Assignment -> ""
198+
| Local_assignment -> "(local)"
197199
in
198200
fprintf ppf "setfield_%s%s_computed" instr init
199201
| Pfloatfield n -> fprintf ppf "floatfield %i" n
@@ -203,6 +205,7 @@ let primitive ppf = function
203205
| Heap_initialization -> "(heap-init)"
204206
| Root_initialization -> "(root-init)"
205207
| Assignment -> ""
208+
| Local_assignment -> "(local)"
206209
in
207210
fprintf ppf "setfloatfield%s %i" init n
208211
| Pduprecord (rep, size) -> fprintf ppf "duprecord %a %i" record_rep rep size

‎lambda/translcore.ml

Lines changed: 9 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -409,15 +409,21 @@ and transl_exp0 ~in_new_scope ~scopes e =
409409
of_location ~scopes e.exp_loc)
410410
end
411411
| Texp_setfield(arg, _, lbl, newval) ->
412+
let mode =
413+
let arg_mode = Types.Value_mode.regional_to_local_alloc arg.exp_mode in
414+
match Types.Alloc_mode.constrain_lower arg_mode with
415+
| Global -> Assignment
416+
| Local -> Local_assignment
417+
in
412418
let access =
413419
match lbl.lbl_repres with
414420
Record_regular
415421
| Record_inlined _ ->
416-
Psetfield(lbl.lbl_pos, maybe_pointer newval, Assignment)
422+
Psetfield(lbl.lbl_pos, maybe_pointer newval, mode)
417423
| Record_unboxed _ -> assert false
418-
| Record_float -> Psetfloatfield (lbl.lbl_pos, Assignment)
424+
| Record_float -> Psetfloatfield (lbl.lbl_pos, mode)
419425
| Record_extension _ ->
420-
Psetfield (lbl.lbl_pos + 1, maybe_pointer newval, Assignment)
426+
Psetfield (lbl.lbl_pos + 1, maybe_pointer newval, mode)
421427
in
422428
Lprim(access, [transl_exp ~scopes arg; transl_exp ~scopes newval],
423429
of_location ~scopes e.exp_loc)

‎lambda/translprim.ml

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -125,7 +125,7 @@ let primitives_table =
125125
"%loc_FUNCTION", Loc Loc_FUNCTION;
126126
"%field0", Primitive ((Pfield 0), 1);
127127
"%field1", Primitive ((Pfield 1), 1);
128-
"%setfield0", Primitive ((Psetfield(0, Pointer, Assignment)), 2);
128+
"%setfield0", Primitive ((Psetfield(0, Pointer, Local_assignment (* FIXME *))), 2);
129129
"%makeblock", Primitive ((Pmakeblock(0, Immutable, None, Alloc_heap)), 1);
130130
"%makemutable", Primitive ((Pmakeblock(0, Mutable, None, Alloc_heap)), 1);
131131
"%makelocalmutable",

‎middle_end/closure/closure.ml

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -122,7 +122,7 @@ let prim_size prim args =
122122
| Psetfield(_f, isptr, init) ->
123123
begin match init with
124124
| Root_initialization -> 1 (* never causes a write barrier hit *)
125-
| Assignment | Heap_initialization ->
125+
| Assignment | Local_assignment | Heap_initialization ->
126126
match isptr with
127127
| Pointer -> 4
128128
| Immediate -> 1

‎middle_end/flambda/inlining_cost.ml

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -26,7 +26,7 @@ let prim_size (prim : Clambda_primitives.primitive) args =
2626
| Psetfield (_, isptr, init) ->
2727
begin match init with
2828
| Root_initialization -> 1 (* never causes a write barrier hit *)
29-
| Assignment | Heap_initialization ->
29+
| Assignment | Local_assignment | Heap_initialization ->
3030
match isptr with
3131
| Pointer -> 4
3232
| Immediate -> 1

‎middle_end/printclambda_primitives.ml

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -78,6 +78,7 @@ let primitive ppf (prim:Clambda_primitives.primitive) =
7878
| Heap_initialization -> "(heap-init)"
7979
| Root_initialization -> "(root-init)"
8080
| Assignment -> ""
81+
| Local_assignment -> "(local)"
8182
in
8283
fprintf ppf "setfield_%s%s %i" instr init n
8384
| Psetfield_computed (ptr, init) ->
@@ -91,6 +92,7 @@ let primitive ppf (prim:Clambda_primitives.primitive) =
9192
| Heap_initialization -> "(heap-init)"
9293
| Root_initialization -> "(root-init)"
9394
| Assignment -> ""
95+
| Local_assignment -> "(local)"
9496
in
9597
fprintf ppf "setfield_%s%s_computed" instr init
9698
| Pfloatfield n -> fprintf ppf "floatfield %i" n
@@ -100,6 +102,7 @@ let primitive ppf (prim:Clambda_primitives.primitive) =
100102
| Heap_initialization -> "(heap-init)"
101103
| Root_initialization -> "(root-init)"
102104
| Assignment -> ""
105+
| Local_assignment -> "(local)"
103106
in
104107
fprintf ppf "setfloatfield%s %i" init n
105108
| Pduprecord (rep, size) ->

‎runtime/memory.c

Lines changed: 13 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -677,6 +677,19 @@ CAMLexport CAMLweakdef void caml_modify (value *fp, value val)
677677
}
678678
}
679679

680+
/* This version of [caml_modify] may additionally be used to mutate
681+
locally-allocated objects. (This version is used by mutations
682+
generated from OCaml code when the value being modified may be
683+
locally allocated) */
684+
CAMLexport void caml_modify_local (value obj, intnat i, value val)
685+
{
686+
if (Color_hd(Hd_val(obj)) == Local_unmarked) {
687+
Field(obj, i) = val;
688+
} else {
689+
caml_modify(&Field(obj, i), val);
690+
}
691+
}
692+
680693
CAMLexport intnat caml_local_region_begin()
681694
{
682695
return Caml_state->local_sp;

‎runtime/minor_gc.c

Lines changed: 12 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -375,6 +375,18 @@ static void verify_minor_heap()
375375
}
376376
}
377377
}
378+
if (arena) {
379+
value** r;
380+
for (r = Caml_state->ref_table->base;
381+
r < Caml_state->ref_table->ptr; r++) {
382+
CAMLassert(!(arena->base <= (char*)*r &&
383+
(char*)*r < arena->base + arena->length));
384+
if (Is_block(**r)) {
385+
CAMLassert(!(arena->base <= (char*)**r &&
386+
(char*)**r < arena->base + arena->length));
387+
}
388+
}
389+
}
378390
}
379391
#endif
380392

‎testsuite/tests/translprim/ref_spec.compilers.reference

Lines changed: 20 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -6,10 +6,11 @@
66
cst_ref = (makemutable 0 0)
77
gen_ref = (makemutable 0 0)
88
flt_ref = (makemutable 0 (float) 0.))
9-
(seq (setfield_imm 0 int_ref 2) (setfield_imm 0 var_ref 66)
10-
(setfield_ptr 0 vargen_ref [0: 66 0]) (setfield_ptr 0 vargen_ref 67)
11-
(setfield_imm 0 cst_ref 1) (setfield_ptr 0 gen_ref [0: "foo"])
12-
(setfield_ptr 0 gen_ref 0) (setfield_ptr 0 flt_ref 1.)
9+
(seq (setfield_imm(local) 0 int_ref 2) (setfield_imm(local) 0 var_ref 66)
10+
(setfield_ptr(local) 0 vargen_ref [0: 66 0])
11+
(setfield_ptr(local) 0 vargen_ref 67) (setfield_imm(local) 0 cst_ref 1)
12+
(setfield_ptr(local) 0 gen_ref [0: "foo"])
13+
(setfield_ptr(local) 0 gen_ref 0) (setfield_ptr(local) 0 flt_ref 1.)
1314
(let
1415
(int_rec = (makemutable 0 (*,int) 0 1)
1516
var_rec = (makemutable 0 0 65)
@@ -24,14 +25,21 @@
2425
(setfield_ptr 1 gen_rec [0: "foo"]) (setfield_ptr 1 gen_rec 0)
2526
(setfield_ptr 1 flt_rec 1.) (setfloatfield 1 flt_rec' 1.)
2627
(let
27-
(set_open_poly = (function r[->L] y[->L] (setfield_ptr 0 r y))
28-
set_open_poly = (function r[->L] y[->L] (setfield_imm 0 r y))
29-
set_open_poly = (function r[->L] y[->L] (setfield_imm 0 r y))
30-
set_open_poly = (function r[->L] y[->L] (setfield_imm 0 r y))
31-
set_open_poly = (function r[->L] y[->L] (setfield_ptr 0 r y))
32-
set_open_poly = (function r[->L] y[->L] (setfield_ptr 0 r y))
33-
set_open_poly = (function r[->L] y[->L] (setfield_ptr 0 r y))
34-
set_open_poly = (function r y (setfield_ptr 0 r y)))
28+
(set_open_poly =
29+
(function r[->L] y[->L] (setfield_ptr(local) 0 r y))
30+
set_open_poly =
31+
(function r[->L] y[->L] (setfield_imm(local) 0 r y))
32+
set_open_poly =
33+
(function r[->L] y[->L] (setfield_imm(local) 0 r y))
34+
set_open_poly =
35+
(function r[->L] y[->L] (setfield_imm(local) 0 r y))
36+
set_open_poly =
37+
(function r[->L] y[->L] (setfield_ptr(local) 0 r y))
38+
set_open_poly =
39+
(function r[->L] y[->L] (setfield_ptr(local) 0 r y))
40+
set_open_poly =
41+
(function r[->L] y[->L] (setfield_ptr(local) 0 r y))
42+
set_open_poly = (function r y (setfield_ptr(local) 0 r y)))
3543
(makeblock 0 int_ref var_ref vargen_ref cst_ref gen_ref flt_ref
3644
int_rec var_rec vargen_rec cst_rec gen_rec flt_rec flt_rec'
3745
set_open_poly)))))))

‎testsuite/tests/typing-local/mutate.ml

Lines changed: 10 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,10 @@
1+
(* TEST *)
2+
let[@inline never] f (g : local_ _ -> unit) n =
3+
let r = local_ { contents = ref 0 } in
4+
g r;
5+
r.contents <- ref n;
6+
Gc.minor ();
7+
r.contents.contents
8+
9+
let _ =
10+
Printf.printf "%d\n" (f (fun _ -> ()) 42)

‎testsuite/tests/typing-local/mutate.reference

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1 @@
1+
42

0 commit comments

Comments
 (0)