more fixes

ocaml/testsuite/tests/formatting/test_locations.dlocations.ocamlc.reference

@@ -88,7 +88,7 @@ let rec fib = function | 0 | 1 -> 1 | n -> (fib (n - 1)) + (fib (n - 2))
       <def_rec>
         pattern (test_locations.ml[17,534+8]..test_locations.ml[17,534+11])
           Tpat_var "fib"
-          value_mode global,many,nonportable,unique,uncontended
+          value_mode global,many,nonportable,join_shared,contended(1[shared,uncontended,unique,uncontended])
         expression (test_locations.ml[17,534+14]..test_locations.ml[19,572+34])
           Texp_function
           region true

ocaml/testsuite/tests/formatting/test_locations.dno-locations.ocamlc.reference

@@ -88,7 +88,7 @@ let rec fib = function | 0 | 1 -> 1 | n -> (fib (n - 1)) + (fib (n - 2))
       <def_rec>
         pattern 
           Tpat_var "fib"
-          value_mode global,many,nonportable,unique,uncontended
+          value_mode global,many,nonportable,join_shared,contended(1[shared,uncontended,unique,uncontended])
         expression 
           Texp_function
           region true

ocaml/testsuite/tests/typing-local/local.ml

@@ -902,7 +902,7 @@ module type T = sig val x : int option end
 Line 4, characters 50-51:
 4 |   let _m : (module T) = local_ (module struct let x = thing end) in
                                                       ^
-Error: This value escapes its region.
+Error: This value is local, but is expected to be global because it is inside a module.
 |}]
 let local_module () =
   let thing = local_ Some 1 in
@@ -914,7 +914,7 @@ let local_module () =
 Line 4, characters 30-31:
 4 |     let module M = struct let x = thing end in
                                   ^
-Error: This value escapes its region.
+Error: This value is local, but is expected to be global because it is inside a module.
 |}]
 let obj () =
   let thing = local_ Some 1 in
@@ -2150,10 +2150,10 @@ module M = struct
       | (None, None, z) = (Some (ref 0), (local_ (Some (ref 0))), (ref 0))
 end
 [%%expect{|
-Line 2, characters 35-36:
+Line 2, characters 12-13:
 2 |   let (Some z, _, _) | (None, Some z, _)
-                                       ^
-Error: This value escapes its region.
+                ^
+Error: This value is local, but is expected to be global because it is inside a module.
 |}]
 
 module M = struct
@@ -2164,7 +2164,7 @@ end
 Line 2, characters 12-13:
 2 |   let (Some z, _, _) | (None, Some z, _)
                 ^
-Error: This value escapes its region.
+Error: This value is local, but is expected to be global because it is inside a module.
 |}]
 
 (* Example of backtracking after mode error *)

ocaml/testsuite/tests/typing-modes/class.ml

@@ -107,7 +107,10 @@ let u =
     portable_use obj#m
 (* CR zqian: this should fail. *)
 [%%expect{|
-val u : unit = ()
+Line 3, characters 17-22:
+3 |     portable_use obj#m
+                     ^^^^^
+Error: This value is nonportable but expected to be portable.
 |}]
 
 (* for methods, arguments can be of any modes *)
@@ -137,7 +140,10 @@ let u =
     portable_use foo
 (* CR zqian: this should fail. *)
 [%%expect{|
-val u : unit = ()
+Line 3, characters 17-20:
+3 |     portable_use foo
+                     ^^^
+Error: This value is nonportable but expected to be portable.
 |}]
 
 module type SC = sig
@@ -164,5 +170,8 @@ let u =
     portable_use obj
 (* CR zqian: this should fail. *)
 [%%expect{|
-val u : unit = ()
+Line 3, characters 17-20:
+3 |     portable_use obj
+                     ^^^
+Error: This value is nonportable but expected to be portable.
 |}]

ocaml/testsuite/tests/typing-modes/module.ml

@@ -34,7 +34,10 @@ let u =
     portable_use foo
 (* CR zqian: This should fail *)
 [%%expect{|
-val u : unit = ()
+Line 6, characters 17-20:
+6 |     portable_use foo
+                     ^^^
+Error: This value is nonportable but expected to be portable.
 |}]
 
 let u =
