flambda-backend: Implement mutable() logic for record and array (#2369

) * implement mutable() logic for record and array * fix chamleon * address some comments * move the coupling of mutable and global * better printing * fix array modalities * remove irrelavent test * address comments * make depend * bootstrap
ocaml-flambda · Apr 2, 2024 · 37d03a9 · 37d03a9
1 parent f7cc47a
commit 37d03a9
Show file tree

Hide file tree

Showing 33 changed files with 289 additions and 168 deletions.
diff --git a/.depend b/.depend
@@ -592,6 +592,7 @@ parsing/parse.cmi : \
 parsing/parser.cmo : \
     parsing/syntaxerr.cmi \
     parsing/parsetree.cmi \
+    utils/misc.cmi \
     parsing/longident.cmi \
     parsing/location.cmi \
     utils/language_extension.cmi \
@@ -608,6 +609,7 @@ parsing/parser.cmo : \
 parsing/parser.cmx : \
     parsing/syntaxerr.cmx \
     parsing/parsetree.cmi \
+    utils/misc.cmx \
     parsing/longident.cmx \
     parsing/location.cmx \
     utils/language_extension.cmx \
@@ -1354,6 +1356,7 @@ typing/primitive.cmo : \
     typing/outcometree.cmi \
     utils/misc.cmi \
     parsing/location.cmi \
+    utils/language_extension.cmi \
     typing/jkind.cmi \
     parsing/attr_helper.cmi \
     typing/primitive.cmi
@@ -1362,6 +1365,7 @@ typing/primitive.cmx : \
     typing/outcometree.cmi \
     utils/misc.cmx \
     parsing/location.cmx \
+    utils/language_extension.cmx \
     typing/jkind.cmx \
     parsing/attr_helper.cmx \
     typing/primitive.cmi
@@ -1736,6 +1740,7 @@ typing/typecore.cmo : \
     typing/typedtree.cmi \
     typing/typedecl.cmi \
     typing/subst.cmi \
+    typing/solver.cmi \
     typing/shape.cmi \
     typing/rec_check.cmi \
     typing/printtyp.cmi \
@@ -1777,6 +1782,7 @@ typing/typecore.cmx : \
     typing/typedtree.cmx \
     typing/typedecl.cmx \
     typing/subst.cmx \
+    typing/solver.cmx \
     typing/shape.cmx \
     typing/rec_check.cmx \
     typing/printtyp.cmx \
@@ -1843,6 +1849,7 @@ typing/typedecl.cmo : \
     utils/misc.cmi \
     parsing/longident.cmi \
     parsing/location.cmi \
+    utils/language_extension.cmi \
     typing/jkind.cmi \
     parsing/jane_syntax.cmi \
     typing/includecore.cmi \
@@ -1879,6 +1886,7 @@ typing/typedecl.cmx : \
     utils/misc.cmx \
     parsing/longident.cmx \
     parsing/location.cmx \
+    utils/language_extension.cmx \
     typing/jkind.cmx \
     parsing/jane_syntax.cmx \
     typing/includecore.cmx \
@@ -2167,7 +2175,6 @@ typing/typeopt.cmo : \
     typing/ctype.cmi \
     utils/config.cmi \
     utils/clflags.cmi \
-    parsing/asttypes.cmi \
     typing/typeopt.cmi
 typing/typeopt.cmx : \
     typing/types.cmx \
@@ -2186,7 +2193,6 @@ typing/typeopt.cmx : \
     typing/ctype.cmx \
     utils/config.cmx \
     utils/clflags.cmx \
-    parsing/asttypes.cmi \
     typing/typeopt.cmi
 typing/typeopt.cmi : \
     typing/types.cmi \
@@ -2332,9 +2338,11 @@ typing/uniqueness_analysis.cmx : \
 typing/uniqueness_analysis.cmi : \
     typing/typedtree.cmi
 typing/untypeast.cmo : \
+    typing/types.cmi \
     typing/typedtree.cmi \
     typing/path.cmi \
     parsing/parsetree.cmi \
+    typing/mode.cmi \
     utils/misc.cmi \
     parsing/longident.cmi \
     parsing/location.cmi \
@@ -2345,9 +2353,11 @@ typing/untypeast.cmo : \
     parsing/ast_helper.cmi \
     typing/untypeast.cmi
 typing/untypeast.cmx : \
+    typing/types.cmx \
     typing/typedtree.cmx \
     typing/path.cmx \
     parsing/parsetree.cmi \
+    typing/mode.cmx \
     utils/misc.cmx \
     parsing/longident.cmx \
     parsing/location.cmx \

