Using const sorts

lambda/matching.ml

@@ -104,17 +104,15 @@ exception Error of Location.t * error
 
 let dbg = false
 
-let jkind_layout_default_to_value_and_check_not_void loc jkind =
-  let rec contains_void : Jkind.Layout.Const.t -> bool = function
-    | Any -> false
+let sort_check_not_void loc sort =
+  let rec contains_void : Jkind.Sort.Const.t -> bool = function
     | Base Void -> true
     | Base (Value | Float64 | Float32 | Word | Bits32 | Bits64 | Vec128) -> false
     | Product [] ->
-      Misc.fatal_error "nil in jkind_layout_default_to_value_and_check_not_void"
-    | Product ts -> List.exists contains_void ts
+      Misc.fatal_error "nil in sort_check_not_void"
+    | Product ss -> List.exists contains_void ss
   in
-  let layout = Jkind.get_layout_defaulting_to_value jkind in
-  if contains_void layout then
+  if contains_void sort then
     raise (Error (loc, Void_layout))
 ;;
 
@@ -1877,9 +1875,7 @@ let get_pat_args_constr p rem =
   match p with
   | { pat_desc = Tpat_construct (_, {cstr_args}, args, _) } ->
     List.iter2
-      (fun { ca_jkind } arg ->
-         jkind_layout_default_to_value_and_check_not_void
-           arg.pat_loc ca_jkind)
+      (fun { ca_sort } arg -> sort_check_not_void arg.pat_loc ca_sort)
       cstr_args args;
       (* CR layouts v5: This sanity check will have to go (or be replaced with a
          void-specific check) when we have other non-value sorts *)
@@ -1895,12 +1891,11 @@ let get_expr_args_constr ~scopes head (arg, _mut, sort, layout) rem =
   let loc = head_loc ~scopes head in
   (* CR layouts v5: This sanity check should be removed or changed to
      specifically check for void when we add other non-value sorts. *)
-  List.iter (fun { ca_jkind } ->
-      jkind_layout_default_to_value_and_check_not_void head.pat_loc ca_jkind)
+  List.iter (fun { ca_sort } -> sort_check_not_void head.pat_loc ca_sort)
     cstr.cstr_args;
   let ubr = Translmode.transl_unique_barrier (head.pat_unique_barrier) in
   let sem = add_barrier_to_read ubr Reads_agree in
-  let make_field_access binding_kind jkind ~field ~pos =
+  let make_field_access binding_kind sort ~field ~pos =
     let prim =
       match cstr.cstr_shape with
       | Constructor_uniform_value -> Pfield (pos, Pointer, sem)
@@ -1922,7 +1917,7 @@ let get_expr_args_constr ~scopes head (arg, _mut, sort, layout) rem =
           let shape = Lambda.transl_mixed_product_shape shape in
           Pmixedfield (pos, read, shape, sem)
     in
-    let sort = Jkind.sort_of_jkind jkind in
+    let sort = Jkind.Sort.of_const sort in
     let layout = Typeopt.layout_of_sort head.pat_loc sort in
     (Lprim (prim, [ arg ], loc), binding_kind, sort, layout)
   in
@@ -1933,15 +1928,15 @@ let get_expr_args_constr ~scopes head (arg, _mut, sort, layout) rem =
     match cstr.cstr_repr with
     | Variant_boxed _ ->
         List.mapi
-          (fun i { ca_jkind } ->
-             make_field_access str ca_jkind ~field:i ~pos:i)
+          (fun i { ca_sort } ->
+             make_field_access str ca_sort ~field:i ~pos:i)
           cstr.cstr_args
         @ rem
     | Variant_unboxed -> (arg, str, sort, layout) :: rem
     | Variant_extensible ->
         List.mapi
-          (fun i { ca_jkind } ->
-             make_field_access str ca_jkind ~field:i ~pos:(i+1))
+          (fun i { ca_sort } ->
+             make_field_access str ca_sort ~field:i ~pos:(i+1))
           cstr.cstr_args
         @ rem
 
