Remove call to make_params in enter_type

Author: goldfirere

ocaml/typing/typeclass.ml

@@ -1615,7 +1615,7 @@ let class_infos define_class kind
   let ci_params =
     let make_param (sty, v) =
       try
-        let param = transl_type_param ~generic:false env (Pident ty_id) sty in
+        let param = transl_type_param env (Pident ty_id) sty in
         (* CR layouts: we require class type parameters to be values, but
            we should lift this restriction. Doing so causes bad error messages
            today, so we wait for tomorrow. *)

ocaml/typing/typedecl.ml

@@ -107,11 +107,11 @@ let get_unboxed_from_attributes sdecl =
 (* [make_params] creates sort variables - these can be defaulted away (as in
    transl_type_decl) or unified with existing sort-variable-free types (as in
    transl_with_constraint). *)
-let make_params ~generic env path params =
+let make_params env path params =
   TyVarEnv.reset (); (* [transl_type_param] binds type variables *)
   let make_param (sty, v) =
     try
-      (transl_type_param ~generic env path sty, v)
+      (transl_type_param env path sty, v)
     with Already_bound ->
       raise(Error(sty.ptyp_loc, Repeated_parameter))
   in
@@ -194,22 +194,28 @@ let enter_type rec_flag env sdecl (id, uid) =
      layout of the variable put in manifests here is updated when constraints
      are checked and then unified with the real manifest and checked against the
      kind. *)
-  let layout =
+  let type_layout =
     (* We set ~legacy_immediate to true because we're looking at a declaration
        that was already allowed to be [@@immediate] *)
     layout_of_attributes_default
       ~legacy_immediate:true ~context:(Type_declaration path)
       ~default:(Layout.any ~why:Initial_typedecl_env)
       sdecl.ptype_attributes
   in
+  let type_params =
+    List.map (fun (param, _) ->
+        let name = get_type_param_name param in
+        let layout = get_type_param_layout path param in
+        Btype.newgenvar ?name layout)
+      sdecl.ptype_params
+  in
   let decl =
