flambda-backend: Remove Jkind.of_sort (#1890)

Author: goldfirere

lambda/translmod.ml

@@ -38,7 +38,7 @@ type unsafe_info =
 type error =
   Circular_dependency of (Ident.t * unsafe_info) list
 | Conflicting_inline_attributes
-| Non_value_jkind of type_expr * Jkind.Violation.t
+| Non_value_jkind of type_expr * Jkind.sort
 
 exception Error of Location.t * error
 
@@ -55,13 +55,7 @@ exception Error of Location.t * error
    some defaulting. *)
 let sort_must_not_be_void loc ty sort =
   if Jkind.Sort.is_void_defaulting sort then
-    let violation =
-      Jkind.(Violation.of_
-                (Not_a_subjkind
-                   (Jkind.of_sort ~why:V1_safety_check sort,
-                    value ~why:V1_safety_check)))
-    in
-    raise (Error (loc, Non_value_jkind (ty, violation)))
+    raise (Error (loc, Non_value_jkind (ty, sort)))
 
 let cons_opt x_opt xs =
   match x_opt with
@@ -1893,12 +1887,12 @@ let report_error loc = function
         print_cycle cycle chapter section
   | Conflicting_inline_attributes ->
       Location.errorf "@[Conflicting 'inline' attributes@]"
-  | Non_value_jkind (ty, err) ->
+  | Non_value_jkind (ty, sort) ->
       Location.errorf
-        "Non-value detected in [translmod]:@ Please report this error to \
-         the Jane Street compilers team.@ %a"
-        (Jkind.Violation.report_with_offender
-           ~offender:(fun ppf -> Printtyp.type_expr ppf ty)) err
+        "Non-value sort %a detected in [translmod] in type %a:@ \
+         Please report this error to the Jane Street compilers team."
+        Jkind.Sort.format sort
+        Printtyp.type_expr ty
 
 let () =
   Location.register_error_of_exn

lambda/translmod.mli

@@ -53,7 +53,7 @@ type unsafe_info =
 type error =
   Circular_dependency of (Ident.t * unsafe_info) list
 | Conflicting_inline_attributes
-| Non_value_jkind of Types.type_expr * Jkind.Violation.t
+| Non_value_jkind of Types.type_expr * Jkind.sort
 
 exception Error of Location.t * error
 

typing/ctype.ml

@@ -238,6 +238,9 @@ let new_scoped_ty scope desc = newty3 ~level:!current_level ~scope desc
 
 let newvar ?name jkind =
   newty2 ~level:!current_level (Tvar { name; jkind })
+let new_rep_var ?name ~why () =
+  let jkind, sort = Jkind.of_new_sort_var ~why in
+  newvar ?name jkind, sort
 let newvar2 ?name level jkind = newty2 ~level (Tvar { name; jkind })
 let new_global_var ?name jkind =
   newty2 ~level:!global_level (Tvar { name; jkind })
@@ -2080,10 +2083,8 @@ let type_jkind env ty =
   estimate_type_jkind env (get_unboxed_type_approximation env ty)
 
 let type_sort ~why env ty =
-  let sort = Jkind.Sort.new_var () in
-  match
-    constrain_type_jkind env ty (Jkind.of_sort sort ~why)
-  with
+  let jkind, sort = Jkind.of_new_sort_var ~why in
+  match constrain_type_jkind env ty jkind with
   | Ok _ -> Ok sort
   | Error _ as e -> e
 
@@ -3817,14 +3818,12 @@ let filter_arrow env t l ~force_tpoly =
        allow both to be any.  Separately, the relevant checks on function
        arguments should happen when functions are constructed, not their
        types. *)
-    let arg_sort = Jkind.Sort.new_var () in
-    let l_arg = Jkind.of_sort ~why:Function_argument arg_sort in
-    let ret_sort = Jkind.Sort.new_var () in
-    let l_res = Jkind.of_sort ~why:Function_result ret_sort in
+    let k_arg, arg_sort = Jkind.of_new_sort_var ~why:Function_argument in
+    let k_res, ret_sort = Jkind.of_new_sort_var ~why:Function_result in
     let ty_arg =
       if not force_tpoly then begin
         assert (not (is_optional l));
