Skip to content

Commit d2cfaca

Browse files
mshinwelllthlsxclerc
authored
flambda-backend: Add mutability annotations to Pfield etc. (oxcaml#88)
Co-authored-by: Vincent Laviron <vincent.laviron@gmail.com> Co-authored-by: xclerc <xclerc@janestreet.com>
1 parent 5532555 commit d2cfaca

37 files changed

Lines changed: 213 additions & 124 deletions

‎asmcomp/cmmgen.ml‎

Lines changed: 6 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -108,14 +108,14 @@ let invert_then_else = function
108108

109109
let mut_from_env env ptr =
110110
match env.environment_param with
111-
| None -> Mutable
111+
| None -> Asttypes.Mutable
112112
| Some environment_param ->
113113
match ptr with
114114
| Cvar ptr ->
115115
(* Loads from the current function's closure are immutable. *)
116-
if V.same environment_param ptr then Immutable
117-
else Mutable
118-
| _ -> Mutable
116+
if V.same environment_param ptr then Asttypes.Immutable
117+
else Asttypes.Mutable
118+
| _ -> Asttypes.Mutable
119119

120120
let get_field env ptr n dbg =
121121
let mut = mut_from_env env ptr in
@@ -1160,7 +1160,7 @@ and transl_let env str kind id exp body =
11601160
(* N.B. [body] must still be traversed even if [exp] will never return:
11611161
there may be constant closures inside that need lifting out. *)
11621162
begin match str, kind with
1163-
| Immutable, _ -> Clet(id, cexp, transl env body)
1163+
| (Immutable | Immutable_unique), _ -> Clet(id, cexp, transl env body)
11641164
| Mutable, Pintval -> Clet_mut(id, typ_int, cexp, transl env body)
11651165
| Mutable, _ -> Clet_mut(id, typ_val, cexp, transl env body)
11661166
end
@@ -1171,7 +1171,7 @@ and transl_let env str kind id exp body =
11711171
let body =
11721172
transl (add_unboxed_id (VP.var id) unboxed_id boxed_number env) body in
11731173
begin match str, boxed_number with
1174-
| Immutable, _ -> Clet (v, cexp, body)
1174+
| (Immutable | Immutable_unique), _ -> Clet (v, cexp, body)
11751175
| Mutable, bn -> Clet_mut (v, typ_of_boxed_number bn, cexp, body)
11761176
end
11771177

‎boot/ocamlc‎

4.55 KB
Binary file not shown.

‎boot/ocamllex‎

-16 Bytes
Binary file not shown.

‎bytecomp/bytegen.ml‎

Lines changed: 5 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -113,7 +113,7 @@ let preserve_tailcall_for_prim = function
113113
true
114114
| Pbytes_to_string | Pbytes_of_string | Pignore | Pgetglobal _ | Psetglobal _
115115
| Pmakeblock _ | Pmakefloatblock _
116-
| Pfield _ | Pfield_computed | Psetfield _
116+
| Pfield _ | Pfield_computed _ | Psetfield _
117117
| Psetfield_computed _ | Pfloatfield _ | Psetfloatfield _ | Pduprecord _
118118
| Pccall _ | Praise _ | Pnot | Pnegint | Paddint | Psubint | Pmulint
119119
| Pdivint _ | Pmodint _ | Pandint | Porint | Pxorint | Plslint | Plsrint
@@ -394,10 +394,11 @@ let comp_primitive p args =
394394
| Pcompare_ints -> Kccall("caml_int_compare", 2)
395395
| Pcompare_floats -> Kccall("caml_float_compare", 2)
396396
| Pcompare_bints bi -> comp_bint_primitive bi "compare" args
397-
| Pfield n -> Kgetfield n
398-
| Pfield_computed -> Kgetvectitem
397+
| Pfield (n, _sem) -> Kgetfield n
398+
| Pfield_computed _sem -> Kgetvectitem
399399
| Psetfield(n, _ptr, _init) -> Ksetfield n
400400
| Psetfield_computed(_ptr, _init) -> Ksetvectitem
401+
| Pfloatfield (n, _sem) -> Kgetfloatfield n
401402
| Psetfloatfield (n, _init) -> Ksetfloatfield n
402403
| Pduprecord _ -> Kccall("caml_obj_dup", 1)
403404
| Pccall p -> Kccall(p.prim_name, p.prim_arity)
@@ -789,7 +790,7 @@ let rec comp_expr env exp sz cont =
789790
| Lprim(Pmakeblock(tag, _mut, _), args, loc) ->
790791
let cont = add_pseudo_event loc !compunit_name cont in
791792
comp_args env args sz (Kmakeblock(List.length args, tag) :: cont)
792-
| Lprim(Pfloatfield n, args, loc) ->
793+
| Lprim(Pfloatfield (n, _sem), args, loc) ->
793794
let cont = add_pseudo_event loc !compunit_name cont in
794795
comp_args env args sz (Kgetfloatfield n :: cont)
795796
| Lprim(p, args, _) ->

‎lambda/lambda.ml‎

Lines changed: 16 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -16,6 +16,8 @@
1616
open Misc
1717
open Asttypes
1818

19+
type mutable_flag = Immutable | Immutable_unique | Mutable
20+
1921
type compile_time_constant =
2022
| Big_endian
2123
| Word_size
@@ -39,6 +41,10 @@ type is_safe =
3941
| Safe
4042
| Unsafe
4143

44+
type field_read_semantics =
45+
| Reads_agree
46+
| Reads_vary
47+
4248
type primitive =
4349
| Pidentity
4450
| Pbytes_to_string
@@ -52,11 +58,11 @@ type primitive =
5258
(* Operations on heap blocks *)
5359
| Pmakeblock of int * mutable_flag * block_shape
5460
| Pmakefloatblock of mutable_flag
55-
| Pfield of int
56-
| Pfield_computed
61+
| Pfield of int * field_read_semantics
62+
| Pfield_computed of field_read_semantics
5763
| Psetfield of int * immediate_or_pointer * initialization_or_assignment
5864
| Psetfield_computed of immediate_or_pointer * initialization_or_assignment
59-
| Pfloatfield of int
65+
| Pfloatfield of int * field_read_semantics
6066
| Psetfloatfield of int * initialization_or_assignment
6167
| Pduprecord of Types.record_representation * int
6268
(* Force lazy values *)
@@ -657,7 +663,7 @@ let rec transl_address loc = function
657663
then Lprim(Pgetglobal id, [], loc)
658664
else Lvar id
659665
| Env.Adot(addr, pos) ->
660-
Lprim(Pfield pos, [transl_address loc addr], loc)
666+
Lprim(Pfield (pos, Reads_agree), [transl_address loc addr], loc)
661667

662668
let transl_path find loc env path =
663669
match find path env with
@@ -969,3 +975,9 @@ let max_arity () =
969975

970976
let reset () =
971977
raise_count := 0
978+
979+
let mod_field ?(read_semantics=Reads_agree) pos =
980+
Pfield (pos, read_semantics)
981+
982+
let mod_setfield pos =
983+
Psetfield (pos, Pointer, Root_initialization)

‎lambda/lambda.mli‎

Lines changed: 17 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -17,6 +17,9 @@
1717

1818
open Asttypes
1919

20+
(* Overriding Asttypes.mutable_flag *)
21+
type mutable_flag = Immutable | Immutable_unique | Mutable
22+
2023
type compile_time_constant =
2124
| Big_endian
2225
| Word_size
@@ -45,6 +48,10 @@ type is_safe =
4548
| Safe
4649
| Unsafe
4750

51+
type field_read_semantics =
52+
| Reads_agree
53+
| Reads_vary
54+
4855
type primitive =
4956
| Pidentity
5057
| Pbytes_to_string
@@ -58,11 +65,11 @@ type primitive =
5865
(* Operations on heap blocks *)
5966
| Pmakeblock of int * mutable_flag * block_shape
6067
| Pmakefloatblock of mutable_flag
61-
| Pfield of int
62-
| Pfield_computed
68+
| Pfield of int * field_read_semantics
69+
| Pfield_computed of field_read_semantics
6370
| Psetfield of int * immediate_or_pointer * initialization_or_assignment
6471
| Psetfield_computed of immediate_or_pointer * initialization_or_assignment
65-
| Pfloatfield of int
72+
| Pfloatfield of int * field_read_semantics
6673
| Psetfloatfield of int * initialization_or_assignment
6774
| Pduprecord of Types.record_representation * int
6875
(* External call *)
@@ -464,3 +471,10 @@ val merge_inline_attributes
464471
-> inline_attribute option
465472

466473
val reset: unit -> unit
474+
475+
(** Helpers for module block accesses.
476+
Module accesses are always immutable, except in translobj where the
477+
method cache is stored in a mutable module field.
478+
*)
479+
val mod_field: ?read_semantics: field_read_semantics -> int -> primitive
480+
val mod_setfield: int -> primitive

‎lambda/matching.ml‎

Lines changed: 27 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -1679,7 +1679,8 @@ let get_expr_args_constr ~scopes head (arg, _mut) rem =
16791679
if pos > last_pos then
16801680
argl
16811681
else
1682-
(Lprim (Pfield pos, [ arg ], loc), binding_kind) :: make_args (pos + 1)
1682+
(Lprim (Pfield (pos, Reads_agree), [ arg ], loc), binding_kind)
1683+
:: make_args (pos + 1)
16831684
in
16841685
make_args first_pos
16851686
in
@@ -1705,9 +1706,13 @@ let divide_constructor ~scopes ctx pm =
17051706

17061707
let get_expr_args_variant_constant = drop_expr_arg
17071708

1709+
let nonconstant_variant_field index =
1710+
Lambda.Pfield(index, Reads_agree)
1711+
17081712
let get_expr_args_variant_nonconst ~scopes head (arg, _mut) rem =
17091713
let loc = head_loc ~scopes head in
1710-
(Lprim (Pfield 1, [ arg ], loc), Alias) :: rem
1714+
let field_prim = nonconstant_variant_field 1 in
1715+
(Lprim (field_prim, [ arg ], loc), Alias) :: rem
17111716

17121717
let divide_variant ~scopes row ctx { cases = cl; args; default = def } =
17131718
let row = Btype.row_repr row in
@@ -1805,6 +1810,8 @@ let code_force_lazy = get_mod_field "CamlinternalLazy" "force"
18051810
Forward(val_out_of_heap).
18061811
*)
18071812

1813+
let lazy_forward_field = Lambda.Pfield (0, Reads_vary)
1814+
18081815
let inline_lazy_force_cond arg loc =
18091816
let idarg = Ident.create_local "lzarg" in
18101817
let varg = Lvar idarg in
@@ -1827,7 +1834,7 @@ let inline_lazy_force_cond arg loc =
18271834
( Pintcomp Ceq,
18281835
[ tag_var; Lconst (Const_base (Const_int Obj.forward_tag)) ],
18291836
loc ),
1830-
Lprim (Pfield 0, [ varg ], loc),
1837+
Lprim (lazy_forward_field, [ varg ], loc),
18311838
Lifthenelse
18321839
(* if (tag == Obj.lazy_tag) then Lazy.force varg else ... *)
18331840
( Lprim
@@ -1865,7 +1872,8 @@ let inline_lazy_force_switch arg loc =
18651872
sw_numblocks = 256;
18661873
(* PR#6033 - tag ranges from 0 to 255 *)
18671874
sw_blocks =
1868-
[ (Obj.forward_tag, Lprim (Pfield 0, [ varg ], loc));
1875+
[ ( Obj.forward_tag,
1876+
Lprim (lazy_forward_field, [ varg ], loc) );
18691877
( Obj.lazy_tag,
18701878
Lapply
18711879
{ ap_tailcall = Default_tailcall;
@@ -1929,7 +1937,8 @@ let get_expr_args_tuple ~scopes head (arg, _mut) rem =
19291937
if pos >= arity then
19301938
rem
19311939
else
1932-
(Lprim (Pfield pos, [ arg ], loc), Alias) :: make_args (pos + 1)
1940+
(Lprim (Pfield (pos, Reads_agree), [ arg ], loc), Alias)
1941+
:: make_args (pos + 1)
19331942
in
19341943
make_args 0
19351944

@@ -1969,14 +1978,20 @@ let get_expr_args_record ~scopes head (arg, _mut) rem =
19691978
rem
19701979
else
19711980
let lbl = all_labels.(pos) in
1981+
let sem =
1982+
match lbl.lbl_mut with
1983+
| Immutable -> Reads_agree
1984+
| Mutable -> Reads_vary
1985+
in
19721986
let access =
19731987
match lbl.lbl_repres with
19741988
| Record_regular
19751989
| Record_inlined _ ->
1976-
Lprim (Pfield lbl.lbl_pos, [ arg ], loc)
1990+
Lprim (Pfield (lbl.lbl_pos, sem), [ arg ], loc)
19771991
| Record_unboxed _ -> arg
1978-
| Record_float -> Lprim (Pfloatfield lbl.lbl_pos, [ arg ], loc)
1979-
| Record_extension _ -> Lprim (Pfield (lbl.lbl_pos + 1), [ arg ], loc)
1992+
| Record_float -> Lprim (Pfloatfield (lbl.lbl_pos, sem), [ arg ], loc)
1993+
| Record_extension _ ->
1994+
Lprim (Pfield (lbl.lbl_pos + 1, sem), [ arg ], loc)
19801995
in
19811996
let str =
19821997
match lbl.lbl_mut with
@@ -2711,7 +2726,9 @@ let combine_constructor loc arg pat_env cstr partial ctx def
27112726
(Lprim (Pintcomp Ceq, [ Lvar tag; ext ], loc), act, rem))
27122727
nonconsts default
27132728
in
2714-
Llet (Alias, Pgenval, tag, Lprim (Pfield 0, [ arg ], loc), tests)
2729+
Llet (Alias, Pgenval, tag,
2730+
Lprim (Pfield (0, Reads_agree), [ arg ], loc),
2731+
tests)
27152732
in
27162733
List.fold_right
27172734
(fun (path, act) rem ->
@@ -2802,7 +2819,7 @@ let call_switcher_variant_constr loc fail arg int_lambda_list =
28022819
( Alias,
28032820
Pgenval,
28042821
v,
2805-
Lprim (Pfield 0, [ arg ], loc),
2822+
Lprim (nonconstant_variant_field 0, [ arg ], loc),
28062823
call_switcher loc fail (Lvar v) min_int max_int int_lambda_list )
28072824

28082825
let combine_variant loc row arg partial ctx def (tag_lambda_list, total1, _pats)

‎lambda/printlambda.ml‎

Lines changed: 20 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -174,6 +174,11 @@ let float_comparison ppf = function
174174
| CFge -> fprintf ppf ">=."
175175
| CFnge -> fprintf ppf "!>=."
176176

177+
let field_read_semantics ppf sem =
178+
match sem with
179+
| Reads_agree -> ()
180+
| Reads_vary -> fprintf ppf "_mut"
181+
177182
let primitive ppf = function
178183
| Pidentity -> fprintf ppf "id"
179184
| Pbytes_to_string -> fprintf ppf "bytes_to_string"
@@ -185,12 +190,18 @@ let primitive ppf = function
185190
| Psetglobal id -> fprintf ppf "setglobal %a" Ident.print id
186191
| Pmakeblock(tag, Immutable, shape) ->
187192
fprintf ppf "makeblock %i%a" tag block_shape shape
193+
| Pmakeblock(tag, Immutable_unique, shape) ->
194+
fprintf ppf "makeblock_unique %i%a" tag block_shape shape
188195
| Pmakeblock(tag, Mutable, shape) ->
189196
fprintf ppf "makemutable %i%a" tag block_shape shape
190197
| Pmakefloatblock Immutable -> fprintf ppf "makefloatblock Immutable"
198+
| Pmakefloatblock Immutable_unique ->
199+
fprintf ppf "makefloatblock Immutable_unique"
191200
| Pmakefloatblock Mutable -> fprintf ppf "makefloatblock Mutable"
192-
| Pfield n -> fprintf ppf "field %i" n
193-
| Pfield_computed -> fprintf ppf "field_computed"
201+
| Pfield (n, sem) ->
202+
fprintf ppf "field%a %i" field_read_semantics sem n
203+
| Pfield_computed sem ->
204+
fprintf ppf "field_computed%a" field_read_semantics sem
194205
| Psetfield(n, ptr, init) ->
195206
let instr =
196207
match ptr with
@@ -217,7 +228,8 @@ let primitive ppf = function
217228
| Assignment -> ""
218229
in
219230
fprintf ppf "setfield_%s%s_computed" instr init
220-
| Pfloatfield n -> fprintf ppf "floatfield %i" n
231+
| Pfloatfield (n, sem) ->
232+
fprintf ppf "floatfield%a %i" field_read_semantics sem n
221233
| Psetfloatfield (n, init) ->
222234
let init =
223235
match init with
@@ -273,8 +285,12 @@ let primitive ppf = function
273285
| Parraylength k -> fprintf ppf "array.length[%s]" (array_kind k)
274286
| Pmakearray (k, Mutable) -> fprintf ppf "makearray[%s]" (array_kind k)
275287
| Pmakearray (k, Immutable) -> fprintf ppf "makearray_imm[%s]" (array_kind k)
288+
| Pmakearray (k, Immutable_unique) ->
289+
fprintf ppf "makearray_unique[%s]" (array_kind k)
276290
| Pduparray (k, Mutable) -> fprintf ppf "duparray[%s]" (array_kind k)
277291
| Pduparray (k, Immutable) -> fprintf ppf "duparray_imm[%s]" (array_kind k)
292+
| Pduparray (k, Immutable_unique) ->
293+
fprintf ppf "duparray_unique[%s]" (array_kind k)
278294
| Parrayrefu k -> fprintf ppf "array.unsafe_get[%s]" (array_kind k)
279295
| Parraysetu k -> fprintf ppf "array.unsafe_set[%s]" (array_kind k)
280296
| Parrayrefs k -> fprintf ppf "array.get[%s]" (array_kind k)
@@ -387,7 +403,7 @@ let name_of_primitive = function
387403
| Pmakeblock _ -> "Pmakeblock"
388404
| Pmakefloatblock _ -> "Pmakefloatblock"
389405
| Pfield _ -> "Pfield"
390-
| Pfield_computed -> "Pfield_computed"
406+
| Pfield_computed _ -> "Pfield_computed"
391407
| Psetfield _ -> "Psetfield"
392408
| Psetfield_computed _ -> "Psetfield_computed"
393409
| Pfloatfield _ -> "Pfloatfield"

‎lambda/simplif.ml‎

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -40,9 +40,10 @@ let rec eliminate_ref id = function
4040
| Lletrec(idel, e2) ->
4141
Lletrec(List.map (fun (v, e) -> (v, eliminate_ref id e)) idel,
4242
eliminate_ref id e2)
43-
| Lprim(Pfield 0, [Lvar v], _) when Ident.same v id ->
43+
| Lprim(Pfield (0, _sem), [Lvar v], _) when Ident.same v id ->
4444
Lvar id
45-
| Lprim(Psetfield(0, _, _), [Lvar v; e], _) when Ident.same v id ->
45+
| Lprim(Psetfield(0, _, _), [Lvar v; e], _)
46+
when Ident.same v id ->
4647
Lassign(id, eliminate_ref id e)
4748
| Lprim(Poffsetref delta, [Lvar v], loc) when Ident.same v id ->
4849
Lassign(id, Lprim(Poffsetint delta, [Lvar id], loc))

0 commit comments

Comments
 (0)