@@ -49,7 +52,10 @@ let u =
     portable_use foo
 (* CR zqian: This should fail *)
 [%%expect{|
-val u : unit = ()
+Line 10, characters 17-20:
+10 |     portable_use foo
+                      ^^^
+Error: This value is nonportable but expected to be portable.
 |}]
 
 (* File-level modules are looked up differently and need to be tested
@@ -62,7 +68,10 @@ let u =
     portable_use foo
 (* CR zqian: this should fail *)
 [%%expect{|
-val u : unit = ()
+Line 6, characters 17-20:
+6 |     portable_use foo
+                     ^^^
+Error: This value is nonportable but expected to be portable.
 |}]
 
 (* Values in modules are defined as legacy *)
@@ -73,7 +82,7 @@ end
 Line 2, characters 8-9:
 2 |     let x = local_ "hello"
             ^
-Error: This value escapes its region.
+Error: This value is local, but is expected to be global because it is inside a module.
 |}]
 
 (* Values from modules are available as legacy *)
@@ -90,7 +99,10 @@ let u =
     portable_use foo
 (* CR zqian: this should fail *)
 [%%expect{|
-val u : unit = ()
+Line 3, characters 17-20:
+3 |     portable_use foo
+                     ^^^
+Error: This value is nonportable but expected to be portable.
 |}]
 
 let u =

ocaml/testsuite/tests/typing-modes/mutable.ml

@@ -34,7 +34,7 @@ let r @ portable =
 (* CR mode-crossing: The [m0] in mutable corresponds to the field type wrapped
    in modality; as a result, it enjoys mode crossing enabled by the modality. *)
 [%%expect{|
-type r = { f : string -> string; mutable g : string -> string; }
+type r = { f : string -> string; mutable g : string -> string @@ portable; }
 Lines 5-6, characters 2-20:
 5 | ..{ f = (fun x -> x);
 6 |     g = fun x -> x }

ocaml/testsuite/tests/typing-modes/val_modalities.ml

@@ -31,15 +31,11 @@ val portable_use : 'a @ portable -> unit = <fun>
 (* The compiler building itself is a comprehensive test of legacy modules/values.
    Below we test non-legacy values in modules. *)
 
-(* In the following, we see [contended] when there is no obvious constraint to
-   force it so. I believe this is because of optimise_allocations. In practice,
-   allocations being pushed to contended is useful information to middle-end: it
-   means this block will never be mutated. *)
 module M = struct
   let foo = {x = "hello"}
 end
 [%%expect{|
-module M : sig val foo : r @@ contended end
+module M : sig val foo : r end
 |}]
 
 module type S = sig
@@ -92,7 +88,7 @@ end
 Line 11, characters 25-29:
 11 |     let _ = portable_use M'.x
                               ^^^^
-Error: Found a nonportable value where a portable value was expected
+Error: This value is nonportable but expected to be portable.
 |}]
 
 module Module_type_of_monadic = struct
@@ -192,7 +188,7 @@ end
 Line 5, characters 26-29:
 5 |     let () = portable_use M.x
                               ^^^
-Error: Found a nonportable value where a portable value was expected
+Error: This value is nonportable but expected to be portable.
 |}]
 
 module Inclusion_fail = struct
@@ -231,7 +227,7 @@ end
 Line 7, characters 28-31:
 7 |     let _ = uncontended_use M.x
                                 ^^^
-Error: Found a contended value where a uncontended value was expected
+Error: This value is contended but expected to be uncontended.
 |}]
 
 module Inclusion_match = struct
@@ -256,10 +252,7 @@ module Close_over_value = struct
 end
 [%%expect{|
 module Close_over_value :
-  sig
-    module M : sig val x : string end
-    val foo : unit -> unit @@ contended
-  end
+  sig module M : sig val x : string end val foo : unit -> unit end
 |}]
 
 module Close_over_value = struct
@@ -274,7 +267,7 @@ end
 Line 3, characters 35-48:
 3 |     let r @ uncontended portable = {x = "hello"}
                                        ^^^^^^^^^^^^^
-Error: Found a nonportable value where a portable value was expected
+Error: This value is nonportable but expected to be portable.
 |}]
 
 module Close_over_value = struct

ocaml/testsuite/tests/typing-private/private.compilers.principal.reference

@@ -75,10 +75,7 @@ Line 3, characters 2-51:
 3 |   struct type t = int let f (x : int) = (x : t) end;; (* must fail *)
       ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
 Error: Signature mismatch:
-       Modules do not match:
-         sig type t = int val f : int -> t end
-       is not included in
-         sig type t = private Foobar.t val f : int -> t end
+       ...
        Type declarations do not match:
          type t = int
        is not included in

ocaml/testsuite/tests/typing-private/private.compilers.reference

@@ -75,10 +75,7 @@ Line 3, characters 2-51:
 3 |   struct type t = int let f (x : int) = (x : t) end;; (* must fail *)
       ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
 Error: Signature mismatch:
-       Modules do not match:
-         sig type t = int val f : int -> t end
-       is not included in
-         sig type t = private Foobar.t val f : int -> t end
+       ...
        Type declarations do not match:
          type t = int
        is not included in

ocaml/typing/mode.ml

@@ -2192,7 +2192,6 @@ module Modality = struct
       | Diff _ as t -> t
       | Undefined as t -> t
 
-
     type 'a axis = (Const.t, 'a) Axis.t
 
     type error =
@@ -2262,7 +2261,7 @@ module Modality = struct
            Atom (Monadic ax, Join_with (Axis.proj ax c))) ]
 
     let print : type d. _ -> d t -> unit =
-    fun ppf -> function
+     fun ppf -> function
       | Join_const c -> Format.fprintf ppf "join_const(%a)" Const.print c
       | Undefined -> Format.fprintf ppf "undefined"
       | Diff _ -> Format.fprintf ppf "diff"
@@ -2274,7 +2273,7 @@ module Modality = struct
          Suffices if [m <= join mm m'].
          Suffices if [m <= join mm.lower m'].
          or [subtract mm.lower m <= m'].
-          *)
+      *)
       let mc = Mode.Guts.get_floor mm in
       Mode.subtract mc m
 
@@ -2391,7 +2390,7 @@ module Modality = struct
            Atom (Comonadic ax, Meet_with (Axis.proj ax c))) ]
 
     let print : type d. _ -> d t -> unit =
-    fun ppf -> function
+     fun ppf -> function
       | Meet_const c -> Format.fprintf ppf "meet_const(%a)" Const.print c
       | Undefined -> Format.fprintf ppf "undefined"
       | Exactly _ -> Format.fprintf ppf "exactly"

ocaml/typing/mode_intf.mli

@@ -498,16 +498,18 @@ module type S = sig
       (** Apply a modality on a left mode. *)
       val apply_left : 'd t -> (allowed * 'r) Value.t -> Value.l
 
-      (** [cons m t] returns the modality that is [m] after [t]. *)
       (* CR zqian: call this [compose]. *)
+
+      (** [cons m t] returns the modality that is [m] after [t]. *)
       val cons : atom -> user -> user
 
       (** [singleton m] returns the modality containing only [m]. *)
       val singleton : atom -> user
 
+      (* CR zqian: return record, then we don't need [Exist.t]. *)
+
       (** Returns the list of [atom] in the given modality. The list is
           commutative. *)
-      (* CR zqian: return record, then we don't need [Exist.t]. *)
       val to_list : user -> atom list
 
       type error =
@@ -546,9 +548,10 @@ module type S = sig
       *)
       val zap_to_id : 'd t -> user
 
+      (* CR zqian: rename to [to_const_exn]. *)
+
       (** Returns a user modality by asserting the given modality is already
       user modality and returning it. *)
-      (* CR zqian: rename to [to_const_exn]. *)
       val zap_assert : 'd t -> user
 
       (** The top modality; [sub x max] succeeds for any [x]. *)

ocaml/typing/typecore.ml

@@ -610,8 +610,16 @@ let register_allocation (expected_mode : expected_mode) =
   alloc_mode, mode_default mode
 
 let optimise_allocations () =
+  (* CR zqian: Ideally we want to optimise all axes relavant to allocation. For
+  example, pushing an allocation to [contended] is useful to the middle-end.
+  However, a [contended] value in a module causes extra modality in printing.
+  Therefore, here we only optimise allocation for stack/heap. Proper solutions:
+  - Remove [Contention] axis from [Alloc].
+  - Add it back when middle-end can really utilize this information. *)
   List.iter
-    (fun mode -> ignore (Alloc.zap_to_ceil mode))
+    (fun mode ->
+      Locality.zap_to_ceil (Alloc.proj (Comonadic Areality) mode)
+      |> ignore)
     !allocations;
   reset_allocations ()