-        newvar2 level l_arg
+        newvar2 level k_arg
       end else begin
         let t1 =
           if is_optional l then
@@ -3835,12 +3834,12 @@ let filter_arrow env t l ~force_tpoly =
                        [newvar2 level (Jkind.value ~why:Type_argument)],
                        ref Mnil))
           else
-            newvar2 level l_arg
+            newvar2 level k_arg
         in
         newty2 ~level (Tpoly(t1, []))
       end
     in
-    let ty_ret = newvar2 level l_res in
+    let ty_ret = newvar2 level k_res in
     let arg_mode = Mode.Alloc.newvar () in
     let ret_mode = Mode.Alloc.newvar () in
     let t' =

typing/ctype.mli

@@ -55,6 +55,10 @@ val create_scope : unit -> int
 val newty: type_desc -> type_expr
 val new_scoped_ty: int -> type_desc -> type_expr
 val newvar: ?name:string -> Jkind.t -> type_expr
+val new_rep_var :
+  ?name:string -> why:Jkind.concrete_jkind_reason -> unit ->
+  type_expr * Jkind.sort
+        (* Return a fresh representable variable, along with its sort *)
 val newvar2: ?name:string -> int -> Jkind.t -> type_expr
         (* Return a fresh variable *)
 val new_global_var: ?name:string -> Jkind.t -> type_expr

typing/jkind.ml

@@ -471,9 +471,12 @@ let get_required_layouts_level (context : annotation_context) (jkind : const) :
 (* construction *)
 
 let of_new_sort_var ~why =
-  fresh_jkind (Sort (Sort.new_var ())) ~why:(Concrete_creation why)
+  let sort = Sort.new_var () in
+  fresh_jkind (Sort sort) ~why:(Concrete_creation why), sort
 
-let of_sort ~why s = fresh_jkind (Sort s) ~why:(Concrete_creation why)
+let of_new_sort ~why = fst (of_new_sort_var ~why)
+
+let of_sort_for_error ~why s = fresh_jkind (Sort s) ~why:(Concrete_creation why)
 
 let of_const ~why : const -> t = function
   | Any -> fresh_jkind Any ~why

typing/jkind.mli

@@ -348,10 +348,17 @@ val float64 : why:float64_creation_reason -> t
 (******************************)
 (* construction *)
 
+(** Create a fresh sort variable, packed into a jkind, returning both
+    the resulting kind and the sort. *)
+val of_new_sort_var : why:concrete_jkind_reason -> t * sort
+
 (** Create a fresh sort variable, packed into a jkind. *)
-val of_new_sort_var : why:concrete_jkind_reason -> t
+val of_new_sort : why:concrete_jkind_reason -> t
 
-val of_sort : why:concrete_jkind_reason -> sort -> t
+(** There should not be a need to convert a sort to a jkind, but this is
+    occasionally useful for formatting error messages. Do not use in actual
+    type-checking. *)
+val of_sort_for_error : why:concrete_jkind_reason -> sort -> t
 
 val of_const : why:creation_reason -> const -> t
 

typing/typeclass.ml

