Add mutability annotations to Pfield etc.

backend/cmmgen.ml

@@ -133,14 +133,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
@@ -1192,7 +1192,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
@@ -1203,7 +1203,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
 

middle_end/clambda_primitives.ml

@@ -13,7 +13,7 @@
 (*                                                                        *)
 (**************************************************************************)
 
-type mutable_flag = Asttypes.mutable_flag
+type mutable_flag = Lambda.mutable_flag
 
 type immediate_or_pointer = Lambda.immediate_or_pointer
 

middle_end/clambda_primitives.mli

@@ -13,7 +13,7 @@
 (*                                                                        *)
 (**************************************************************************)
 
-type mutable_flag = Asttypes.mutable_flag
+type mutable_flag = Lambda.mutable_flag
 
 type immediate_or_pointer = Lambda.immediate_or_pointer
 

middle_end/closure/closure.ml

@@ -1108,12 +1108,13 @@ let rec close ({ backend; fenv; cenv ; mutable_vars } as env) lam =
       let dbg = Debuginfo.from_location loc in
       check_constant_result (getglobal dbg id)
                             (Compilenv.global_approx id)
-  | Lprim(Pfield n, [lam], loc) ->
+  | Lprim(Pfield (n, _), [lam], loc) ->
       let (ulam, approx) = close env lam in
       let dbg = Debuginfo.from_location loc in
       check_constant_result (Uprim(P.Pfield n, [ulam], dbg))
                             (field_approx n approx)
-  | Lprim(Psetfield(n, is_ptr, init), [Lprim(Pgetglobal id, [], _); lam], loc)->
+  | Lprim(Psetfield(n, is_ptr, init),
+          [Lprim(Pgetglobal id, [], _); lam], loc)->
       let (ulam, approx) = close env lam in
       if approx <> Value_unknown then
         (!global_approx).(n) <- approx;

middle_end/convert_primitives.ml

@@ -28,13 +28,13 @@ let convert (prim : Lambda.primitive) : Clambda_primitives.primitive =
       Pmakeblock (tag, mutability, shape)
   | Pmakefloatblock mutability ->
       Pmakearray (Pfloatarray, mutability)
-  | Pfield field -> Pfield field
-  | Pfield_computed -> Pfield_computed
+  | Pfield (field, _sem) -> Pfield field
+  | Pfield_computed _sem -> Pfield_computed
   | Psetfield (field, imm_or_pointer, init_or_assign) ->
       Psetfield (field, imm_or_pointer, init_or_assign)
   | Psetfield_computed (imm_or_pointer, init_or_assign) ->
       Psetfield_computed (imm_or_pointer, init_or_assign)
-  | Pfloatfield field -> Pfloatfield field
+  | Pfloatfield (field, _sem) -> Pfloatfield field
   | Psetfloatfield (field, init_or_assign) ->
       Psetfloatfield (field, init_or_assign)
   | Pduprecord (repr, size) -> Pduprecord (repr, size)

middle_end/flambda/alias_analysis.ml

@@ -23,8 +23,8 @@ type allocation_point =
 
 type allocated_const =
   | Normal of Allocated_const.t
-  | Array of Lambda.array_kind * Asttypes.mutable_flag * Variable.t list
-  | Duplicate_array of Lambda.array_kind * Asttypes.mutable_flag * Variable.t
+  | Array of Lambda.array_kind * Lambda.mutable_flag * Variable.t list
+  | Duplicate_array of Lambda.array_kind * Lambda.mutable_flag * Variable.t
 
 type constant_defining_value =
   | Allocated_const of allocated_const

middle_end/flambda/alias_analysis.mli

@@ -22,8 +22,8 @@ type allocation_point =
 
 type allocated_const =
   | Normal of Allocated_const.t
-  | Array of Lambda.array_kind * Asttypes.mutable_flag * Variable.t list
-  | Duplicate_array of Lambda.array_kind * Asttypes.mutable_flag * Variable.t
+  | Array of Lambda.array_kind * Lambda.mutable_flag * Variable.t list
+  | Duplicate_array of Lambda.array_kind * Lambda.mutable_flag * Variable.t
 
 type constant_defining_value =
   | Allocated_const of allocated_const

middle_end/flambda/inconstant_idents.ml

@@ -335,15 +335,16 @@ module Inconstants (P:Param) (Backend:Backend_intf.S) = struct
        makeblock(Mutable) can be a 'constant' if it is allocated at
        toplevel: if this expression is evaluated only once.
     *)
-    | Prim (Pmakeblock (_tag, Asttypes.Immutable, _value_kind), args,
-            _dbg) ->
+    | Prim (Pmakeblock (_tag, (Immutable | Immutable_unique), _value_kind),
+            args, _dbg) ->
       mark_vars args curr
 (*  (* CR-someday pchambart: If global mutables are allowed: *)
     | Prim(Lambda.Pmakeblock(_tag, Asttypes.Mutable), args, _dbg, _)
       when toplevel ->
       List.iter (mark_loop ~toplevel curr) args
 *)