diff --git a/boot/ocamlc b/boot/ocamlc
diff --git a/lambda/matching.ml b/lambda/matching.ml
@@ -2145,9 +2145,7 @@ let get_expr_args_record ~scopes head (arg, _mut, sort, layout) rem =
       let lbl_sort = Jkind.sort_of_jkind lbl.lbl_jkind in
       let lbl_layout = Typeopt.layout_of_sort lbl.lbl_loc lbl_sort in
       let sem =
-        match lbl.lbl_mut with
-        | Immutable -> Reads_agree
-        | Mutable -> Reads_vary
+        if Types.is_mutable lbl.lbl_mut then Reads_vary else Reads_agree
       in
       let access, sort, layout =
         match lbl.lbl_repres with
@@ -2170,11 +2168,7 @@ let get_expr_args_record ~scopes head (arg, _mut, sort, layout) rem =
             Lprim (Pfield (lbl.lbl_pos + 1, ptr, sem), [ arg ], loc),
             lbl_sort, lbl_layout
       in
-      let str =
-        match lbl.lbl_mut with
-        | Immutable -> Alias
-        | Mutable -> StrictOpt
-      in
+      let str = if Types.is_mutable lbl.lbl_mut then StrictOpt else Alias in
       (access, str, sort, layout) :: make_args (pos + 1)
   in
   make_args 0
@@ -2222,9 +2216,7 @@ let get_expr_args_array ~scopes kind head (arg, _mut, _sort, _layout) rem =
           (Parrayrefu (ref_kind, Ptagged_int_index),
            [ arg; Lconst (Const_base (Const_int pos)) ],
            loc),
-        (match am with
-        | Mutable   -> StrictOpt
-        | Immutable -> Alias),
+        (if Types.is_mutable am then StrictOpt else Alias),
         arg_sort,
         result_layout)
       :: make_args (pos + 1)
@@ -3640,10 +3632,7 @@ let is_record_with_mutable_field p =
   match p.pat_desc with
   | Tpat_record (lps, _) ->
       List.exists
-        (fun (_, lbl, _) ->
-          match lbl.Types.lbl_mut with
-          | Mutable -> true
-          | Immutable -> false)
+        (fun (_, lbl, _) -> Types.is_mutable lbl.lbl_mut)
         lps
   | Tpat_alias _
   | Tpat_variant _

diff --git a/lambda/translcore.ml b/lambda/translcore.ml
@@ -554,9 +554,7 @@ and transl_exp0 ~in_new_scope ~scopes sort e =
   | Texp_field(arg, id, lbl, float) ->
       let targ = transl_exp ~scopes Jkind.Sort.for_record arg in
       let sem =
-        match lbl.lbl_mut with
-        | Immutable -> Reads_agree
-        | Mutable -> Reads_vary
+        if Types.is_mutable lbl.lbl_mut then Reads_vary else Reads_agree
       in
       let lbl_sort = Jkind.sort_of_jkind lbl.lbl_jkind in
       check_record_field_sort id.loc lbl_sort lbl.lbl_repres;
@@ -622,16 +620,14 @@ and transl_exp0 ~in_new_scope ~scopes sort e =
       in
       let imm_array = makearray Immutable in
       let lambda_arr_mut : Lambda.mutable_flag =
-        match (amut : Asttypes.mutable_flag) with
-        | Mutable   -> Mutable
-        | Immutable -> Immutable
+        if Types.is_mutable amut then Mutable else Immutable
       in
       begin try
         (* For native code the decision as to which compilation strategy to
            use is made later.  This enables the Flambda passes to lift certain
            kinds of array definitions to symbols. *)
         (* Deactivate constant optimization if array is small enough *)
-        if amut = Asttypes.Mutable &&
+        if Types.is_mutable amut &&
            List.length ll <= use_dup_for_constant_mutable_arrays_bigger_than
         then begin
           raise Not_constant
@@ -640,7 +636,7 @@ and transl_exp0 ~in_new_scope ~scopes sort e =
         if is_local_mode mode then raise Not_constant;
         begin match List.map extract_constant ll with
         | exception Not_constant