@@ -2262,7 +2257,7 @@ let record_matching_line num_fields lbl_pat_list =
   List.iter (fun (_, lbl, pat) ->
     (* CR layouts v5: This void sanity check can be removed when we add proper
        void support (or whenever we remove `lbl_pos_void`) *)
-    jkind_layout_default_to_value_and_check_not_void pat.pat_loc lbl.lbl_jkind;
+    sort_check_not_void pat.pat_loc lbl.lbl_sort;
     patv.(lbl.lbl_pos) <- pat)
     lbl_pat_list;
   Array.to_list patv
@@ -2289,10 +2284,9 @@ let get_expr_args_record ~scopes head (arg, _mut, sort, layout) rem =
       rem
     else
       let lbl = all_labels.(pos) in
-      jkind_layout_default_to_value_and_check_not_void
-        head.pat_loc lbl.lbl_jkind;
+      sort_check_not_void head.pat_loc lbl.lbl_sort;
       let ptr = Typeopt.maybe_pointer_type head.pat_env lbl.lbl_arg in
-      let lbl_sort = Jkind.sort_of_jkind lbl.lbl_jkind in
+      let lbl_sort = Jkind.Sort.of_const lbl.lbl_sort in
       let lbl_layout = Typeopt.layout_of_sort lbl.lbl_loc lbl_sort in
       let sem =
         if Types.is_mutable lbl.lbl_mut then Reads_vary else Reads_agree

lambda/translcore.ml

@@ -54,8 +54,7 @@ let sort_must_not_be_void loc ty sort =
 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.default_to_value_and_get sort with
+let check_record_field_sort loc : Jkind.Sort.Const.t -> _ = function
   | Base (Value | Float64 | Float32 | Bits32 | Bits64 | Vec128 | Word) -> ()
   | Base Void -> raise (Error (loc, Illegal_void_record_field))
   | Product _ as c -> raise (Error (loc, Illegal_product_record_field c))
@@ -520,13 +519,11 @@ and transl_exp0 ~in_new_scope ~scopes sort e =
             of_location ~scopes e.exp_loc)
   | Texp_construct(_, cstr, args, alloc_mode) ->
       let args_with_sorts =
-        List.map2 (fun { ca_jkind } e ->
-            let sort = Jkind.sort_of_jkind ca_jkind in
-            e, sort)
-          cstr.cstr_args args
+        List.map2 (fun { ca_sort } e -> e, ca_sort) cstr.cstr_args args
       in
       let ll =
-        List.map (fun (e, sort) -> transl_exp ~scopes sort e) args_with_sorts
+        List.map (fun (e, sort) ->
+            transl_exp ~scopes (Jkind.Sort.of_const sort) e) args_with_sorts
       in
       if cstr.cstr_inlined <> None then begin match ll with
         | [x] -> x
@@ -566,7 +563,8 @@ and transl_exp0 ~in_new_scope ~scopes sort e =
                 | Constructor_uniform_value ->
                     let shape =
                       List.map (fun (e, sort) ->
-                          Lambda.must_be_value (layout_exp sort e))
+                          Lambda.must_be_value
+                            (layout_exp (Jkind.Sort.of_const sort) e))
                         args_with_sorts
                     in
                     Pmakeblock(runtime_tag, Immutable, Some shape, alloc_mode)
@@ -592,7 +590,8 @@ and transl_exp0 ~in_new_scope ~scopes sort e =
               | Constructor_uniform_value ->
                   let shape =
                     List.map (fun (e, sort) ->
-                        Lambda.must_be_value (layout_exp sort e))
+                        Lambda.must_be_value
+                          (layout_exp (Jkind.Sort.of_const sort) e))
                       args_with_sorts
                   in
                   Pmakeblock(0, Immutable, Some (Pgenval :: shape),
@@ -635,8 +634,7 @@ and transl_exp0 ~in_new_scope ~scopes sort e =
         if Types.is_mutable lbl.lbl_mut then Reads_vary else Reads_agree
       in
       let sem = add_barrier_to_read (transl_unique_barrier ubr) sem in
-      let lbl_sort = Jkind.sort_of_jkind lbl.lbl_jkind in
-      check_record_field_sort id.loc lbl_sort;
+      check_record_field_sort id.loc lbl.lbl_sort;
       begin match lbl.lbl_repres with
           Record_boxed _
         | Record_inlined (_, Constructor_uniform_value, Variant_boxed _) ->
@@ -696,8 +694,7 @@ and transl_exp0 ~in_new_scope ~scopes sort e =
          representability on construction, [sort_of_jkind] will be unsafe here.
          Probably we should add a sort to `Texp_setfield` in the typed tree,
          then. *)