-    | Prim (Pmakearray (Pfloatarray, Immutable), args, _) ->
+    | Prim (Pmakearray (Pfloatarray, (Immutable | Immutable_unique)),
+            args, _) ->
       mark_vars args curr
     | Prim (Pmakearray (Pfloatarray, Mutable), args, _) ->
       (* CR-someday pchambart: Toplevel float arrays could always be
@@ -356,7 +357,8 @@ module Inconstants (P:Param) (Backend:Backend_intf.S) = struct
       *)
       if toplevel then mark_vars args curr
       else mark_curr curr
-    | Prim (Pduparray (Pfloatarray, Immutable), [arg], _) ->
+    | Prim (Pduparray (Pfloatarray, (Immutable | Immutable_unique)),
+            [arg], _) ->
       mark_var arg curr
     | Prim (Pduparray (Pfloatarray, Mutable), [arg], _) ->
       if toplevel then mark_var arg curr

middle_end/flambda/lift_constants.ml

@@ -293,7 +293,7 @@ let translate_definition_and_resolve_alias inconstants
     ~(backend : (module Backend_intf.S))
     : Flambda.constant_defining_value option =
   let resolve_float_array_involving_variables
-        ~(mutability : Asttypes.mutable_flag) ~vars =
+        ~(mutability : Lambda.mutable_flag) ~vars =
     (* Resolve an [Allocated_const] of the form:
         [Array (Pfloatarray, _, _)]
        (which references its contents via variables; it does not contain
@@ -326,7 +326,7 @@ let translate_definition_and_resolve_alias inconstants
     in
     let const : Allocated_const.t =
       match mutability with
-      | Immutable -> Immutable_float_array floats
+      | Immutable | Immutable_unique -> Immutable_float_array floats
       | Mutable -> Float_array floats
     in
     Some (Flambda.Allocated_const const)
@@ -432,7 +432,7 @@ let translate_definition_and_resolve_alias inconstants
     | Allocated_const (Normal (Immutable_float_array floats)) ->
       let const : Allocated_const.t =
         match mutability with
-        | Immutable -> Immutable_float_array floats
+        | Immutable | Immutable_unique -> Immutable_float_array floats
         | Mutable -> Float_array floats
       in
       Some (Flambda.Allocated_const const)

middle_end/flambda/lift_let_to_initialize_symbol.ml

@@ -81,7 +81,8 @@ let rec accumulate ~substitution ~copied_lets ~extracted_lets
     let extracted =
       let renamed = Variable.rename var in
       match named with
-      | Prim (Pmakeblock (tag, Asttypes.Immutable, _value_kind), args, _dbg) ->
+      | Prim (Pmakeblock (tag, (Immutable | Immutable_unique), _value_kind),
+              args, _dbg) ->
         let tag = Tag.create_exn tag in
         let args =
           List.map (fun v ->

middle_end/flambda/ref_to_variables.ml

@@ -91,7 +91,7 @@ let variables_containing_ref (flam:Flambda.t) =
   let aux (flam : Flambda.t) =
     match flam with
     | Let { var;
-            defining_expr = Prim(Pmakeblock(0, Asttypes.Mutable, _), l, _);
+            defining_expr = Prim(Pmakeblock(0, Mutable, _), l, _);
           } ->
       map := Variable.Map.add var (List.length l) !map
     | _ -> ()
@@ -127,7 +127,7 @@ let eliminate_ref_of_expr flam =
     let aux (flam : Flambda.t) : Flambda.t =
       match flam with
       | Let { var;
-              defining_expr = Prim(Pmakeblock(0, Asttypes.Mutable, shape), l,_);
+              defining_expr = Prim(Pmakeblock(0, Mutable, shape), l,_);
               body }
         when convertible_variable var ->
         let shape = match shape with

middle_end/flambda/simplify_primitives.ml

@@ -108,27 +108,27 @@ let primitive (p : Clambda_primitives.primitive) (args, approxs)
     : Flambda.named * A.t * Inlining_cost.Benefit.t =
   let fpc = !Clflags.float_const_prop in
   match p with
-  | Pmakeblock(tag_int, Asttypes.Immutable, shape) ->
+  | Pmakeblock(tag_int, (Immutable | Immutable_unique), shape) ->
     let tag = Tag.create_exn tag_int in
     let shape = match shape with
       | None -> List.map (fun _ -> Lambda.Pgenval) args
       | Some shape -> shape
     in
     let approxs = List.map2 A.augment_with_kind approxs shape in
     let shape = List.map2 A.augment_kind_with_approx approxs shape in
-    Prim (Pmakeblock(tag_int, Asttypes.Immutable, Some shape), args, dbg),
+    Prim (Pmakeblock(tag_int, Lambda.Immutable, Some shape), args, dbg),
     A.value_block tag (Array.of_list approxs), C.Benefit.zero
   | Praise _ ->
     expr, A.value_bottom, C.Benefit.zero
   | Pmakearray(_, _) when is_empty approxs ->
-    Prim (Pmakeblock(0, Asttypes.Immutable, Some []), [], dbg),
+    Prim (Pmakeblock(0, Lambda.Immutable, Some []), [], dbg),
     A.value_block (Tag.create_exn 0) [||], C.Benefit.zero
   | Pmakearray (Pfloatarray, Mutable) ->
       let approx =
         A.value_mutable_float_array ~size:(List.length args)
       in
       expr, approx, C.Benefit.zero
-  | Pmakearray (Pfloatarray, Immutable) ->
+  | Pmakearray (Pfloatarray, (Immutable | Immutable_unique)) ->
       let approx =
         A.value_immutable_float_array (Array.of_list approxs)
       in

middle_end/internal_variable_names.ml

@@ -326,7 +326,7 @@ let of_primitive : Lambda.primitive -> string = function
   | Pmakeblock _ -> pmakeblock
   | Pmakefloatblock _ -> pmakefloatblock
   | Pfield _ -> pfield
-  | Pfield_computed -> pfield_computed
+  | Pfield_computed _ -> pfield_computed
   | Psetfield _ -> psetfield
   | Psetfield_computed _ -> psetfield_computed
   | Pfloatfield _ -> pfloatfield
@@ -434,7 +434,7 @@ let of_primitive_arg : Lambda.primitive -> string = function
   | Pmakeblock _ -> pmakeblock_arg
   | Pmakefloatblock _ -> pmakefloatblock_arg
   | Pfield _ -> pfield_arg
-  | Pfield_computed -> pfield_computed_arg
+  | Pfield_computed _ -> pfield_computed_arg
   | Psetfield _ -> psetfield_arg
   | Psetfield_computed _ -> psetfield_computed_arg
   | Pfloatfield _ -> pfloatfield_arg

middle_end/printclambda.ml

@@ -15,15 +15,14 @@
 
 
 open Format
-open Asttypes
 open Clambda
 
 module V = Backend_var
 module VP = Backend_var.With_provenance
 
 let mutable_flag = function
-  | Mutable-> "[mut]"
-  | Immutable -> ""
+  | Lambda.Mutable-> "[mut]"
+  | Lambda.Immutable | Lambda.Immutable_unique -> ""
 
 let value_kind =
   let open Lambda in

middle_end/printclambda_primitives.ml

@@ -15,7 +15,6 @@
 
 
 open Format
-open Asttypes
 
 let boxed_integer_name = function
   | Lambda.Pnativeint -> "nativeint"
@@ -59,6 +58,8 @@ let primitive ppf (prim:Clambda_primitives.primitive) =
       fprintf ppf "read_symbol %s" sym
   | Pmakeblock(tag, Immutable, shape) ->
       fprintf ppf "makeblock %i%a" tag Printlambda.block_shape shape
+  | Pmakeblock(tag, Immutable_unique, shape) ->
+      fprintf ppf "makeblock_unique %i%a" tag Printlambda.block_shape shape
   | Pmakeblock(tag, Mutable, shape) ->
       fprintf ppf "makemutable %i%a" tag Printlambda.block_shape shape
   | Pfield n -> fprintf ppf "field %i" n
@@ -146,8 +147,12 @@ let primitive ppf (prim:Clambda_primitives.primitive) =
   | 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)

middle_end/semantics_of_primitives.ml

@@ -23,8 +23,8 @@ let for_primitive (prim : Clambda_primitives.primitive) =
   match prim with
   | Pmakeblock _
   | Pmakearray (_, Mutable) -> Only_generative_effects, No_coeffects
-  | Pmakearray (_, Immutable) -> No_effects, No_coeffects
-  | Pduparray (_, Immutable) ->
+  | Pmakearray (_, (Immutable | Immutable_unique)) -> No_effects, No_coeffects
+  | Pduparray (_, (Immutable | Immutable_unique)) ->
       No_effects, No_coeffects  (* Pduparray (_, Immutable) is allowed only on
                                    immutable arrays. *)
   | Pduparray (_, Mutable) | Pduprecord _ ->

native_toplevel/opttoploop.ml

@@ -84,7 +84,7 @@ let close_phrase lam =
   Ident.Set.fold (fun id l ->
     let glb, pos = toplevel_value id in
     let glob =
-      Lprim (Pfield pos,
+      Lprim (mod_field pos,
              [Lprim (Pgetglobal glb, [], Loc_unknown)],
              Loc_unknown)
     in

ocaml/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
 

ocaml/bytecomp/bytegen.ml

@@ -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, _) ->