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>

Author: liam923

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