diff --git a/typing/typedecl.ml b/typing/typedecl.ml index a175ddc306..5187a80165 100644 --- a/typing/typedecl.ml +++ b/typing/typedecl.ml @@ -3733,10 +3733,10 @@ let transl_with_constraint id ?fixed_row_path ~sig_env ~sig_decl ~outer_env let type_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in let type_unboxed_version = match get_desc man with - | Tconstr (path, _, _) -> + | Tconstr (path, args, _) -> begin match Env.find_type path outer_env with | { type_unboxed_version = Some decl ; _ } -> - let man = Ctype.newconstr (Path.unboxed_version path) params in + let man = Ctype.newconstr (Path.unboxed_version path) args in let type_kind = match sig_decl.type_unboxed_version, arity_ok with | Some { type_kind ; _ }, true -> type_kind @@ -3808,9 +3808,10 @@ let transl_with_constraint id ?fixed_row_path ~sig_env ~sig_decl ~outer_env end; let new_sig_decl = name_recursion sdecl id new_sig_decl in let new_type_variance = - let required = Typedecl_variance.variance_of_sdecl sdecl in + let required = Typedecl_variance.variance_of_params sdecl.ptype_params in try - Typedecl_variance.compute_decl env ~check:(Some id) new_sig_decl required + Typedecl_variance.compute_decl env ~check:(Some (id, false)) new_sig_decl + required with Typedecl_variance.Error (loc, err) -> raise (Error (loc, Variance err)) in let new_type_separability = @@ -3835,18 +3836,36 @@ let transl_with_constraint id ?fixed_row_path ~sig_env ~sig_decl ~outer_env type_loc = new_sig_decl.type_loc; type_attributes = new_sig_decl.type_attributes; type_uid = new_sig_decl.type_uid; + type_is_unboxed_version = new_sig_decl.type_is_unboxed_version; + (* For every recomputed field added below, consider if we also must + recompute it for the unboxed version. *) type_variance = new_type_variance; type_separability = new_type_separability; type_has_illegal_crossings = false; type_unboxed_version = - Option.map (fun d -> { - d with - type_variance = new_type_variance; - type_separability = new_type_separability; - }) new_sig_decl.type_unboxed_version - ; - type_is_unboxed_version = new_sig_decl.type_is_unboxed_version; + Option.map (fun d -> + let type_variance = + let required = + Typedecl_variance.variance_of_params sdecl.ptype_params in + try + Typedecl_variance.compute_decl env ~check:(Some (id, true)) + d required + with Typedecl_variance.Error (loc, err) -> + raise (Error (loc, Variance err)) + in + let type_separability = + try + Typedecl_separability.compute_decl env d + with Typedecl_separability.Error (loc, err) -> + raise (Error (loc, Separability err)) + in + { + d with + type_variance; + type_separability; + }) + new_sig_decl.type_unboxed_version } in { typ_id = id; @@ -4265,12 +4284,22 @@ let report_error ppf = function Printtyp.prepare_for_printing [ variable ]; Printtyp.Naming_context.reset (); begin match context with - | Type_declaration (id, decl) -> + | Type_declaration { id ; decl ; unboxed_version } -> + let pre, post = + if unboxed_version then + (* Unexpected; errors in the unboxed version should have also + been present and reported first for the boxed version. *) + "In the unboxed version of the definition", + "@ Please report this error to the Jane Street compilers team." + else + "In the definition", "" + in Printtyp.add_type_declaration_to_preparation id decl; - fprintf ppf "@[%s@;<1 2>%a@;" - "In the definition" + fprintf ppf "@[%s@;<1 2>%a@;%s" + pre (Style.as_inline_code @@ Printtyp.prepared_type_declaration id) decl + post | Gadt_constructor c -> Printtyp.add_constructor_to_preparation c; fprintf ppf "@[%s@;<1 2>%a@;" diff --git a/typing/typedecl_properties.ml b/typing/typedecl_properties.ml index 28a1bb6673..a85c30b567 100644 --- a/typing/typedecl_properties.ml +++ b/typing/typedecl_properties.ml @@ -24,7 +24,7 @@ type ('prop, 'req) property = { compute : Env.t -> decl -> 'req -> 'prop; update_decl : decl -> 'prop -> decl; - check : Env.t -> Ident.t -> decl -> 'req -> unit; + check : Env.t -> Ident.t -> decl -> 'req * 'req option -> unit; } let add_type ~check id decl env = @@ -39,25 +39,43 @@ let add_types_to_env decls env = let compute_property : ('prop, 'req) property -> Env.t -> - (Ident.t * decl) list -> 'req list -> (Ident.t * decl) list + (Ident.t * decl) list -> ('req * 'req option) list -> (Ident.t * decl) list = fun property env decls required -> (* [decls] and [required] must be lists of the same size, with [required] containing the requirement for the corresponding declaration in [decls]. *) - let props = List.map (fun (_id, decl) -> property.default decl) decls in + let props = + List.map (fun (_id, (decl : decl)) -> + property.default decl, + Option.map (fun d -> property.default d) decl.type_unboxed_version) + decls + in let rec compute_fixpoint props = let new_decls = - List.map2 (fun (id, decl) prop -> - (id, property.update_decl decl prop)) + List.map2 (fun (id, (decl : decl)) (prop, prop_u) -> + let type_unboxed_version = Option.map (fun d -> + property.update_decl d (Option.get prop_u)) + decl.type_unboxed_version + in + (id, { (property.update_decl decl prop) with type_unboxed_version })) decls props in let new_env = add_types_to_env new_decls env in + let update_prop decl prop req = + property.merge ~prop ~new_prop:(property.compute new_env decl req) + in let new_props = List.map2 - (fun (_id, decl) (prop, req) -> - let new_prop = property.compute new_env decl req in - property.merge ~prop ~new_prop) + (fun (_id, (decl : decl)) ((prop, prop_u), (req, req_u)) -> + update_prop decl prop req, + Option.map (fun d -> + update_prop d (Option.get prop_u) (Option.get req_u)) + decl.type_unboxed_version) new_decls (List.combine props required) in - if not (List.for_all2 property.eq props new_props) + if not (List.for_all2 + (fun (prop, prop_u) (prop', prop_u') -> + property.eq prop prop' + && Option.equal property.eq prop_u prop_u') + props new_props) then compute_fixpoint new_props else begin List.iter2 @@ -69,5 +87,8 @@ let compute_property compute_fixpoint props let compute_property_noreq property env decls = - let req = List.map (fun _ -> ()) decls in + let req = List.map + (fun (_, (d : decl)) -> (), Option.map (fun _ -> ()) d.type_unboxed_version) + decls + in compute_property property env decls req diff --git a/typing/typedecl_properties.mli b/typing/typedecl_properties.mli index 153c3f719c..a121b2bc6a 100644 --- a/typing/typedecl_properties.mli +++ b/typing/typedecl_properties.mli @@ -31,7 +31,7 @@ type ('prop, 'req) property = { compute : Env.t -> decl -> 'req -> 'prop; update_decl : decl -> 'prop -> decl; - check : Env.t -> Ident.t -> decl -> 'req -> unit; + check : Env.t -> Ident.t -> decl -> 'req * 'req option -> unit; } (** ['prop] represents the type of property values ({!Types.Variance.t}, just 'bool' for immediacy, etc). @@ -49,7 +49,7 @@ type ('prop, 'req) property = { type declarations. The [req] argument must be a list of the same size as [decls], providing the user requirement for each declaration. *) val compute_property : ('prop, 'req) property -> Env.t -> - (Ident.t * decl) list -> 'req list -> (Ident.t * decl) list + (Ident.t * decl) list -> ('req * 'req option) list -> (Ident.t * decl) list val compute_property_noreq : ('prop, unit) property -> Env.t -> (Ident.t * decl) list -> (Ident.t * decl) list diff --git a/typing/typedecl_separability.ml b/typing/typedecl_separability.ml index 829a4573cc..ea1211cf7e 100644 --- a/typing/typedecl_separability.ml +++ b/typing/typedecl_separability.ml @@ -672,7 +672,7 @@ let property : (prop, unit) Typedecl_properties.property = let default decl = best_msig decl in let compute env decl () = compute_decl env decl in let update_decl decl type_separability = { decl with type_separability } in - let check _env _id _decl () = () in (* FIXME run final check? *) + let check _env _id _decl _req = () in (* FIXME run final check? *) { eq; merge; default; compute; update_decl; check; } (* Definition using the fixpoint infrastructure. *) diff --git a/typing/typedecl_variance.ml b/typing/typedecl_variance.ml index 54dcb11b2b..ef62fe5c41 100644 --- a/typing/typedecl_variance.ml +++ b/typing/typedecl_variance.ml @@ -23,7 +23,11 @@ module TypeMap = Btype.TypeMap type surface_variance = bool * bool * bool type variance_variable_context = - | Type_declaration of Ident.t * type_declaration + | Type_declaration of { + id: Ident.t; + decl: type_declaration; + unboxed_version : bool + } | Gadt_constructor of constructor_declaration | Extension_constructor of Ident.t * extension_constructor @@ -309,7 +313,10 @@ let compute_variance_gadt_constructor env ~check rloc decl tl = let compute_variance_decl env ~check decl (required, _ as rloc) = let check = - Option.map (fun id -> Type_declaration (id, decl)) check + Option.map + (fun (id, unboxed_version) -> + Type_declaration {id; decl; unboxed_version}) + check in let abstract = Btype.type_kind_is_abstract decl in if (abstract || decl.type_kind = Type_open) && decl.type_manifest = None then @@ -376,8 +383,8 @@ let check_variance_extension env decl ext rloc = let compute_decl env ~check decl req = compute_variance_decl env ~check decl (req, decl.type_loc) -let check_decl env id decl req = - ignore (compute_variance_decl env ~check:(Some id) decl (req, decl.type_loc)) +let check_decl env check decl req = + ignore (compute_variance_decl env ~check decl (req, decl.type_loc)) type prop = Variance.t list type req = surface_variance list @@ -393,8 +400,14 @@ let property : (prop, req) Typedecl_properties.property = compute_decl env ~check:None decl req in let update_decl decl variance = { decl with type_variance = variance } in - let check env id decl req = - if is_hash id then () else check_decl env id decl req in + let check env id decl (req, req') = + if is_hash id then () else begin + check_decl env (Some (id, false)) decl req; + Option.iter (fun d -> + check_decl env (Some (id, true)) d (Option.get req')) + decl.type_unboxed_version + end + in { eq; merge; @@ -416,11 +429,12 @@ let transl_variance (v, i) = let variance_of_params ptype_params = List.map transl_variance (List.map snd ptype_params) -let variance_of_sdecl sdecl = - variance_of_params sdecl.Parsetree.ptype_params - let update_decls env sdecls decls = - let required = List.map variance_of_sdecl sdecls in + let required = List.map2 (fun sdecl (_, decl) -> + let variance = variance_of_params sdecl.Parsetree.ptype_params in + variance, Option.map (fun _ -> variance) decl.type_unboxed_version) + sdecls decls + in Typedecl_properties.compute_property property env decls required let update_class_decls env cldecls = @@ -428,7 +442,7 @@ let update_class_decls env cldecls = List.fold_right (fun (obj_id, obj_abbr, _clty, _cltydef, ci) (decls, req) -> (obj_id, obj_abbr) :: decls, - variance_of_params ci.Typedtree.ci_params :: req) + (variance_of_params ci.Typedtree.ci_params, None) :: req) cldecls ([],[]) in let decls = diff --git a/typing/typedecl_variance.mli b/typing/typedecl_variance.mli index 6392e61dd1..0b29e62050 100644 --- a/typing/typedecl_variance.mli +++ b/typing/typedecl_variance.mli @@ -22,15 +22,17 @@ type surface_variance = bool * bool * bool val variance_of_params : (Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list -> surface_variance list -val variance_of_sdecl : - Parsetree.type_declaration -> surface_variance list type prop = Variance.t list type req = surface_variance list val property : (Variance.t list, req) property type variance_variable_context = - | Type_declaration of Ident.t * type_declaration + | Type_declaration of { + id: Ident.t; + decl: type_declaration; + unboxed_version : bool + } | Gadt_constructor of constructor_declaration | Extension_constructor of Ident.t * extension_constructor @@ -58,7 +60,9 @@ val check_variance_extension : Typedtree.extension_constructor -> req * Location.t -> unit val compute_decl : - Env.t -> check:Ident.t option -> type_declaration -> req -> prop + Env.t -> check:(Ident.t * bool) option -> + type_declaration -> req -> Variance.t list +(* [check] is the decl ident and whether it's the unboxed version *) val update_decls : Env.t -> Parsetree.type_declaration list ->