final clean up, I promise

Author: riaqn

ocaml/lambda/translmode.mli

@@ -1,6 +1,7 @@
-val transl_locality_mode_l : (Mode.allowed * 'r) Mode.Locality.t -> Lambda.locality_mode
+open Mode
+val transl_locality_mode_l : (allowed * 'r) Locality.t -> Lambda.locality_mode
 
-val transl_alloc_mode_l : (Mode.allowed * 'r) Mode.Alloc.t -> Lambda.alloc_mode
-val transl_alloc_mode_r : ('l * Mode.allowed) Mode.Alloc.t -> Lambda.alloc_mode
+val transl_alloc_mode_l : (allowed * 'r) Alloc.t -> Lambda.alloc_mode
+val transl_alloc_mode_r : ('l * allowed) Alloc.t -> Lambda.alloc_mode
 
-val transl_modify_mode : (Mode.allowed * 'r) Mode.Locality.t -> Lambda.modify_mode
+val transl_modify_mode : (allowed * 'r) Locality.t -> Lambda.modify_mode

ocaml/typing/includecore.ml

@@ -125,7 +125,7 @@ let value_descriptions ~loc env name
          with Ctype.Moregen err -> raise (Dont_match (Type err)));
         let pc =
           {pc_desc = p1; pc_type = vd2.Types.val_type;
-          pc_poly_mode = Option.map Mode.Locality.disallow_right mode1;
+           pc_poly_mode = Option.map Mode.Locality.disallow_right mode1;
            pc_env = env; pc_loc = vd1.Types.val_loc; } in
         Tcoerce_primitive pc
      end

ocaml/typing/printtyped.ml

@@ -212,17 +212,6 @@ let attributes i ppf l =
 let layout_annotation i ppf layout =
   line i ppf "%s" (Layouts.Layout.string_of_const layout)
 
-let alloc_mode i ppf m =
-  line i ppf "alloc_mode %a\n" (Mode.Alloc.print ()) m
-
-let alloc_mode_option i ppf m = Option.iter (alloc_mode i ppf) m
-
-let locality_mode i ppf m =
-  line i ppf "locality_mode %a\n" (Mode.Locality.print ()) m
-
-let value_mode i ppf m =
-  line i ppf "value_mode %a\n" (Mode.Value.print ()) m
-
 let rec core_type i ppf x =
   line i ppf "core_type %a\n" fmt_location x.ctyp_loc;
   attributes i ppf x.ctyp_attributes;
@@ -368,6 +357,18 @@ and expression_extra i ppf (x,_,attrs) =
       line i ppf "Texp_newtype %a\n" (typevar_layout ~print_quote:false) (s, lay);
       attributes i ppf attrs;
 
+and alloc_mode i ppf m =
+  line i ppf "alloc_mode %a\n" (Mode.Alloc.print ()) m
+
+and alloc_mode_option i ppf m = Option.iter (alloc_mode i ppf) m
+
+and locality_mode i ppf m =
+  line i ppf "locality_mode %a\n"
+    (Mode.Locality.print ()) m
+
+and value_mode i ppf m =
+  line i ppf "value_mode %a\n" (Mode.Value.print ()) m
+
 and expression_alloc_mode i ppf (expr, am) =
   alloc_mode i ppf am;
   expression i ppf expr

ocaml/typing/typecore.ml

@@ -20,10 +20,10 @@ open Asttypes
 open Parsetree
 open Layouts
 open Types
+open Mode
 open Typedtree
 open Btype
 open Ctype
-open Mode
 open Uniqueness_analysis
 
 type comprehension_type =
@@ -422,7 +422,6 @@ let _modality_box_right global_flag mode =
       |> le_many_right
   | Unrestricted -> mode
 
-
 (* Describes how a modality affects field projection. Returns the mode
    of the projection given the mode of the record. *)
 let modality_unbox_left global_flag mode =
@@ -456,7 +455,6 @@ let mode_default mode =
 
 let mode_legacy = mode_default Value.legacy
 
-
 (* used when entering a function;
 mode is the mode of the function region *)
 let mode_return mode =
@@ -473,10 +471,11 @@ let mode_region mode =
     closure_context = None;
   }
 
-let mode_max = mode_default Value.max
+let mode_max =
+  mode_default Value.max
 
 let mode_max_with_position position =
-  {mode_max with position}
+  { mode_max with position }
 
 let mode_subcomponent expected_mode =
   let mode = alloc_as_value (value_to_alloc_r2g expected_mode.mode) in
@@ -505,10 +504,11 @@ let mode_strictly_local expected_mode =
 
 let mode_unique expected_mode =
   let mode = le_unique_right expected_mode.mode in
-  {expected_mode with mode}
+  { expected_mode with mode }
 
 let mode_once expected_mode =
-  {expected_mode with mode = Value.set_linearity_max expected_mode.mode}
+  { expected_mode with
+    mode = Value.set_linearity_max expected_mode.mode}
 
 let mode_tailcall_function mode =
   { (mode_default mode) with
@@ -521,8 +521,8 @@ let mode_tailcall_argument mode =
 
 let mode_partial_application expected_mode =
   let mode = alloc_as_value (value_to_alloc_r2g expected_mode.mode) in
-  { expected_mode
-    with mode;
+  { expected_mode with
+    mode;
     closure_context = Some Partial_application }
 
 
@@ -780,7 +780,7 @@ let mode_cross_to_min env ty mode =
 
 let expect_mode_cross env ty (expected_mode : expected_mode) =
   if mode_cross env ty then
-  { expected_mode with
+    { expected_mode with
       mode = Value.disallow_left Value.max;
       exact = None;
       strictly_local = false }
@@ -4486,9 +4486,9 @@ let unique_use ~loc ~env mode_l mode_r  =
   let uniqueness = Uniqueness.disallow_left (Value.uniqueness mode_r) in
   let linearity = Linearity.disallow_right (Value.linearity mode_l) in
   if not (Language_extension.is_enabled Unique) then begin
-      (* if unique extension is not enabled, we will not run uniqueness analysis ;
-      instead, we force all uses to be shared and many. This is equivalent to
-      running a UA which forces everything *)
+    (* if unique extension is not enabled, we will not run uniqueness analysis;
+       instead, we force all uses to be shared and many. This is equivalent to
+       running a UA which forces everything *)
     (match Uniqueness.submode Uniqueness.shared uniqueness with
     | Ok () -> ()
     | Error () ->
@@ -5292,7 +5292,6 @@ and type_expect_
         else record.exp_type
       in
       let (label_loc, label, newval) =
-        (* rmode won't be used because mutable field *)
         type_label_exp false env (mode_default rmode) loc
           ty_record (lid, label, snewval) in
       unify_exp env record ty_record;
@@ -6115,10 +6114,11 @@ and type_ident env ?(recarg=Rejected) lid =
        let ty, mode = instance_prim_mode prim (instance desc.val_type) in
        begin match prim.prim_native_repr_res, mode with
        (* if the locality of returned value of the primitive is poly
-        we then register allocation for further optimization *)
-       | (Prim_poly, _), Some mode -> register_allocation_mode
-       (* TODO: fix this dirty hack *)
-          (Alloc.meet [Alloc.max_with_locality mode; Alloc.max_with_linearity Linearity.many])
+          we then register allocation for further optimization *)
+       | (Prim_poly, _), Some mode ->
+           register_allocation_mode
+             (Alloc.meet [Alloc.max_with_locality mode;
+                          Alloc.max_with_linearity Linearity.many])
        | _ -> ()
        end;
        ty, Id_prim (Option.map Locality.disallow_right mode)
@@ -6311,7 +6311,6 @@ and type_function
     exp_desc =
       Texp_function
         { arg_label; param; cases; partial; region; curry; warnings;
-
           arg_mode = Alloc.disallow_right arg_mode; arg_sort;
           alloc_mode = Alloc.disallow_left alloc_mode; ret_sort };
     exp_loc = loc; exp_extra = [];
@@ -8441,7 +8440,9 @@ let escaping_hint failure_reason submode_reason
       let rec loop sureness n ty =
         match get_desc ty with
         | Tarrow ((_, _, res_mode), _, res_ty, _) ->
-          begin match Locality.check_const (Alloc.locality res_mode) with
+          begin match
+            Locality.check_const (Alloc.locality res_mode)
+          with
           | Some Global ->
             Some (n+1, true)
           | (None | Some Local) as res_mode ->
@@ -8945,19 +8946,19 @@ let report_error ~loc env = function
         Printtyp.type_expr ty
   | Submode_failed(fail_reason, submode_reason, closure_context, shared_context)
      ->
-    let sub =
-      match fail_reason with
-      | `Linearity | `Uniqueness ->
+      let sub =
+        match fail_reason with
+        | `Linearity | `Uniqueness ->
           sharedness_hint fail_reason submode_reason shared_context
-      | `Regionality ->
+        | `Regionality ->
           escaping_hint fail_reason submode_reason closure_context
-    in
-    Location.errorf ~loc ~sub begin
-      match fail_reason with
-      | `Regionality -> "This value escapes its region"
-      | `Uniqueness -> "Found a shared value where a unique value was expected"
-      | `Linearity -> "Found a once value where a many value was expected"
-      end
+      in
+      Location.errorf ~loc ~sub begin
+        match fail_reason with
+        | `Regionality -> "This value escapes its region"
+        | `Uniqueness -> "Found a shared value where a unique value was expected"
+        | `Linearity -> "Found a once value where a many value was expected"
+        end
   | Local_application_complete (lbl, loc_kind) ->
       let sub =
         match loc_kind with

ocaml/typing/types.ml

@@ -43,7 +43,8 @@ and type_desc =
   | Tpoly of type_expr * type_expr list
   | Tpackage of Path.t * (Longident.t * type_expr) list
 
-and arrow_desc = arg_label * Mode.Alloc.lr * Mode.Alloc.lr
+and arrow_desc =
+  arg_label * Mode.Alloc.lr * Mode.Alloc.lr
 
 and row_desc =
     { row_fields: (label * row_field) list;
@@ -607,7 +608,7 @@ type change =
   | Ckind : [`var] field_kind_gen -> change
   | Ccommu : [`var] commutable_gen -> change
   | Cuniv : type_expr option ref * type_expr option -> change
-  | Cmode : Solver.changes -> change
+  | Cmodes : Solver.changes -> change
 
 type changes =
     Change of change * changes ref
@@ -621,6 +622,8 @@ let log_change ch =
   !trail := Change (ch, r');
   trail := r'
 
+let () =
+  Solver.append_changes := (fun changes -> log_change (Cmodes !changes))
 
 (* constructor and accessors for [field_kind] *)
 
@@ -869,7 +872,7 @@ let undo_change = function
   | Ckind  (FKvar r) -> r.field_kind <- FKprivate
   | Ccommu (Cvar r)  -> r.commu <- Cunknown
   | Cuniv  (r, v)    -> r := v
-  | Cmode c          -> Solver.undo_changes c
+  | Cmodes c          -> Solver.undo_changes c
 
 type snapshot = changes ref * int
 let last_snapshot = Local_store.s_ref 0
@@ -1028,5 +1031,4 @@ let undo_compress (changes, _old) =
         | _ -> ())
         log
 
-let () =
-  Solver.append_changes := fun changes -> log_change (Cmode !changes)
+

ocaml/typing/types.mli

@@ -136,7 +136,8 @@ and type_desc =
   | Tpackage of Path.t * (Longident.t * type_expr) list
   (** Type of a first-class module (a.k.a package). *)
 
-and arrow_desc = arg_label * Mode.Alloc.lr * Mode.Alloc.lr
+and arrow_desc =
+  arg_label * Mode.Alloc.lr * Mode.Alloc.lr
 
 
 

ocaml/typing/typetexp.ml

@@ -585,12 +585,15 @@ and transl_type_aux env policy mode styp =
         | (l, arg_mode, arg) :: rest ->
           check_arg_type arg;
           let arg_cty = transl_type env policy arg_mode arg in
-          let (loc, lin, _) =
+          let acc_mode =
             Alloc.Const.join
               (Alloc.Const.close_over arg_mode)
               (Alloc.Const.partial_apply acc_mode)
           in
-          let acc_mode = (loc, lin, Uniqueness.Const.Shared) in
+          let acc_mode =
+            Alloc.Const.join acc_mode
+              (Alloc.Const.min_with_uniqueness Uniqueness.Const.Shared)
+          in
           let ret_mode =
             match rest with
             | [] -> ret_mode