Properly compute properties for unboxed versions

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 "@[<v>%s@;<1 2>%a@;"
-                 "In the definition"
+               fprintf ppf "@[<v>%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 "@[<v>%s@;<1 2>%a@;"

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

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

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. *)

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,19 +429,20 @@ 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 =
   let decls, required =
     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 =

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 ->