make mode system scale better with more axes (#2395)

* make mode constants scale

* make mode checking scale

* decompose axis access

* reuse existing representation of axis

* decompose monadic vs. comonadic

Author: riaqn

ocaml/lambda/translmode.ml

@@ -29,11 +29,11 @@ let transl_locality_mode_r locality =
 
 let transl_alloc_mode_l mode =
   (* we only take the locality axis *)
-  Alloc.locality mode |> transl_locality_mode_l
+  Alloc.proj (Comonadic Areality) mode |> transl_locality_mode_l
 
 let transl_alloc_mode_r mode =
   (* we only take the locality axis *)
-  Alloc.locality mode |> transl_locality_mode_r
+  Alloc.proj (Comonadic Areality) mode |> transl_locality_mode_r
 
 let transl_modify_mode locality =
   match Locality.zap_to_floor locality with

ocaml/typing/ctype.ml

@@ -1583,9 +1583,9 @@ let prim_mode mvar = function
     put in [mode.ml] *)
 let with_locality locality m =
   let m' = Alloc.newvar () in
-  Locality.equate_exn (Alloc.locality m') locality;
-  Alloc.submode_exn m' (Alloc.join_with_locality Locality.Const.max m);
-  Alloc.submode_exn (Alloc.meet_with_locality Locality.Const.min m) m';
+  Locality.equate_exn (Alloc.proj (Comonadic Areality) m') locality;
+  Alloc.submode_exn m' (Alloc.join_with (Comonadic Areality) Locality.Const.max m);
+  Alloc.submode_exn (Alloc.meet_with (Comonadic Areality) Locality.Const.min m) m';
   m'
 
 let rec instance_prim_locals locals mvar macc finalret ty =
@@ -5578,7 +5578,7 @@ let mode_cross_left env ty mode =
      now; will return and figure this out later. *)
   let jkind = type_jkind_purely env ty in
   let upper_bounds = Jkind.get_modal_upper_bounds jkind in
-  Alloc.meet_with upper_bounds mode
+  Alloc.meet_const upper_bounds mode
 
 (* CR layouts v2.8: merge with Typecore.expect_mode_cross when [Value]
    and [Alloc] get unified *)

ocaml/typing/env.ml

@@ -2958,7 +2958,7 @@ let lookup_ident_module (type a) (load : a load) ~errors ~use ~loc s env =
 let escape_mode ~errors ~env ~loc id vmode escaping_context =
   match
   Mode.Regionality.submode
-    (Mode.Value.regionality vmode)
+    (Mode.Value.proj (Comonadic Areality) vmode)
     (Mode.Regionality.global)
   with
   | Ok () -> ()
@@ -2969,13 +2969,13 @@ let escape_mode ~errors ~env ~loc id vmode escaping_context =
 let share_mode ~errors ~env ~loc id vmode shared_context =
   match
     Mode.Linearity.submode
-      (Mode.Value.linearity vmode)
+      (Mode.Value.proj (Comonadic Linearity) vmode)
       Mode.Linearity.many
   with
   | Error _ ->
       may_lookup_error errors loc env
         (Once_value_used_in (id, shared_context))
-  | Ok () -> Mode.Value.join [Mode.Value.min_with_uniqueness Mode.Uniqueness.shared; vmode]
+  | Ok () -> Mode.Value.join [Mode.Value.min_with (Monadic Uniqueness) Mode.Uniqueness.shared; vmode]
 
 let closure_mode ~errors ~env ~loc id {Mode.monadic; comonadic}
   closure_context comonadic0 : Mode.Value.l =
@@ -2998,7 +2998,7 @@ let closure_mode ~errors ~env ~loc id {Mode.monadic; comonadic}
 let exclave_mode ~errors ~env ~loc id vmode =
   match
   Mode.Regionality.submode
-    (Mode.Value.regionality vmode)
+    (Mode.Value.proj (Comonadic Areality) vmode)
     Mode.Regionality.regional
 with
 | Ok () -> vmode |> Mode.value_to_alloc_r2l |> Mode.alloc_as_value
@@ -3962,15 +3962,15 @@ let report_lookup_error _loc env ppf = function
   | Value_used_in_closure (lid, error, context) ->
       let e0, e1 =
         match error with
-        | `Regionality _ -> "local", "might escape"
-        | `Linearity _ -> "once", "is many"
+        | Error (Areality, _) -> "local", "might escape"
+        | Error (Linearity, _) -> "once", "is many"
       in
       fprintf ppf
       "@[The value %a is %s, so cannot be used \
             inside a closure that %s.@]"
       !print_longident lid e0 e1;
       begin match error, context with
-      | `Regionality _, Some Tailcall_argument ->
+      | Error (Areality, _), Some Tailcall_argument ->
          fprintf ppf "@.@[Hint: The closure might escape because it \
                           is an argument to a tail call@]"
       | _ -> ()