flambda-backend: Add mutability annotations to Pfield etc. (#88)

Co-authored-by: Vincent Laviron <[email protected]>
Co-authored-by: xclerc <[email protected]>

Author: 3 people

asmcomp/cmmgen.ml

@@ -108,14 +108,14 @@ let invert_then_else = function
 
 let mut_from_env env ptr =
   match env.environment_param with
-  | None -> Mutable
+  | None -> Asttypes.Mutable
   | Some environment_param ->
     match ptr with
     | Cvar ptr ->
       (* Loads from the current function's closure are immutable. *)
-      if V.same environment_param ptr then Immutable
-      else Mutable
-    | _ -> Mutable
+      if V.same environment_param ptr then Asttypes.Immutable
+      else Asttypes.Mutable
+    | _ -> Asttypes.Mutable
 
 let get_field env ptr n dbg =
   let mut = mut_from_env env ptr in
@@ -1160,7 +1160,7 @@ and transl_let env str kind id exp body =
       (* N.B. [body] must still be traversed even if [exp] will never return:
          there may be constant closures inside that need lifting out. *)
       begin match str, kind with
-      | Immutable, _ -> Clet(id, cexp, transl env body)
+      | (Immutable | Immutable_unique), _ -> Clet(id, cexp, transl env body)
       | Mutable, Pintval -> Clet_mut(id, typ_int, cexp, transl env body)
       | Mutable, _ -> Clet_mut(id, typ_val, cexp, transl env body)
       end
@@ -1171,7 +1171,7 @@ and transl_let env str kind id exp body =
       let body =
         transl (add_unboxed_id (VP.var id) unboxed_id boxed_number env) body in
       begin match str, boxed_number with
-      | Immutable, _ -> Clet (v, cexp, body)
+      | (Immutable | Immutable_unique), _ -> Clet (v, cexp, body)
       | Mutable, bn -> Clet_mut (v, typ_of_boxed_number bn, cexp, body)
       end
 

boot/ocamlc

@@ -113,7 +113,7 @@ let preserve_tailcall_for_prim = function
       true
   | Pbytes_to_string | Pbytes_of_string | Pignore | Pgetglobal _ | Psetglobal _
   | Pmakeblock _ | Pmakefloatblock _
-  | Pfield _ | Pfield_computed | Psetfield _
+  | Pfield _ | Pfield_computed _ | Psetfield _
   | Psetfield_computed _ | Pfloatfield _ | Psetfloatfield _ | Pduprecord _
   | Pccall _ | Praise _ | Pnot | Pnegint | Paddint | Psubint | Pmulint
   | Pdivint _ | Pmodint _ | Pandint | Porint | Pxorint | Plslint | Plsrint
@@ -394,10 +394,11 @@ let comp_primitive p args =
   | Pcompare_ints -> Kccall("caml_int_compare", 2)
   | Pcompare_floats -> Kccall("caml_float_compare", 2)
   | Pcompare_bints bi -> comp_bint_primitive bi "compare" args
-  | Pfield n -> Kgetfield n
-  | Pfield_computed -> Kgetvectitem
+  | Pfield (n, _sem) -> Kgetfield n
+  | Pfield_computed _sem -> Kgetvectitem
   | Psetfield(n, _ptr, _init) -> Ksetfield n
   | Psetfield_computed(_ptr, _init) -> Ksetvectitem
+  | Pfloatfield (n, _sem) -> Kgetfloatfield n
   | Psetfloatfield (n, _init) -> Ksetfloatfield n
   | Pduprecord _ -> Kccall("caml_obj_dup", 1)
   | Pccall p -> Kccall(p.prim_name, p.prim_arity)
@@ -789,7 +790,7 @@ let rec comp_expr env exp sz cont =
   | Lprim(Pmakeblock(tag, _mut, _), args, loc) ->
       let cont = add_pseudo_event loc !compunit_name cont in
       comp_args env args sz (Kmakeblock(List.length args, tag) :: cont)
-  | Lprim(Pfloatfield n, args, loc) ->
+  | Lprim(Pfloatfield (n, _sem), args, loc) ->
       let cont = add_pseudo_event loc !compunit_name cont in
       comp_args env args sz (Kgetfloatfield n :: cont)
   | Lprim(p, args, _) ->

boot/ocamllex

@@ -16,6 +16,8 @@
 open Misc
 open Asttypes
 
+type mutable_flag = Immutable | Immutable_unique | Mutable
+
 type compile_time_constant =
   | Big_endian
   | Word_size
@@ -39,6 +41,10 @@ type is_safe =
   | Safe
   | Unsafe
 
+type field_read_semantics =
+  | Reads_agree
+  | Reads_vary
+
 type primitive =
   | Pidentity
   | Pbytes_to_string
@@ -52,11 +58,11 @@ type primitive =
   (* Operations on heap blocks *)
   | Pmakeblock of int * mutable_flag * block_shape
   | Pmakefloatblock of mutable_flag
-  | Pfield of int
-  | Pfield_computed
+  | Pfield of int * field_read_semantics
+  | Pfield_computed of field_read_semantics
   | Psetfield of int * immediate_or_pointer * initialization_or_assignment
   | Psetfield_computed of immediate_or_pointer * initialization_or_assignment
-  | Pfloatfield of int
+  | Pfloatfield of int * field_read_semantics
   | Psetfloatfield of int * initialization_or_assignment
   | Pduprecord of Types.record_representation * int
   (* Force lazy values *)
@@ -657,7 +663,7 @@ let rec transl_address loc = function
       then Lprim(Pgetglobal id, [], loc)
       else Lvar id
   | Env.Adot(addr, pos) ->
-      Lprim(Pfield pos, [transl_address loc addr], loc)
+      Lprim(Pfield (pos, Reads_agree), [transl_address loc addr], loc)
 
 let transl_path find loc env path =
   match find path env with
@@ -969,3 +975,9 @@ let max_arity () =
 
 let reset () =
   raise_count := 0
+
+let mod_field ?(read_semantics=Reads_agree) pos =
+  Pfield (pos, read_semantics)
+
+let mod_setfield pos =
+  Psetfield (pos, Pointer, Root_initialization)

bytecomp/bytegen.ml

@@ -17,6 +17,9 @@
 
 open Asttypes
 
+(* Overriding Asttypes.mutable_flag *)
+type mutable_flag = Immutable | Immutable_unique | Mutable
+
 type compile_time_constant =
   | Big_endian
   | Word_size
@@ -45,6 +48,10 @@ type is_safe =
   | Safe
   | Unsafe
 
+type field_read_semantics =
+  | Reads_agree
+  | Reads_vary
+
 type primitive =
   | Pidentity
   | Pbytes_to_string
@@ -58,11 +65,11 @@ type primitive =
   (* Operations on heap blocks *)
   | Pmakeblock of int * mutable_flag * block_shape
   | Pmakefloatblock of mutable_flag
-  | Pfield of int
-  | Pfield_computed
+  | Pfield of int * field_read_semantics
+  | Pfield_computed of field_read_semantics
   | Psetfield of int * immediate_or_pointer * initialization_or_assignment
   | Psetfield_computed of immediate_or_pointer * initialization_or_assignment
-  | Pfloatfield of int
+  | Pfloatfield of int * field_read_semantics
   | Psetfloatfield of int * initialization_or_assignment
   | Pduprecord of Types.record_representation * int
   (* External call *)
@@ -464,3 +471,10 @@ val merge_inline_attributes
   -> inline_attribute option
 
 val reset: unit -> unit
+
+(** Helpers for module block accesses.
+    Module accesses are always immutable, except in translobj where the
+    method cache is stored in a mutable module field.
+*)
+val mod_field: ?read_semantics: field_read_semantics -> int -> primitive
+val mod_setfield: int -> primitive

lambda/lambda.ml

@@ -1679,7 +1679,8 @@ let get_expr_args_constr ~scopes head (arg, _mut) rem =
       if pos > last_pos then
         argl
       else
-        (Lprim (Pfield pos, [ arg ], loc), binding_kind) :: make_args (pos + 1)
+        (Lprim (Pfield (pos, Reads_agree), [ arg ], loc), binding_kind)
+          :: make_args (pos + 1)
     in
     make_args first_pos
   in
@@ -1705,9 +1706,13 @@ let divide_constructor ~scopes ctx pm =
 
 let get_expr_args_variant_constant = drop_expr_arg
 
+let nonconstant_variant_field index =
+  Lambda.Pfield(index, Reads_agree)
+
 let get_expr_args_variant_nonconst ~scopes head (arg, _mut) rem =
   let loc = head_loc ~scopes head in
-  (Lprim (Pfield 1, [ arg ], loc), Alias) :: rem
+   let field_prim = nonconstant_variant_field 1 in
+  (Lprim (field_prim, [ arg ], loc), Alias) :: rem
 
 let divide_variant ~scopes row ctx { cases = cl; args; default = def } =
   let row = Btype.row_repr row in
@@ -1805,6 +1810,8 @@ let code_force_lazy = get_mod_field "CamlinternalLazy" "force"
    Forward(val_out_of_heap).
 *)
 
+let lazy_forward_field = Lambda.Pfield (0, Reads_vary)
+
 let inline_lazy_force_cond arg loc =
   let idarg = Ident.create_local "lzarg" in
   let varg = Lvar idarg in
@@ -1827,7 +1834,7 @@ let inline_lazy_force_cond arg loc =
                 ( Pintcomp Ceq,
                   [ tag_var; Lconst (Const_base (Const_int Obj.forward_tag)) ],
                   loc ),
-              Lprim (Pfield 0, [ varg ], loc),
+              Lprim (lazy_forward_field, [ varg ], loc),
               Lifthenelse
                 (* if (tag == Obj.lazy_tag) then Lazy.force varg else ... *)
                 ( Lprim
@@ -1865,7 +1872,8 @@ let inline_lazy_force_switch arg loc =
                 sw_numblocks = 256;
                 (* PR#6033 - tag ranges from 0 to 255 *)
                 sw_blocks =
-                  [ (Obj.forward_tag, Lprim (Pfield 0, [ varg ], loc));
+                  [ ( Obj.forward_tag,
+                      Lprim (lazy_forward_field, [ varg ], loc) );
                     ( Obj.lazy_tag,
                       Lapply
                         { ap_tailcall = Default_tailcall;
@@ -1929,7 +1937,8 @@ let get_expr_args_tuple ~scopes head (arg, _mut) rem =
     if pos >= arity then
       rem
     else
-      (Lprim (Pfield pos, [ arg ], loc), Alias) :: make_args (pos + 1)
+      (Lprim (Pfield (pos, Reads_agree), [ arg ], loc), Alias)
+        :: make_args (pos + 1)
   in
   make_args 0
 
@@ -1969,14 +1978,20 @@ let get_expr_args_record ~scopes head (arg, _mut) rem =
       rem
     else
       let lbl = all_labels.(pos) in
+      let sem =
+        match lbl.lbl_mut with
+        | Immutable -> Reads_agree
+        | Mutable -> Reads_vary
+      in
       let access =
         match lbl.lbl_repres with
         | Record_regular
         | Record_inlined _ ->
-            Lprim (Pfield lbl.lbl_pos, [ arg ], loc)
+            Lprim (Pfield (lbl.lbl_pos, sem), [ arg ], loc)
         | Record_unboxed _ -> arg
-        | Record_float -> Lprim (Pfloatfield lbl.lbl_pos, [ arg ], loc)
-        | Record_extension _ -> Lprim (Pfield (lbl.lbl_pos + 1), [ arg ], loc)
+        | Record_float -> Lprim (Pfloatfield (lbl.lbl_pos, sem), [ arg ], loc)
+        | Record_extension _ ->
+            Lprim (Pfield (lbl.lbl_pos + 1, sem), [ arg ], loc)
       in
       let str =
         match lbl.lbl_mut with
@@ -2711,7 +2726,9 @@ let combine_constructor loc arg pat_env cstr partial ctx def
                       (Lprim (Pintcomp Ceq, [ Lvar tag; ext ], loc), act, rem))
                   nonconsts default
               in
-              Llet (Alias, Pgenval, tag, Lprim (Pfield 0, [ arg ], loc), tests)
+              Llet (Alias, Pgenval, tag,
+                    Lprim (Pfield (0, Reads_agree), [ arg ], loc),
+                    tests)
         in
         List.fold_right
           (fun (path, act) rem ->
@@ -2802,7 +2819,7 @@ let call_switcher_variant_constr loc fail arg int_lambda_list =
     ( Alias,
       Pgenval,
       v,
-      Lprim (Pfield 0, [ arg ], loc),
+      Lprim (nonconstant_variant_field 0, [ arg ], loc),
       call_switcher loc fail (Lvar v) min_int max_int int_lambda_list )
 
 let combine_variant loc row arg partial ctx def (tag_lambda_list, total1, _pats)

lambda/lambda.mli

@@ -174,6 +174,11 @@ let float_comparison ppf = function
   | CFge -> fprintf ppf ">=."
   | CFnge -> fprintf ppf "!>=."
 
+let field_read_semantics ppf sem =
+  match sem with
+  | Reads_agree -> ()
+  | Reads_vary -> fprintf ppf "_mut"
+
 let primitive ppf = function
   | Pidentity -> fprintf ppf "id"
   | Pbytes_to_string -> fprintf ppf "bytes_to_string"
@@ -185,12 +190,18 @@ let primitive ppf = function
   | Psetglobal id -> fprintf ppf "setglobal %a" Ident.print id
   | Pmakeblock(tag, Immutable, shape) ->
       fprintf ppf "makeblock %i%a" tag block_shape shape
+  | Pmakeblock(tag, Immutable_unique, shape) ->
+      fprintf ppf "makeblock_unique %i%a" tag block_shape shape
   | Pmakeblock(tag, Mutable, shape) ->
       fprintf ppf "makemutable %i%a" tag block_shape shape
   | Pmakefloatblock Immutable -> fprintf ppf "makefloatblock Immutable"
+  | Pmakefloatblock Immutable_unique ->
+    fprintf ppf "makefloatblock Immutable_unique"
   | Pmakefloatblock Mutable -> fprintf ppf "makefloatblock Mutable"
-  | Pfield n -> fprintf ppf "field %i" n
-  | Pfield_computed -> fprintf ppf "field_computed"
+  | Pfield (n, sem) ->
+      fprintf ppf "field%a %i" field_read_semantics sem n
+  | Pfield_computed sem ->
+      fprintf ppf "field_computed%a" field_read_semantics sem
   | Psetfield(n, ptr, init) ->
       let instr =
         match ptr with
@@ -217,7 +228,8 @@ let primitive ppf = function
         | Assignment -> ""
       in
       fprintf ppf "setfield_%s%s_computed" instr init
-  | Pfloatfield n -> fprintf ppf "floatfield %i" n
+  | Pfloatfield (n, sem) ->
+      fprintf ppf "floatfield%a %i" field_read_semantics sem n
   | Psetfloatfield (n, init) ->
       let init =
         match init with
@@ -273,8 +285,12 @@ let primitive ppf = function
   | Parraylength k -> fprintf ppf "array.length[%s]" (array_kind k)
   | Pmakearray (k, Mutable) -> fprintf ppf "makearray[%s]" (array_kind k)
   | Pmakearray (k, Immutable) -> fprintf ppf "makearray_imm[%s]" (array_kind k)
+  | Pmakearray (k, Immutable_unique) ->
+      fprintf ppf "makearray_unique[%s]" (array_kind k)
   | Pduparray (k, Mutable) -> fprintf ppf "duparray[%s]" (array_kind k)
   | Pduparray (k, Immutable) -> fprintf ppf "duparray_imm[%s]" (array_kind k)
+  | Pduparray (k, Immutable_unique) ->
+      fprintf ppf "duparray_unique[%s]" (array_kind k)
   | Parrayrefu k -> fprintf ppf "array.unsafe_get[%s]" (array_kind k)
   | Parraysetu k -> fprintf ppf "array.unsafe_set[%s]" (array_kind k)
   | Parrayrefs k -> fprintf ppf "array.get[%s]" (array_kind k)
@@ -387,7 +403,7 @@ let name_of_primitive = function
   | Pmakeblock _ -> "Pmakeblock"
   | Pmakefloatblock _ -> "Pmakefloatblock"
   | Pfield _ -> "Pfield"
-  | Pfield_computed -> "Pfield_computed"
+  | Pfield_computed _ -> "Pfield_computed"
   | Psetfield _ -> "Psetfield"
   | Psetfield_computed _ -> "Psetfield_computed"
   | Pfloatfield _ -> "Pfloatfield"

lambda/matching.ml

@@ -40,9 +40,10 @@ let rec eliminate_ref id = function
   | Lletrec(idel, e2) ->
       Lletrec(List.map (fun (v, e) -> (v, eliminate_ref id e)) idel,
               eliminate_ref id e2)
-  | Lprim(Pfield 0, [Lvar v], _) when Ident.same v id ->
+  | Lprim(Pfield (0, _sem), [Lvar v], _) when Ident.same v id ->
       Lvar id
-  | Lprim(Psetfield(0, _, _), [Lvar v; e], _) when Ident.same v id ->
+  | Lprim(Psetfield(0, _, _), [Lvar v; e], _)
+    when Ident.same v id ->
       Lassign(id, eliminate_ref id e)
   | Lprim(Poffsetref delta, [Lvar v], loc) when Ident.same v id ->
       Lassign(id, Lprim(Poffsetint delta, [Lvar id], loc))