flambda-backend: Improve mode checking related to allocation (#2366)

* remove mode_subcomponent

* refactor option_some

* improve Texp_record

* improve Texp_field

* improve Texp_field for unique analysis

* better story of field projection with boxing

* address comments

Author: riaqn

lambda/translcore.ml

@@ -539,7 +539,7 @@ and transl_exp0 ~in_new_scope ~scopes sort e =
       transl_record ~scopes e.exp_loc e.exp_env
         (Option.map transl_alloc_mode_r alloc_mode)
         fields representation extended_expression
-  | Texp_field(arg, id, lbl, _, alloc_mode) ->
+  | Texp_field(arg, id, lbl, float) ->
       let targ = transl_exp ~scopes Jkind.Sort.for_record arg in
       let sem =
         match lbl.lbl_mut with
@@ -554,7 +554,12 @@ and transl_exp0 ~in_new_scope ~scopes sort e =
                  of_location ~scopes e.exp_loc)
         | Record_unboxed | Record_inlined (_, Variant_unboxed) -> targ
         | Record_float ->
-          let mode = transl_alloc_mode_r (Option.get alloc_mode) in
+          let alloc_mode =
+            match float with
+            | Boxing (alloc_mode, _) -> alloc_mode
+            | Non_boxing _ -> assert false
+          in
+          let mode = transl_alloc_mode_r alloc_mode in
           Lprim (Pfloatfield (lbl.lbl_pos, sem, mode), [targ],
                  of_location ~scopes e.exp_loc)
         | Record_ufloat ->

testsuite/tests/typing-local/local.ml

@@ -2945,3 +2945,15 @@ let () = foo (local_ M_constructor)
 let () = foo_f (local_ (fun M_constructor -> ()))
 [%%expect{|
 |}]
+
+type r = {global_ x : string; y : string}
+
+let foo () =
+  let local_ y = "world" in
+  let local_ r = {x = "hello"; y} in
+  (* Only using r.x, which is global. So the whole return is global and OK. *)
+  {r with y = "foo!" }
+[%%expect{|
+type r = { global_ x : string; y : string; }
+val foo : unit -> r = <fun>
+|}]

testsuite/tests/typing-modal-kinds/basics.ml

@@ -181,6 +181,22 @@ Line 2, characters 45-46:
 Error: This value escapes its region
 |}]
 
+type r = {x : float; y : float}
+
+let foo () =
+  let local_ r = {x = 3.0; y = 4.0} in
+  (* [r.x] is allocated global and can escape. *)
+  r.x
+
+(* CR layouts v2.8: this should succeed *)
+[%%expect{|
+type r = { x : float; y : float; }
+Line 6, characters 2-5:
+6 |   r.x
+      ^^^
+Error: This value escapes its region
+|}]
+
 let function_escape = let local_ x : int -> int = fun y -> y in x
 
 [%%expect{|

testsuite/tests/typing-unique/unique_analysis.ml

@@ -781,3 +781,47 @@ Line 4, characters 20-21:
 
 |}]
 
+type r = {x : float; y : float}
+
+(* CR zqian: The following should pass but doesn't, because the uniqueness
+   analysis doesn't support mode crossing. The following involes sequencing the
+   maybe_unique usage of [r.x] and the maybe_unique usage of [r] as a whole.
+   Sequencing them will force both to be shared and many. The [unique_use] in
+   [r.x] is mode-crossed (being an unboxed float) so is fine. The [unique_use]
+   in [r] cannot cross mode, and forcing it causes error. *)
+
+let foo () =
+  let r = {x = 3.0; y = 5.0} in
+  let x = r.x in
+  ignore (unique_id r);
+  (* [x] is allocated fresh, unrelated to [r]. *)
+  ignore (unique_id x)
+[%%expect{|
+type r = { x : float; y : float; }
+Line 13, characters 20-21:
+13 |   ignore (unique_id r);
+                         ^
+Error: This value is used here,
+       but part of it has already been used as unique:
+Line 12, characters 10-13:
+12 |   let x = r.x in
+               ^^^
+
+|}]
+
+let foo () =
+  let r = {x = 3.0; y = 5.0} in
+  ignore (unique_id r);
+  (* but projection still uses [r]'s mem block, of course *)
+  let x = r.x in
+  ignore (unique_id x)
+[%%expect{|
+Line 5, characters 10-11:
+5 |   let x = r.x in
+              ^
+Error: This value is read from here, but it has already been used as unique:
+Line 3, characters 20-21:
+3 |   ignore (unique_id r);
+                        ^
+
+|}]

typing/printtyped.ml

@@ -467,9 +467,8 @@ and expression i ppf x =
       record_representation (i+1) ppf representation;
       line i ppf "extended_expression =\n";
       option (i+1) expression ppf extended_expression;
-  | Texp_field (e, li, _, _, am) ->
+  | Texp_field (e, li, _, _) ->
       line i ppf "Texp_field\n";
-      alloc_mode_option i ppf am;
       expression i ppf e;
       longident i ppf li;
   | Texp_setfield (e1, am, li, _, e2) ->

typing/rec_check.ml

@@ -720,7 +720,7 @@ let rec expression : Typedtree.expression -> term_judg =
       join [
         expression e1 << Dereference
       ]
-    | Texp_field (e, _, _, _, _) ->
+    | Texp_field (e, _, _, _) ->
       (*
         G |- e: m[Dereference]
         -----------------------

typing/tast_iterator.ml

@@ -329,7 +329,7 @@ let expr sub {exp_loc; exp_extra; exp_desc; exp_env; exp_attributes; _} =
         | _, Overridden (lid, exp) -> iter_loc sub lid; sub.expr sub exp)
         fields;
       Option.iter (sub.expr sub) extended_expression;
-  | Texp_field (exp, lid, _, _, _) ->
+  | Texp_field (exp, lid, _, _) ->
       iter_loc sub lid;
       sub.expr sub exp
   | Texp_setfield (exp1, _, lid, _, exp2) ->

typing/tast_mapper.ml

@@ -477,8 +477,8 @@ let expr sub x =
           extended_expression = Option.map (sub.expr sub) extended_expression;
           alloc_mode
         }
-    | Texp_field (exp, lid, ld, mode, am) ->
-        Texp_field (sub.expr sub exp, map_loc sub lid, ld, mode, am)
+    | Texp_field (exp, lid, ld, float) ->
+        Texp_field (sub.expr sub exp, map_loc sub lid, ld, float)
     | Texp_setfield (exp1, am, lid, ld, exp2) ->
         Texp_setfield (
           sub.expr sub exp1,

typing/typeclass.ml

@@ -1303,17 +1303,14 @@ and class_expr_aux cl_num val_env met_env virt self_scope scl =
                   let arg = Typecore.type_argument val_env sarg ty ty0 in
                   arg, Jkind.Sort.value
                 else
-                  let ty' = Typecore.extract_option_type val_env ty
-                  and ty0' = Typecore.extract_option_type val_env ty0 in
-                  let arg = Typecore.type_argument val_env sarg ty' ty0' in
-                  Typecore.option_some val_env arg Mode.Value.legacy,
+                  Typecore.type_option_some val_env sarg ty ty0,
                   (* CR layouts v5: Change the sort when options can hold
                      non-values. *)
                   Jkind.Sort.value
               )
             in
             let eliminate_optional_arg () =
-              Arg (Typecore.option_none val_env ty0 Location.none,
+              Arg (Typecore.type_option_none val_env ty0 Location.none,
                    (* CR layouts v5: Change the sort when options can hold
                       non-values. *)
                    Jkind.Sort.value