-      let lbl_sort = Jkind.sort_of_jkind lbl.lbl_jkind in
-      check_record_field_sort id.loc lbl_sort;
+      check_record_field_sort id.loc lbl.lbl_sort;
       let mode =
         Assignment (transl_modify_mode arg_mode)
       in
@@ -735,7 +732,7 @@ and transl_exp0 ~in_new_scope ~scopes sort e =
         end
       in
       Lprim(access, [transl_exp ~scopes Jkind.Sort.for_record arg;
-                     transl_exp ~scopes lbl_sort newval],
+                     transl_exp ~scopes (Jkind.Sort.of_const lbl.lbl_sort) newval],
             of_location ~scopes e.exp_loc)
   | Texp_array (amut, element_sort, expr_list, alloc_mode) ->
       let mode = transl_alloc_mode alloc_mode in
@@ -1819,8 +1816,7 @@ and transl_record ~scopes loc env mode fields repres opt_init_expr =
     let copy_id = Ident.create_local "newrecord" in
     let update_field cont (lbl, definition) =
       (* CR layouts v5: allow more unboxed types here. *)
-      let lbl_sort = Jkind.sort_of_jkind lbl.lbl_jkind in
-      check_record_field_sort lbl.lbl_loc lbl_sort;
+      check_record_field_sort lbl.lbl_loc lbl.lbl_sort;
       match definition with
       | Kept _ -> cont
       | Overridden (_lid, expr) ->
@@ -1867,7 +1863,8 @@ and transl_record ~scopes loc env mode fields repres opt_init_expr =
               end
           in
           Lsequence(Lprim(upd, [Lvar copy_id;
-                                transl_exp ~scopes lbl_sort expr],
+                                transl_exp ~scopes
+                                  (Jkind.Sort.of_const lbl.lbl_sort) expr],
                           of_location ~scopes loc),
                     cont)
     in
@@ -1885,14 +1882,10 @@ and transl_record ~scopes loc env mode fields repres opt_init_expr =
     let lv =
       Array.mapi
         (fun i (lbl, definition) ->
-           (* CR layouts v2.5: When we allow `any` in record fields and check
-              representability on construction, [sort_of_layout] will be unsafe
-              here.  Probably we should add sorts to record construction in the
-              typed tree, then. *)
-           let lbl_sort = Jkind.sort_of_jkind lbl.lbl_jkind in
+           let sort = Jkind.Sort.of_const lbl.lbl_sort in
            match definition with
            | Kept (typ, mut, _) ->
-               let field_layout = layout env lbl.lbl_loc lbl_sort typ in
+               let field_layout = layout env lbl.lbl_loc sort typ in
                let sem =
                  if Types.is_mutable mut then Reads_vary else Reads_agree
                in
@@ -1948,8 +1941,8 @@ and transl_record ~scopes loc env mode fields repres opt_init_expr =
                      of_location ~scopes loc),
                field_layout
            | Overridden (_lid, expr) ->
-               let field_layout = layout_exp lbl_sort expr in
-               transl_exp ~scopes lbl_sort expr, field_layout)
+               let field_layout = layout_exp sort expr in
+               transl_exp ~scopes sort expr, field_layout)
         fields
     in
     let ll, shape = List.split (Array.to_list lv) in

toplevel/genprintval.ml

@@ -457,9 +457,9 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
                             instantiate_types env type_params ty_list l in
                           let ty_args =
                             List.map2
-                              (fun { ca_jkind } ty_arg ->
+                              (fun { ca_sort } ty_arg ->
                                  (ty_arg,
-                                 get_and_default_jkind_for_printing ca_jkind)
+                                 get_and_default_sort_for_printing ca_sort)
                               ) l ty_args
                           in
                           tree_of_constr_with_args (tree_of_constr env path)