-          when kind = Pfloatarray && amut = Asttypes.Mutable ->
+          when kind = Pfloatarray && Types.is_mutable amut ->
             (* We cannot currently lift mutable [Pintarray] arrays safely in
                Flambda because [caml_modify] might be called upon them
                (e.g. from code operating on polymorphic arrays, or functions
@@ -669,9 +665,7 @@ and transl_exp0 ~in_new_scope ~scopes sort e =
                 | Punboxedfloatarray _ | Punboxedintarray _ ->
                   Misc.fatal_error "Use flambda2 for unboxed arrays"
             in
-            match amut with
-            | Mutable   -> duparray_to_mutable const
-            | Immutable -> const
+            if Types.is_mutable amut then duparray_to_mutable const else const
         end
       with Not_constant ->
         makearray lambda_arr_mut
@@ -1663,9 +1657,7 @@ and transl_record ~scopes loc env mode fields repres opt_init_expr =
                  record_field_kind (layout env lbl.lbl_loc lbl_sort typ)
                in
                let sem =
-                 match mut with
-                 | Immutable -> Reads_agree
-                 | Mutable -> Reads_vary
+                 if Types.is_mutable mut then Reads_vary else Reads_agree
                in
                let access =
                  match repres with
@@ -1691,7 +1683,7 @@ and transl_record ~scopes loc env mode fields repres opt_init_expr =
     in
     let ll, shape = List.split (Array.to_list lv) in
     let mut : Lambda.mutable_flag =
-      if Array.exists (fun (lbl, _) -> lbl.lbl_mut = Asttypes.Mutable) fields
+      if Array.exists (fun (lbl, _) -> Types.is_mutable lbl.lbl_mut) fields
       then Mutable
       else Immutable in
     let lam =

diff --git a/ocamldoc/odoc_sig.ml b/ocamldoc/odoc_sig.ml
@@ -440,7 +440,7 @@ module Analyser =
       let comment_opt = analyze_alerts comment_opt ld_attributes in
       {
         rf_name = field_name ;
-        rf_mutable = mutable_flag = Mutable ;
+        rf_mutable = Types.is_mutable mutable_flag;
         rf_type = Odoc_env.subst_type env type_expr ;
         rf_text = comment_opt
       }

diff --git a/testsuite/tests/typing-core-bugs/const_int_hint.ml b/testsuite/tests/typing-core-bugs/const_int_hint.ml
@@ -187,12 +187,12 @@ Error: This pattern matches values of type int
        but a pattern was expected which matches values of type int32
   Hint: Did you mean `0b1000_1101l'?
 |}]
-type t1 = {f1: int32};; let _ = fun x -> x.f1 <- 1_000n;;
+type t1 = {mutable f1: int32};; let _ = fun x -> x.f1 <- 1_000n;;
 [%%expect{|
-type t1 = { f1 : int32; }
-Line 1, characters 49-55:
-1 | type t1 = {f1: int32};; let _ = fun x -> x.f1 <- 1_000n;;
-                                                     ^^^^^^
+type t1 = { mutable f1 : int32; }
+Line 1, characters 57-63:
+1 | type t1 = {mutable f1: int32};; let _ = fun x -> x.f1 <- 1_000n;;
+                                                             ^^^^^^
 Error: This expression has type nativeint
        but an expression was expected of type int32
   Hint: Did you mean `1_000l'?

diff --git a/testsuite/tests/typing-modes/mutable.ml b/testsuite/tests/typing-modes/mutable.ml
@@ -0,0 +1,10 @@
+(* TEST
+   * expect
+   flags = "-extension unique"
+*)
+
+(* Since [mutable] implies [global] modality, which in turns implies [shared]
+   and [many] modalities, the effect of mutable in isolation is not testable
+   yet. *)
+
+(* CR zqian: add test for mutable when mutable is decoupled from modalities. *)
diff --git a/typing/ctype.ml b/typing/ctype.ml
@@ -4318,7 +4318,7 @@ type add_instance_variable_failure =
 
 exception Add_instance_variable_failed of add_instance_variable_failure
 
-let check_mutability mut mut' =
+let check_mutability (mut : mutable_flag) (mut' : mutable_flag) =
   match mut, mut' with
   | Mutable, Mutable -> ()
   | Immutable, Immutable -> ()
@@ -5295,10 +5295,10 @@ let match_class_sig_shape ~strict sign1 sign2 =
   in
   let errors =
     Vars.fold
-      (fun lab (mut, vr, _) err ->
+      (fun lab ((mut:Asttypes.mutable_flag), vr, _) err ->
          match Vars.find lab sign1.csig_vars with
          | exception Not_found -> CM_Missing_value lab::err
-         | (mut', vr', _) ->
+         | ((mut':Asttypes.mutable_flag), vr', _) ->
              match mut', mut with
              | Immutable, Mutable -> CM_Non_mutable_value lab::err
              | _, _ ->

diff --git a/typing/env.ml b/typing/env.ml
@@ -123,13 +123,13 @@ let label_usage_complaint priv mut lu
   | Asttypes.Private, _ ->
       if lu.lu_projection then None
       else Some Unused
-  | Asttypes.Public, Asttypes.Immutable -> begin
+  | Asttypes.Public, Types.Immutable -> begin
       match lu.lu_projection, lu.lu_construct with
       | true, _ -> None
       | false, false -> Some Unused
       | false, true -> Some Not_read
     end
-  | Asttypes.Public, Asttypes.Mutable -> begin
+  | Asttypes.Public, Types.Mutable _ -> begin
       match lu.lu_projection, lu.lu_mutation, lu.lu_construct with
       | true, true, _ -> None
       | false, false, false -> Some Unused

diff --git a/typing/includecore.ml b/typing/includecore.ml
@@ -543,11 +543,22 @@ module Record_diffing = struct
   let compare_labels env params1 params2
         (ld1 : Types.label_declaration)
         (ld2 : Types.label_declaration) =
-        if ld1.ld_mutable <> ld2.ld_mutable
-        then
-          let ord = if ld1.ld_mutable = Asttypes.Mutable then First else Second in
-          Some (Mutability ord)
-        else begin
+        let mut =
+          match ld1.ld_mutable, ld2.ld_mutable with
+          | Immutable, Immutable -> None
+          | Mutable _, Immutable -> Some First
+          | Immutable, Mutable _ -> Some Second
+          | Mutable m1, Mutable m2 ->
+            let open Mode.Alloc.Comonadic.Const in
+            (if not (eq m1 legacy) then
+              Misc.fatal_errorf "Unexpected mutable(%a)" print m1);
+            (if not (eq m2 legacy) then
+              Misc.fatal_errorf "Unexpected mutable(%a)" print m2);
+            None
+        in
+        begin match mut with
+        | Some mut -> Some (Mutability mut)
+        | None ->
           match compare_global_flags ld1.ld_global ld2.ld_global with
           | None ->
             let tl1 = params1 @ [ld1.ld_type] in

diff --git a/typing/mode.ml b/typing/mode.ml
@@ -1412,6 +1412,8 @@ end
 module Comonadic_with_locality = struct
   module Const = struct
     include C.Comonadic_with_locality
+
+    let eq a b = le a b && le b a
   end
 
   module Obj = struct

diff --git a/typing/mode_intf.mli b/typing/mode_intf.mli
@@ -331,11 +331,18 @@ module type S = sig
     end
 
     module Comonadic : sig
+      module Const : sig
+        include Lattice
+
+        val eq : t -> t -> bool
+      end
+
       include
         Common
           with type error =
             [ `Locality of Locality.error
             | `Linearity of Linearity.error ]
+           and module Const := Const
 
       val meet_with : Const.t -> ('l * 'r) t -> ('l * disallowed) t
     end
@@ -354,6 +361,8 @@ module type S = sig
 
       val split : t -> (Monadic.Const.t, Comonadic.Const.t) monadic_comonadic
 
+      val merge : (Monadic.Const.t, Comonadic.Const.t) monadic_comonadic -> t
+
       module Option : sig
         type some = t
 

diff --git a/typing/oprint.ml b/typing/oprint.ml
@@ -441,6 +441,10 @@ let is_initially_labeled_tuple ty =
   | Otyp_tuple ((Some _, _) :: _) -> true
   | _ -> false
 
+let string_of_gbl_space = function
+  | Ogf_global -> "global_ "
+  | Ogf_unrestricted -> ""
+
 let rec print_out_type_0 mode ppf =
   function
   | Otyp_alias {non_gen; aliased; alias } ->
@@ -626,15 +630,19 @@ and print_typargs ppf =
       pp_print_char ppf ')';
       pp_close_box ppf ();
       pp_print_space ppf ()
-and print_out_label ppf (name, mut_or_gbl, arg) =
+and print_out_label ppf (name, mut, arg, gbl) =
   (* See the notes [NON-LEGACY MODES] *)
-  let flag =
-    match mut_or_gbl with
-    | Ogom_mutable -> "mutable "
-    | Ogom_global -> "global_ "
-    | Ogom_immutable -> ""
+  let mut =
+    match mut with
+    | Om_immutable -> ""
+    | Om_mutable None -> "mutable "
+    | Om_mutable (Some s) -> "mutable(" ^ s ^ ") "
   in
-  fprintf ppf "@[<2>%s%s :@ %a@];" flag name print_out_type arg
+  fprintf ppf "@[<2>%s%s%s :@ %a@];"
+    mut
+    (string_of_gbl_space gbl)
+    name
+    print_out_type arg
 
 let out_label = ref print_out_label