@@ -1398,7 +1398,7 @@ and class_expr_aux cl_num val_env met_env virt self_scope scl =
                   Typecore.escape ~loc ~env:val_env ~reason:Other mode;
                   if not (Jkind.Sort.(equate sort value))
                   then let viol = Jkind.Violation.of_ (Not_a_subjkind(
-                    Jkind.of_sort ~why:Let_binding sort,
+                    Jkind.of_sort_for_error ~why:Let_binding sort,
                     Jkind.value ~why:Class_let_binding))
                     in
                     raise (Error(loc, met_env,

typing/typecore.ml

@@ -3298,13 +3298,10 @@ let collect_unknown_apply_args env funct ty_fun mode_fun rev_args sargs ret_tvar
           let ty_fun = expand_head env ty_fun in
           match get_desc ty_fun with
           | Tvar _ ->
-              let sort_arg = Jkind.Sort.new_var () in
-              let ty_arg_mono =
-                newvar (Jkind.of_sort ~why:Function_argument sort_arg)
-              in
+              let ty_arg_mono, sort_arg = new_rep_var ~why:Function_argument () in
               let ty_arg = newmono ty_arg_mono in
               let ty_res =
-                newvar (Jkind.of_new_sort_var ~why:Function_result)
+                newvar (Jkind.of_new_sort ~why:Function_result)
               in
               if ret_tvar &&
                  not (is_prim ~name:"%identity" funct) &&
@@ -3817,7 +3814,7 @@ let rec approx_type env sty =
       let arg =
         if is_optional p
         then type_option (newvar (Jkind.value ~why:Type_argument))
-        else newvar (Jkind.of_new_sort_var ~why:Function_argument)
+        else newvar (Jkind.of_new_sort ~why:Function_argument)
       in
       let ret = approx_type env sty in
       let marg = Alloc.of_const arg_mode in
@@ -4912,10 +4909,9 @@ and type_expect_
           tuple_pat_mode mode modes, mode_tuple mode modes
       in
       begin_def ();
-      let sort = Jkind.Sort.new_var () in
+      let expected_ty, sort = new_rep_var ~why:Match () in
       let arg =
-        type_expect env arg_expected_mode sarg
-          (mk_expected (newvar (Jkind.of_sort ~why:Match sort)))
+        type_expect env arg_expected_mode sarg (mk_expected expected_ty)
       in
       end_def ();
       if maybe_expansive arg then lower_contravariant env arg.exp_type;
@@ -5079,7 +5075,7 @@ and type_expect_
         in
         match expected_opath, opt_exp_opath with
         | None, None ->
-          newvar (Jkind.of_new_sort_var ~why:Record_projection), None
+          newvar (Jkind.of_new_sort ~why:Record_projection), None
         | Some _, None -> ty_expected, expected_opath
         | Some(_, _, true), Some _ -> ty_expected, expected_opath
         | (None | Some (_, _, false)), Some (_, p', _) ->
@@ -5244,7 +5240,7 @@ and type_expect_
         type_label_access env srecord Env.Mutation lid in
       let ty_record =
         if expected_type = None
-        then newvar (Jkind.of_new_sort_var ~why:Record_assignment)
+        then newvar (Jkind.of_new_sort ~why:Record_assignment)
         else record.exp_type
       in
       let (label_loc, label, newval) =
@@ -5864,29 +5860,19 @@ and type_expect_
       let spat_params, ty_params, param_sort =
         let initial_jkind, initial_sort = match sands with
           | [] ->
-            let sort = Jkind.Sort.new_var () in
-            Jkind.of_sort ~why:Function_argument sort, sort
+            Jkind.of_new_sort_var ~why:Function_argument
           (* CR layouts v5: eliminate value requirement for tuple elements *)
           | _ -> Jkind.value ~why:Tuple_element, Jkind.Sort.value
         in
         loop slet.pbop_pat (newvar initial_jkind) initial_sort sands
       in
-      let body_sort = Jkind.Sort.new_var () in
-      let ty_func_result =
-        newvar (Jkind.of_sort ~why:Function_result body_sort)
-      in
+      let ty_func_result, body_sort = new_rep_var ~why:Function_result () in
       let arrow_desc = Nolabel, Alloc.legacy, Alloc.legacy in
       let ty_func =
         newty (Tarrow(arrow_desc, newmono ty_params, ty_func_result, commu_ok))
       in
-      let op_result_sort = Jkind.Sort.new_var () in
-      let ty_result =
-        newvar (Jkind.of_sort ~why:Function_result op_result_sort)
-      in
-      let sort_andops = Jkind.Sort.new_var () in
-      let ty_andops =
-        newvar (Jkind.of_sort ~why:Function_argument sort_andops)
-      in
+      let ty_result, op_result_sort = new_rep_var ~why:Function_result () in
+      let ty_andops, sort_andops = new_rep_var ~why:Function_argument () in
       let ty_op =
         newty (Tarrow(arrow_desc, newmono ty_andops,
           newty (Tarrow(arrow_desc, newmono ty_func,
@@ -7072,8 +7058,7 @@ and type_statement ?explanation ?(position=RNontail) env sexp =
      getting a sort variable for its jkind. *)
   (* CR layouts v10: Abstract jkinds will introduce cases where we really
      have [any] and can't get a sort here. *)
-  let sort = Jkind.Sort.new_var () in
-  let tv = newvar (Jkind.of_sort ~why:Statement sort) in
+  let tv, sort = new_rep_var ~why:Statement () in
   if is_Tvar ty && get_level ty > get_level tv then
     Location.prerr_warning
       (final_subexpression exp).exp_loc
@@ -7448,9 +7433,8 @@ and type_let
          attrs, pat_mode, exp_mode, spat)
       spat_sexp_list in
   let is_recursive = (rec_flag = Recursive) in
-  let sorts = List.map (fun _ -> Jkind.Sort.new_var ()) spatl in
-  let nvs =
-    List.map (fun s -> newvar (Jkind.of_sort ~why:Let_binding s)) sorts
+  let nvs, sorts =
+    List.split (List.map (fun _ -> new_rep_var ~why:Let_binding ()) spatl)
   in
   if is_recursive then begin_def ();
   let (pat_list, new_env, force, pvs, mvs) =
@@ -7713,14 +7697,9 @@ and type_andops env sarg sands expected_sort expected_ty =
         if !Clflags.principal then begin_def ();
         let op_path, op_desc = type_binding_op_ident env sop in
         let op_type = op_desc.val_type in
-        let sort_arg = Jkind.Sort.new_var () in
-        let ty_arg = newvar (Jkind.of_sort ~why:Function_argument sort_arg) in
-        let sort_rest = Jkind.Sort.new_var () in
-        let ty_rest = newvar (Jkind.of_sort ~why:Function_argument sort_rest) in
-        let op_result_sort = Jkind.Sort.new_var () in
-        let ty_result =
-          newvar (Jkind.of_sort ~why:Function_result op_result_sort)
-        in
+        let ty_arg, sort_arg = new_rep_var ~why:Function_argument () in
+        let ty_rest, sort_rest = new_rep_var ~why:Function_argument () in
+        let ty_result, op_result_sort = new_rep_var ~why:Function_result () in
         let arrow_desc = (Nolabel,Alloc.legacy,Alloc.legacy) in
         let ty_rest_fun =
           newty (Tarrow(arrow_desc, newmono ty_arg, ty_result, commu_ok))
@@ -8239,8 +8218,8 @@ let type_expression env jkind sexp =
   maybe_check_uniqueness_exp exp; exp
 
 let type_representable_expression ~why env sexp =
-  let sort = Jkind.Sort.new_var () in
-  let exp = type_expression env (Jkind.of_sort ~why sort) sexp in
+  let jkind, sort = Jkind.of_new_sort_var ~why in
+  let exp = type_expression env jkind sexp in
   exp, sort
 
 let type_expression env sexp =

typing/typetexp.ml

@@ -464,7 +464,7 @@ let transl_type_param env path styp =
    to ask for it with an annotation.  Some restriction here seems necessary
    for backwards compatibility (e.g., we wouldn't want [type 'a id = 'a] to
    have jkind any).  But it might be possible to infer any in some cases. *)
-  let jkind = Jkind.of_new_sort_var ~why:Unannotated_type_parameter in
+  let jkind = Jkind.of_new_sort ~why:Unannotated_type_parameter in
   let attrs = styp.ptyp_attributes in
   match styp.ptyp_desc with
     Ptyp_any -> transl_type_param_var env loc attrs None jkind None
@@ -480,7 +480,7 @@ let transl_type_param env path styp =
 
 let get_type_param_jkind path styp =
   match Jane_syntax.Core_type.of_ast styp with
-  | None -> Jkind.of_new_sort_var ~why:Unannotated_type_parameter
+  | None -> Jkind.of_new_sort ~why:Unannotated_type_parameter
   | Some (Jtyp_layout (Ltyp_var { name; jkind }), _attrs) ->
     Jkind.of_annotation ~context:(Type_parameter (path, name)) jkind
   | Some _ -> Misc.fatal_error "non-type-variable in get_type_param_jkind"