flambda-backend: Port upstream #12368 about abstract environments (#1759

)

* Manually apply patch from upstream #12368

* bootstrap

ocamldoc/odoc_sig.ml

@@ -372,7 +372,7 @@ module Analyser =
 
     let get_type_kind env name_comment_list type_kind =
       match type_kind with
-        Types.Type_abstract ->
+        Types.Type_abstract _ ->
           Odoc_type.Type_abstract
       | Types.Type_variant (l,_) ->
           let f {Types.cd_id=constructor_name;cd_args;cd_res=ret_type} =

testsuite/tests/typing-misc/constraints.ml

@@ -371,3 +371,17 @@ val test_obj_with_expansion :
   'a tag -> ('b, < bar : bar -> 'b; foo : foo -> 'b; .. >) obj -> 'a -> 'b =
   <fun>
 |}]
+
+(* PR #12334 *)
+
+type 'a t = 'a foo foo
+and 'a foo = int constraint 'a = int
+[%%expect{|
+Line 1, characters 0-22:
+1 | type 'a t = 'a foo foo
+    ^^^^^^^^^^^^^^^^^^^^^^
+Error: Constraints are not satisfied in this type.
+       Type int should be an instance of 'a foo
+       Type foo was considered abstract when checking constraints in this
+       recursive type definition.
+|}]

toplevel/genprintval.ml

@@ -368,9 +368,9 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
               try
                 let decl = Env.find_type path env in
                 match decl with
-                | {type_kind = Type_abstract; type_manifest = None} ->
+                | {type_kind = Type_abstract _; type_manifest = None} ->
                     Oval_stuff "<abstr>"
-                | {type_kind = Type_abstract; type_manifest = Some body} ->
+                | {type_kind = Type_abstract _; type_manifest = Some body} ->
                     tree_of_val depth obj
                       (instantiate_type env decl.type_params ty_list body)
                 | {type_kind = Type_variant (constr_list,rep)} ->

typing/btype.ml

@@ -127,6 +127,8 @@ let is_Tvar ty = match get_desc ty with Tvar _ -> true | _ -> false
 let is_Tunivar ty = match get_desc ty with Tunivar _ -> true | _ -> false
 let is_Tconstr ty = match get_desc ty with Tconstr _ -> true | _ -> false
 let is_Tpoly ty = match get_desc ty with Tpoly _ -> true | _ -> false
+let type_kind_is_abstract decl =
+  match decl.type_kind with Type_abstract _ -> true | _ -> false
 
 let dummy_method = "*dummy method*"
 
@@ -325,7 +327,7 @@ let map_type_expr_cstr_args f = function
       Cstr_record (List.map (fun d -> {d with ld_type=f d.ld_type}) lbls)
 
 let iter_type_expr_kind f = function
-  | Type_abstract -> ()
+  | Type_abstract _ -> ()
   | Type_variant (cstrs, _) ->
       List.iter
         (fun cd ->

typing/btype.mli

@@ -81,6 +81,7 @@ val is_Tconstr: type_expr -> bool
 val is_Tpoly: type_expr -> bool
 
 val dummy_method: label
+val type_kind_is_abstract: type_declaration -> bool
 
 (**** polymorphic variants ****)
 

typing/ctype.ml

@@ -380,7 +380,7 @@ let in_pervasives p =
 let is_datatype decl=
   match decl.type_kind with
     Type_record _ | Type_variant _ | Type_open -> true
-  | Type_abstract -> false
+  | Type_abstract _ -> false
 
 
                   (**********************************************)
@@ -622,7 +622,7 @@ let closed_type_decl decl =
     List.iter mark_type decl.type_params;
     List.iter remove_mode_and_layout_variables decl.type_params;
     begin match decl.type_kind with
-      Type_abstract ->
+      Type_abstract _ ->
         ()
     | Type_variant (v, _rep) ->
         List.iter
@@ -957,7 +957,7 @@ let rec lower_contravariant env var_level visited contra ty =
          try
            let typ = Env.find_type path env in
            typ.type_variance,
-           decl_is_abstract typ
+           type_kind_is_abstract typ
           with Not_found ->
             (* See testsuite/tests/typing-missing-cmi-2 for an example *)
             List.map (fun _ -> Variance.unknown) tyl,
@@ -1312,7 +1312,7 @@ let new_local_type ?(loc = Location.none) ?manifest_and_scope layout =
   {
     type_params = [];
     type_arity = 0;
-    type_kind = Type_abstract;
+    type_kind = Type_abstract Abstract_def;
     type_layout = layout;
     type_private = Public;
     type_manifest = manifest;
@@ -1381,7 +1381,7 @@ let instance_parameterized_type_2 sch_args sch_lst sch =
 
 (* [map_kind f kind] maps [f] over all the types in [kind]. [f] must preserve layouts *)
 let map_kind f = function
-  | (Type_abstract | Type_open) as k -> k
+  | (Type_abstract _ | Type_open) as k -> k
   | Type_variant (cl, rep) ->
       Type_variant (
         List.map
@@ -1840,7 +1840,7 @@ let rec extract_concrete_typedecl env ty =
       begin match Env.find_type p env with
       | exception Not_found -> May_have_typedecl
       | decl ->
-          if not (decl_is_abstract decl) then Typedecl(p, p, decl)
+          if not (type_kind_is_abstract decl) then Typedecl(p, p, decl)
           else begin
             match try_expand_safe env ty with
             | exception Cannot_expand -> May_have_typedecl
@@ -2184,7 +2184,7 @@ let generic_abbrev env path =
 let generic_private_abbrev env path =
   try
     match Env.find_type path env with
-      {type_kind = Type_abstract;
+      {type_kind = Type_abstract _;
        type_private = Private;
        type_manifest = Some body} ->
          get_level body = generic_level
@@ -2640,7 +2640,7 @@ let is_newtype env p =
   try
     let decl = Env.find_type p env in
     decl.type_expansion_scope <> Btype.lowest_level &&
-    decl_is_abstract decl &&
+    type_kind_is_abstract decl &&
     decl.type_private = Public
   with Not_found -> false
 
@@ -2668,14 +2668,14 @@ let non_aliasable p decl =
    appropriate platforms).
 
    CR layouts: the non_aliasable check could really be combined with the
-   decl_is_abstract check, and both could be guarded by ~for_layout_eqn, allowing
+   type_kind_is_abstract check, and both could be guarded by ~for_layout_eqn, allowing
    the refinement of layouts of data types.  Write some tests cases and make
    that change.
 *)
 let is_instantiable env ~for_layout_eqn p =
   try
     let decl = Env.find_type p env in
-    decl_is_abstract decl &&
+    type_kind_is_abstract decl &&
     decl.type_private = Public &&
     decl.type_arity = 0 &&
     decl.type_manifest = None &&
@@ -2862,9 +2862,9 @@ and mcomp_type_decl type_pairs env p1 p2 tl1 tl2 =
           mcomp_variant_description type_pairs env v1 v2
       | Type_open, Type_open ->
           mcomp_list type_pairs env tl1 tl2
-      | Type_abstract, Type_abstract -> ()
-      | Type_abstract, _ when not (non_aliasable p1 decl)-> ()
-      | _, Type_abstract when not (non_aliasable p2 decl') -> ()
+      | Type_abstract _, Type_abstract _ -> ()
+      | Type_abstract _, _ when not (non_aliasable p1 decl)-> ()
+      | _, Type_abstract _ when not (non_aliasable p2 decl') -> ()
       | _ -> raise Incompatible
   with Not_found -> ()
 
@@ -3056,7 +3056,7 @@ let complete_type_list ?(allow_absent=false) env fl1 lv2 mty2 fl2 =
     | (n, _) :: nl, _ ->
         let lid = concat_longident (Longident.Lident "Pkg") n in
         match Env.find_type_by_name lid env' with
-        | (_, {type_arity = 0; type_kind = Type_abstract;
+        | (_, {type_arity = 0; type_kind = Type_abstract _;
                type_private = Public; type_manifest = Some t2}) ->
             begin match nondep_instance env' lv2 id2 t2 with
             | t -> (n, t) :: complete nl fl2
@@ -3066,7 +3066,7 @@ let complete_type_list ?(allow_absent=false) env fl1 lv2 mty2 fl2 =
                 else
                   raise Exit
             end
-        | (_, {type_arity = 0; type_kind = Type_abstract;
+        | (_, {type_arity = 0; type_kind = Type_abstract _;
                type_private = Public; type_manifest = None})
           when allow_absent ->
             complete nl fl2
@@ -6113,7 +6113,7 @@ let nondep_type_decl env mid is_covariant decl =
     let params = List.map (nondep_type_rec env mid) decl.type_params in
     let tk =
       try map_kind (nondep_type_rec env mid) decl.type_kind
-      with Nondep_cannot_erase _ when is_covariant -> Type_abstract
+      with Nondep_cannot_erase _ when is_covariant -> Type_abstract Abstract_def
     and tm, priv =
       match decl.type_manifest with
       | None -> None, decl.type_private

typing/datarepr.ml

@@ -249,11 +249,11 @@ let constructors_of_type ~current_unit ty_path decl =
   match decl.type_kind with
   | Type_variant (cstrs,rep) ->
      constructor_descrs ~current_unit ty_path decl cstrs rep
-  | Type_record _ | Type_abstract | Type_open -> []
+  | Type_record _ | Type_abstract _ | Type_open -> []
 
 let labels_of_type ty_path decl =
   match decl.type_kind with
   | Type_record(labels, rep) ->
       label_descrs (newgenconstr ty_path decl.type_params)
         labels rep decl.type_private
-  | Type_variant _ | Type_abstract | Type_open -> []
+  | Type_variant _ | Type_abstract _ | Type_open -> []

typing/env.ml

@@ -1230,7 +1230,7 @@ let find_type_data path env =
       | decl ->
           {
             tda_declaration = decl;
-            tda_descriptions = Type_abstract;
+            tda_descriptions = Type_abstract Abstract_def;
             tda_shape = Shape.leaf decl.type_uid;
           }
       | exception Not_found -> find_type_full p env
@@ -1248,7 +1248,7 @@ let find_type_data path env =
               List.find (fun cstr -> cstr.cstr_name = s) cstrs
             with Not_found -> assert false
           end
-        | Type_record _ | Type_abstract | Type_open -> assert false
+        | Type_record _ | Type_abstract _ | Type_open -> assert false
         end
       in
       type_of_cstr path cstr
@@ -1485,7 +1485,7 @@ let find_type_expansion path env =
   let decl = find_type path env in
   match decl.type_manifest with
   | Some body when decl.type_private = Public
-              || not (decl_is_abstract decl)
+              || not (Btype.type_kind_is_abstract decl)
               || Btype.has_constr_row body ->
       (decl.type_params, body, decl.type_expansion_scope)
   (* The manifest type of Private abstract data types without
@@ -1841,7 +1841,7 @@ let rec components_of_module_maker
                         add_to_tbl descr.lbl_name descr c.comp_labels)
                     lbls;
                   Type_record (lbls, repr)
-              | Type_abstract -> Type_abstract
+              | Type_abstract r -> Type_abstract r
               | Type_open -> Type_open
             in
             let shape = Shape.proj cm_shape (Shape.Item.type_ id) in
@@ -2089,7 +2089,7 @@ and store_type ~check id info shape env =
           (fun env (lbl_id, lbl) ->
             store_label ~check info id lbl_id lbl env)
           env labels
-    | Type_abstract -> Type_abstract, env
+    | Type_abstract r -> Type_abstract r, env
     | Type_open -> Type_open, env
   in
   let tda =
@@ -2111,7 +2111,7 @@ and store_type_infos ~tda_shape id info env =
   let tda =
     {
       tda_declaration = info;
-      tda_descriptions = Type_abstract;
+      tda_descriptions = Type_abstract Abstract_def;
       tda_shape
     }
   in
@@ -3367,7 +3367,7 @@ let lookup_label ~errors ~use ~loc usage lid env =
 let lookup_all_labels_from_type ~use ~loc usage ty_path env =
   match find_type_descrs ty_path env with
   | exception Not_found -> []
-  | Type_variant _ | Type_abstract | Type_open -> []
+  | Type_variant _ | Type_abstract _ | Type_open -> []
   | Type_record (lbls, _) ->
       List.map
         (fun lbl ->
@@ -3389,7 +3389,7 @@ let lookup_constructor ~errors ~use ~loc usage lid env =
 let lookup_all_constructors_from_type ~use ~loc usage ty_path env =
   match find_type_descrs ty_path env with
   | exception Not_found -> []
-  | Type_record _ | Type_abstract | Type_open -> []
+  | Type_record _ | Type_abstract _ | Type_open -> []
   | Type_variant (cstrs, _) ->
       List.map
         (fun cstr ->

typing/includecore.ml

@@ -812,7 +812,7 @@ let privacy_mismatch env decl1 decl2 =
       | Type_record  _, Type_record  _ -> Some Private_record_type
       | Type_variant _, Type_variant _ -> Some Private_variant_type
       | Type_open,      Type_open      -> Some Private_extensible_variant
-      | Type_abstract, Type_abstract
+      | Type_abstract _, Type_abstract _
         when Option.is_some decl2.type_manifest -> begin
           match decl1.type_manifest with
           | Some ty1 -> begin
@@ -949,7 +949,7 @@ let type_manifest env ty1 params1 ty2 params2 priv2 kind2 =
   | _ -> begin
       let is_private_abbrev_2 =
         match priv2, kind2 with
-        | Private, Type_abstract -> begin
+        | Private, Type_abstract _ -> begin
             (* Same checks as the [when] guards from above, inverted *)
             match get_desc ty2' with
             | Tvariant row ->
@@ -1008,7 +1008,7 @@ let type_declarations ?(equality = false) ~loc env ~mark name
   in
   if err <> None then err else
   let err = match (decl1.type_kind, decl2.type_kind) with
-      (_, Type_abstract) ->
+      (_, Type_abstract _) ->
        (* Note that [decl2.type_layout] is an upper bound.
           If it isn't tight, [decl2] must
           have a manifest, which we're already checking for equality
@@ -1056,7 +1056,7 @@ let type_declarations ?(equality = false) ~loc env ~mark name
     | (_, _) -> Some Kind
   in
   if err <> None then err else
-  let abstr = decl_is_abstract decl2 && decl2.type_manifest = None in
+  let abstr = Btype.type_kind_is_abstract decl2 && decl2.type_manifest = None in
   let need_variance =
     abstr || decl1.type_private = Private || decl1.type_kind = Type_open in
   if not need_variance then None else

typing/mtype.ml

@@ -84,7 +84,7 @@ and strengthen_lazy_sig' ~aliasable sg p =
     [] -> []
   | (Sig_value(_, _, _) as sigelt) :: rem ->
       sigelt :: strengthen_lazy_sig' ~aliasable rem p
-  | Sig_type(id, {type_kind=Type_abstract}, _, _) :: rem
+  | Sig_type(id, {type_kind=Type_abstract _}, _, _) :: rem
     when Btype.is_row_name (Ident.name id) ->
       strengthen_lazy_sig' ~aliasable rem p
   | Sig_type(id, decl, rs, vis) :: rem ->
@@ -96,7 +96,7 @@ and strengthen_lazy_sig' ~aliasable sg p =
             let manif =
               Some(Btype.newgenty(Tconstr(Pdot(p, Ident.name id),
                                           decl.type_params, ref Mnil))) in
-            if decl_is_abstract decl then
+            if Btype.type_kind_is_abstract decl then
               { decl with type_private = Public; type_manifest = manif }
             else
               { decl with type_manifest = manif }
@@ -304,7 +304,7 @@ let rec sig_make_manifest sg =
           Some (Btype.newgenty(Tconstr(Pident id, decl.type_params, ref Mnil)))
         in
         match decl.type_kind with
-        | Type_abstract ->
+        | Type_abstract _ ->
           { decl with type_private = Public; type_manifest = manif }
         | (Type_record _ | Type_variant _ | Type_open) ->
           { decl with type_manifest = manif }
@@ -632,7 +632,7 @@ and contains_type_sig env = List.iter (contains_type_item env)
 
 and contains_type_item env = function
     Sig_type (_,({type_manifest = None} |
-                 {type_kind = Type_abstract; type_private = Private}),_, _)
+                 {type_kind = Type_abstract _; type_private = Private}),_, _)
   | Sig_modtype _
   | Sig_typext (_, {ext_args = Cstr_record _}, _, _) ->
       (* We consider that extension constructors with an inlined

typing/parmatch.ml

@@ -850,7 +850,7 @@ let pats_of_type ?(always=false) env ty =
               labels
           in
           [make_pat (Tpat_record (fields, Closed)) ty env]
-      | Type_variant _ | Type_abstract | Type_open -> [omega]
+      | Type_variant _ | Type_abstract _ | Type_open -> [omega]
       end
   | Ttuple tl ->
       [make_pat (Tpat_tuple (omegas (List.length tl))) ty env]

typing/predef.ml

@@ -165,7 +165,7 @@ and ident_some = ident_create "Some"
 
 let mk_add_type add_type
       ?manifest type_ident
-      ?(kind=Type_abstract)
+      ?(kind=Type_abstract Abstract_def)
       ?(layout=Layout.value ~why:(Primitive type_ident))
       env =
   let decl =
@@ -192,7 +192,7 @@ let mk_add_type add_type
 let common_initial_env add_type add_extension empty_env =
   let add_type = mk_add_type add_type
   and add_type1 type_ident
-        ?(kind=fun _ -> Type_abstract)
+        ?(kind=fun _ -> Type_abstract Abstract_def)
         ?(layout=Layout.value ~why:(Primitive type_ident))
       ~variance ~separability env =
     let param = newgenvar (Layout.value ~why:Type_argument) in