flambda-backend: Support for mod syntax - unclean (#2717)

* Apply changes from PR 2676 as on 6/21/24

* Fix printing of unrepresentable jkinds

* Resolve memoization issue in jkind.ml

* Fix memoization in subst

* Add crs for bad error messages

* Mode crossing tests

* Add more tests for soundness checks

* Add more inference tests

* Add tests for intersection behavior

* Add test for modality annotations

* Add gadt tests

* Add tests for objects

* Test externality axis interaction with mixed blocks

* Add test for mutable record field

* Fix memoization in sort

* Hoist builtins in subst

* Update incorrect CRs

* Some tweaks in jkind tests during review

---------

Co-authored-by: Richard Eisenberg <reisenberg@janestreet.com>

debugger/loadprinter.ml

@@ -93,7 +93,7 @@ let eval_value_path env path =
 
 let match_printer_type desc make_printer_type =
   Ctype.with_local_level ~post:Ctype.generalize begin fun () ->
-    let ty_arg = Ctype.newvar Jkind.(value ~why:Debug_printer_argument) in
+    let ty_arg = Ctype.newvar (Jkind.Primitive.value ~why:Debug_printer_argument) in
     Ctype.unify (Lazy.force Env.initial)
       (make_printer_type ty_arg)
       (Ctype.instance desc.val_type);

debugger4/loadprinter.ml

@@ -93,7 +93,7 @@ let eval_value_path env path =
 
 let match_printer_type desc make_printer_type =
   Ctype.with_local_level ~post:Ctype.generalize begin fun () ->
-    let ty_arg = Ctype.newvar Jkind.(value ~why:Debug_printer_argument) in
+    let ty_arg = Ctype.newvar Jkind.Primitive.(value ~why:Debug_printer_argument) in
     Ctype.unify (Lazy.force Env.initial)
       (make_printer_type ty_arg)
       (Ctype.instance desc.val_type);

lambda/matching.ml

@@ -106,8 +106,10 @@ exception Error of Location.t * error
 let dbg = false
 
 let jkind_layout_default_to_value_and_check_not_void loc jkind =
-  match Jkind.get_default_value jkind with
-  | Void -> raise (Error (loc, Void_layout))
+  let const = Jkind.default_to_value_and_get jkind in
+  let layout = Jkind.Const.get_layout const in
+  match layout with
+  | Sort Void -> raise (Error (loc, Void_layout))
   | _ -> ()
 ;;
 

lambda/translcore.ml

@@ -54,7 +54,7 @@ let layout_exp sort e = layout e.exp_env e.exp_loc sort e.exp_type
 let layout_pat sort p = layout p.pat_env p.pat_loc sort p.pat_type
 
 let check_record_field_sort loc sort =
-  match Jkind.Sort.get_default_value sort with
+  match Jkind.Sort.default_to_value_and_get sort with
   | Value | Float64 | Float32 | Bits32 | Bits64 | Word -> ()
   | Void -> raise (Error (loc, Illegal_void_record_field))
 
@@ -1022,7 +1022,7 @@ and transl_exp0 ~in_new_scope ~scopes sort e =
             match
               Ctype.check_type_jkind
                 e.exp_env (Ctype.correct_levels val_type)
-                (Jkind.value ~why:Probe)
+                (Jkind.Primitive.value ~why:Probe)
             with
             | Ok _ -> ()
             | Error _ -> raise (Error (e.exp_loc, Bad_probe_layout id))

lambda/translmod.ml

@@ -300,7 +300,7 @@ let init_shape id modl =
             Tarrow(_,ty_arg,_,_) -> begin
               (* CR layouts: We should allow any representable layout here. It
                  will require reworking [camlinternalMod.init_mod]. *)
-              let jkind = Jkind.value ~why:Recmod_fun_arg in
+              let jkind = Jkind.Primitive.value ~why:Recmod_fun_arg in
               let ty_arg = Ctype.correct_levels ty_arg in
               match Ctype.check_type_jkind env ty_arg jkind with
               | Ok _ -> const_int 0 (* camlinternalMod.Function *)

lambda/translprim.ml

@@ -143,7 +143,7 @@ let to_modify_mode ~poly = function
 let extern_repr_of_native_repr:
   poly_sort:Jkind.Sort.t option -> Primitive.native_repr -> Lambda.extern_repr
   = fun ~poly_sort r -> match r, poly_sort with
-  | Repr_poly, Some s -> Same_as_ocaml_repr (Jkind.Sort.get_default_value s)
+  | Repr_poly, Some s -> Same_as_ocaml_repr (Jkind.Sort.default_to_value_and_get s)
   | Repr_poly, None -> Misc.fatal_error "Unexpected Repr_poly"
   | Same_as_ocaml_repr s, _ -> Same_as_ocaml_repr s
   | Unboxed_float f, _ -> Unboxed_float f

ocamldoc/odoc_sig.ml

@@ -493,7 +493,7 @@ module Analyser =
           { Typedtree.ld_id; ld_mutable; ld_type; ld_loc; ld_attributes } =
         get_field env comments @@
         {Types.ld_id; ld_mutable; ld_modalities = Mode.Modality.Value.id;
-         ld_jkind=Jkind.any ~why:Dummy_jkind (* ignored *);
+         ld_jkind=Jkind.Primitive.any ~why:Dummy_jkind (* ignored *);
          ld_type=ld_type.Typedtree.ctyp_type;
          ld_loc; ld_attributes; ld_uid=Types.Uid.internal_not_actually_unique} in
       let open Typedtree in

parsing/ast_iterator.ml

@@ -1005,7 +1005,7 @@ let default_iterator =
     jkind_annotation =
       (fun this -> function
         | Default -> ()
-        | Primitive_layout_or_abbreviation s ->
+        | Abbreviation s ->
           iter_loc this (s : Jane_syntax.Jkind.Const.t :> _ loc)
         | Mod (t, mode_list) ->
           this.jkind_annotation this t;

parsing/ast_mapper.ml

@@ -1130,11 +1130,11 @@ let default_mapper =
       let open Jane_syntax in
       function
       | Default -> Default
-      | Primitive_layout_or_abbreviation s ->
+      | Abbreviation s ->
         let {txt; loc} =
           map_loc this (s : Jkind.Const.t :> _ loc)
         in
-        Primitive_layout_or_abbreviation (Jkind.Const.mk txt loc)
+        Abbreviation (Jkind.Const.mk txt loc)
       | Mod (t, mode_list) ->
         Mod (this.jkind_annotation this t, this.modes this mode_list)
       | With (t, ty) ->

parsing/jane_syntax.ml

@@ -514,7 +514,7 @@ module Jkind = struct
 
   type t =
     | Default
-    | Primitive_layout_or_abbreviation of Const.t
+    | Abbreviation of Const.t
     | Mod of t * Mode_expr.t
     | With of t * core_type
     | Kind_of of core_type
@@ -571,8 +571,8 @@ module Jkind = struct
     let to_structure_item t = to_structure_item (Location.mknoloc t) in
     match t_loc.txt with
     | Default -> struct_item_of_list "default" [] t_loc.loc
-    | Primitive_layout_or_abbreviation c ->
-      struct_item_of_list "prim" [Const.to_structure_item c] t_loc.loc
+    | Abbreviation c ->
+      struct_item_of_list "abbrev" [Const.to_structure_item c] t_loc.loc
     | Mod (t, mode_list) ->
       let mode_list_item =
         struct_item_of_attr
@@ -607,9 +607,8 @@ module Jkind = struct
               ret loc (With (t, ty))))
     | Some ("kind_of", [item_of_ty], loc) ->
       bind (struct_item_to_type item_of_ty) (fun ty -> ret loc (Kind_of ty))