@@ -699,8 +699,8 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
           | _ -> assert false
         in
         let args = instantiate_types env type_params ty_list cstr.cstr_args in
-        let args = List.map2 (fun { ca_jkind } arg ->
-            (arg, get_and_default_jkind_for_printing ca_jkind))
+        let args = List.map2 (fun { ca_sort } arg ->
+            (arg, get_and_default_sort_for_printing ca_sort))
             cstr.cstr_args args
         in
         tree_of_constr_with_args

typing/datarepr.ml

@@ -70,7 +70,7 @@ let constructor_args ~current_unit priv cd_args cd_res path rep =
       in
       let type_params = TypeSet.elements arg_vars_set in
       let arity = List.length type_params in
-      let is_void_label lbl = Jkind.is_void_defaulting lbl.ld_jkind in
+      let is_void_label lbl = Jkind.Sort.Const.(equal void lbl.ld_sort) in
       let jkind =
         Jkind.for_boxed_record ~all_void:(List.for_all is_void_label lbls)
       in
@@ -97,7 +97,7 @@ let constructor_args ~current_unit priv cd_args cd_res path rep =
       [
         {
           ca_type = newgenconstr path type_params;
-          ca_jkind = jkind;
+          ca_sort = Jkind.Sort.Const.value;
           ca_modalities = Mode.Modality.Value.Const.id;
           ca_loc = Location.none
         }
@@ -112,19 +112,19 @@ let constructor_descrs ~current_unit ty_path decl cstrs rep =
     | Variant_boxed x, _ -> x
     | Variant_unboxed, [{ cd_args }] ->
       begin match cd_args with
-      | Cstr_tuple [{ ca_jkind = jkind }]
-      | Cstr_record [{ ld_jkind = jkind }] ->
-        [| Constructor_uniform_value, [| jkind |] |]
+      | Cstr_tuple [{ ca_sort = sort }]
+      | Cstr_record [{ ld_sort = sort }] ->
+        [| Constructor_uniform_value, [| sort |] |]
       | _ -> Misc.fatal_error "Multiple arguments in [@@unboxed] variant"
       end
     | _ -> Misc.fatal_error "Multiple constructors in [@@unboxed] variant"
   in
-  let all_void jkinds = Array.for_all Jkind.is_void_defaulting jkinds in
+  let all_void sorts = Array.for_all Jkind.Sort.Const.(equal void) sorts in
   let num_consts = ref 0 and num_nonconsts = ref 0 in
   let cstr_constant =
     Array.map
-      (fun (_, jkinds) ->
-         let all_void = all_void jkinds in
+      (fun (_, sorts) ->
+         let all_void = all_void sorts in
          if all_void then incr num_consts else incr num_nonconsts;
          all_void)
       cstr_shapes_and_arg_jkinds
@@ -213,7 +213,7 @@ let none =
 let dummy_label =
   { lbl_name = ""; lbl_res = none; lbl_arg = none;
     lbl_mut = Immutable; lbl_modalities = Mode.Modality.Value.Const.id;
-    lbl_jkind = Jkind.Builtin.any ~why:Dummy_jkind;
+    lbl_sort = Jkind.Sort.Const.void;
     lbl_num = -1; lbl_pos = -1; lbl_all = [||];
     lbl_repres = Record_unboxed;
     lbl_private = Public;
@@ -227,14 +227,14 @@ let label_descrs ty_res lbls repres priv =
   let rec describe_labels num pos = function
       [] -> []
     | l :: rest ->
-        let is_void = Jkind.is_void_defaulting l.ld_jkind  in
+        let is_void = Jkind.Sort.Const.(equal void l.ld_sort) in
         let lbl =
           { lbl_name = Ident.name l.ld_id;
             lbl_res = ty_res;
             lbl_arg = l.ld_type;
             lbl_mut = l.ld_mutable;
             lbl_modalities = l.ld_modalities;
-            lbl_jkind = l.ld_jkind;
+            lbl_sort = l.ld_sort;
             lbl_pos = if is_void then lbl_pos_void else pos;
             lbl_num = num;
             lbl_all = all_labels;