-    { type_params = List.map (fun (ctyp, _) -> ctyp.ctyp_type)
-                      (make_params ~generic:true env path sdecl.ptype_params);
+    { type_params;
       type_arity = arity;
       type_kind = Type_abstract;
-      type_layout = layout;
+      type_layout;
       type_private = sdecl.ptype_private;
-      type_manifest = Some (Ctype.newvar layout);
+      type_manifest = Some (Ctype.newvar type_layout);
       type_variance = Variance.unknown_signature ~injective:false ~arity;
       type_separability = Types.Separability.default_signature ~arity;
       type_is_newtype = false;
@@ -590,7 +596,7 @@ let transl_declaration env sdecl (id, uid) =
   TyVarEnv.reset ();
   Ctype.begin_def ();
   let path = Path.Pident id in
-  let tparams = make_params ~generic:false env path sdecl.ptype_params in
+  let tparams = make_params env path sdecl.ptype_params in
   let params = List.map (fun (cty, _) -> cty.ctyp_type) tparams in
   let cstrs = List.map
     (fun (sty, sty', loc) ->
@@ -1743,7 +1749,7 @@ let transl_type_extension extend env loc styext =
   | Some err -> raise (Error(loc, Extension_mismatch (type_path, env, err)))
   end;
   let ttype_params =
-    make_params ~generic:false env type_path styext.ptyext_params
+    make_params env type_path styext.ptyext_params
   in
   let type_params = List.map (fun (cty, _) -> cty.ctyp_type) ttype_params in
   List.iter2 (Ctype.unify_var env)
@@ -2083,7 +2089,7 @@ let transl_with_constraint id ?fixed_row_path ~sig_env ~sig_decl ~outer_env
      declaration [sdecl] in the outer environment [outer_env]. *)
   let env = outer_env in
   let loc = sdecl.ptype_loc in
-  let tparams = make_params ~generic:false env (Pident id) sdecl.ptype_params in
+  let tparams = make_params env (Pident id) sdecl.ptype_params in
   let params = List.map (fun (cty, _) -> cty.ctyp_type) tparams in
   let arity = List.length params in
   let constraints =

ocaml/typing/typetexp.ml

@@ -425,7 +425,7 @@ let newvar ?name layout =
 let valid_tyvar_name name =
   name <> "" && name.[0] <> '_'
 
-let transl_type_param_var ~generic env loc attrs name_opt
+let transl_type_param_var env loc attrs name_opt
       (layout : layout) (layout_annot : const_layout option) =
   let tvar = Ttyp_var (name_opt, layout_annot) in
   let name =
@@ -438,35 +438,26 @@ let transl_type_param_var ~generic env loc attrs name_opt
         raise Already_bound;
       name
   in
-  let ty = if generic
-    then
-      (* this case is used in [Typedecl.enter_type], when we're creating
-         a temporary env just for layout checking; no need to actually
-         add the variable to the env *)
-      Btype.newgenvar ~name layout
-    else
-      let ty = new_global_var ~name layout in
-      Option.iter (fun name -> TyVarEnv.add name ty) name_opt;
-      ty
-  in
+  let ty = new_global_var ~name layout in
+  Option.iter (fun name -> TyVarEnv.add name ty) name_opt;
   { ctyp_desc = tvar; ctyp_type = ty; ctyp_env = env;
     ctyp_loc = loc; ctyp_attributes = attrs }
 
-let transl_type_param_jst ~generic env loc attrs path :
+let transl_type_param_jst env loc attrs path :
   Jane_syntax.Core_type.t -> _ =
   function
   | Jtyp_layout (Ltyp_var { name; layout = annot }) ->
      let layout =
        Layout.of_annotation ~context:(Type_parameter (path, name)) annot
      in
-     transl_type_param_var ~generic env loc attrs name layout (Some annot.txt)
+     transl_type_param_var env loc attrs name layout (Some annot.txt)
   | Jtyp_layout (Ltyp_poly _ | Ltyp_alias _) ->
     Misc.fatal_error "non-type-variable in transl_type_param_jst"
 
-let transl_type_param ~generic env path styp =
+let transl_type_param env path styp =
   let loc = styp.ptyp_loc in
   match Jane_syntax.Core_type.of_ast styp with
-  | Some (etyp, attrs) -> transl_type_param_jst ~generic env loc attrs path etyp
+  | Some (etyp, attrs) -> transl_type_param_jst env loc attrs path etyp
   | None ->
   (* Our choice for now is that if you want a parameter of layout any, you have
    to ask for it with an annotation.  Some restriction here seems necessary
@@ -475,25 +466,32 @@ let transl_type_param ~generic env path styp =
   let layout = Layout.of_new_sort_var ~why:Unannotated_type_parameter in
   let attrs = styp.ptyp_attributes in
   match styp.ptyp_desc with
-    Ptyp_any -> transl_type_param_var ~generic env loc attrs None layout None
+    Ptyp_any -> transl_type_param_var env loc attrs None layout None
   | Ptyp_var name ->
-    transl_type_param_var ~generic env loc attrs (Some name) layout None
+    transl_type_param_var env loc attrs (Some name) layout None
   | _ -> assert false
 
-let transl_type_param ~generic env path styp =
+let transl_type_param env path styp =
   (* Currently useless, since type parameters cannot hold attributes
      (but this could easily be lifted in the future). *)
   Builtin_attributes.warning_scope styp.ptyp_attributes
-    (fun () -> transl_type_param ~generic env path styp)
+    (fun () -> transl_type_param env path styp)
 
-(* returns just the layout of the param *)
 let get_type_param_layout path styp =
   match Jane_syntax.Core_type.of_ast styp with
   | None -> Layout.of_new_sort_var ~why:Unannotated_type_parameter
   | Some (Jtyp_layout (Ltyp_var { name; layout }), _attrs) ->
     Layout.of_annotation ~context:(Type_parameter (path, name)) layout
   | Some _ -> Misc.fatal_error "non-type-variable in get_type_param_layout"
 
+let get_type_param_name styp =
+  (* We don't need to check for jane-syntax here, just to get the
+     name. *)
+  match styp.ptyp_desc with
+  | Ptyp_any -> None
+  | Ptyp_var name -> Some name
+  | _ -> Misc.fatal_error "non-type-variable in get_type_param_name"
+
 let get_alloc_mode styp =
   match Builtin_attributes.has_local styp.ptyp_attributes with
   | Ok true -> Alloc_mode.Local

ocaml/typing/typetexp.mli

@@ -69,10 +69,12 @@ val transl_simple_type_delayed
 val transl_type_scheme:
         Env.t -> Parsetree.core_type -> Typedtree.core_type
 val transl_type_param:
-  generic:bool -> Env.t -> Path.t -> Parsetree.core_type -> Typedtree.core_type
+  Env.t -> Path.t -> Parsetree.core_type -> Typedtree.core_type
 (* the Path.t above is of the type/class whose param we are processing;
    the level defaults to the current level *)
+
 val get_type_param_layout: Path.t -> Parsetree.core_type -> layout
+val get_type_param_name: Parsetree.core_type -> string option
 
 val get_alloc_mode : Parsetree.core_type -> alloc_mode_const