-    | Some ("prim", [item], loc) ->
-      bind (Const.of_structure_item item) (fun c ->
-          ret loc (Primitive_layout_or_abbreviation c))
+    | Some ("abbrev", [item], loc) ->
+      bind (Const.of_structure_item item) (fun c -> ret loc (Abbreviation c))
     | Some _ | None -> None
 end
 

parsing/jane_syntax.mli

@@ -199,7 +199,7 @@ module Jkind : sig
 
   type t =
     | Default
-    | Primitive_layout_or_abbreviation of Const.t
+    | Abbreviation of Const.t
     | Mod of t * Mode_expr.t
     | With of t * Parsetree.core_type
     | Kind_of of Parsetree.core_type

parsing/parser.mly

@@ -3879,8 +3879,7 @@ jkind:
     }
   | mkrhs(ident) {
       let {txt; loc} = $1 in
-      Jane_syntax.Jkind.(Primitive_layout_or_abbreviation
-        (Const.mk txt loc))
+      Jane_syntax.Jkind.(Abbreviation (Const.mk txt loc))
     }
   | KIND_OF ty=core_type {
       Jane_syntax.Jkind.Kind_of ty

parsing/pprintast.ml

@@ -377,7 +377,7 @@ and type_with_label ctxt f (label, c) =
 
 and jkind ctxt f k = match (k : Jane_syntax.Jkind.t) with
   | Default -> pp f "_"
-  | Primitive_layout_or_abbreviation s ->
+  | Abbreviation s ->
     pp f "%s" (s : Jane_syntax.Jkind.Const.t :> _ loc).txt
   | Mod (t, { txt = mode_list }) ->
     begin match mode_list with

parsing/pprintast.mli

@@ -59,3 +59,4 @@ val tyvar: Format.formatter -> string -> unit
       position, or for keywords by escaping them with \#. No-op on "_". *)
 
 val jkind : Format.formatter -> Jane_syntax.Jkind.t -> unit
+val mode : Format.formatter -> Jane_syntax.Mode_expr.Const.t -> unit

testsuite/tests/language-extensions/pprintast_unconditional.ml

@@ -120,10 +120,12 @@ module Example = struct
   let tyvar            = "no_tyvars_require_extensions"
   let jkind            = Jane_syntax.Jkind.(
                             With (
-                              Primitive_layout_or_abbreviation
+                              Abbreviation
                                 (Const.mk "value" loc),
                               core_type
                             ))
+
+  let mode = Jane_syntax.Mode_expr.Const.mk "global" loc
 end
 
 let print_test_header name =
@@ -205,6 +207,7 @@ end = struct
 
   let tyvar = test "tyvar" tyvar Example.tyvar
   let jkind = test "jkind" jkind Example.jkind
+  let mode = test "mode" mode Example.mode
 end
 
 

testsuite/tests/language-extensions/pprintast_unconditional.reference

@@ -95,6 +95,8 @@ tyvar: 'no_tyvars_require_extensions
 
 jkind: value with local_ ('a : value) -> unit
 
+mode: global
+
 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
 
 ##### Extensions disallowed
@@ -194,6 +196,8 @@ tyvar: 'no_tyvars_require_extensions
 
 jkind: value with local_ ('a : value) -> unit
 
+mode: global
+
 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
 
 ##### Calling [Language_extension.For_pprintast.make_printer_exporter ()]

testsuite/tests/typing-layouts-arrays/basics.ml

@@ -274,6 +274,8 @@ module M6_2 = struct
   let f2 idx : int32# = get arr idx
 end
 
+(* CR layouts v2.8: The jkind in the error message is wrong. It should really be
+   ('a : layout float64) *)
 [%%expect{|
 Line 9, characters 24-35:
 9 |   let f2 idx : int32# = get arr idx