Add support for [@@immediate64]

Signed-off-by: Jeremie Dimino <jeremie@dimino.org>

.depend

@@ -439,6 +439,7 @@ typing/btype.cmi : \
     parsing/asttypes.cmi
 typing/ctype.cmo : \
     typing/types.cmi \
+    typing/type_immediacy.cmi \
     typing/subst.cmi \
     typing/predef.cmi \
     typing/path.cmi \
@@ -453,6 +454,7 @@ typing/ctype.cmo : \
     typing/ctype.cmi
 typing/ctype.cmx : \
     typing/types.cmx \
+    typing/type_immediacy.cmx \
     typing/subst.cmx \
     typing/predef.cmx \
     typing/path.cmx \
@@ -467,6 +469,7 @@ typing/ctype.cmx : \
     typing/ctype.cmi
 typing/ctype.cmi : \
     typing/types.cmi \
+    typing/type_immediacy.cmi \
     typing/path.cmi \
     parsing/longident.cmi \
     typing/ident.cmi \
@@ -596,6 +599,7 @@ typing/includeclass.cmi : \
 typing/includecore.cmo : \
     typing/types.cmi \
     typing/typedtree.cmi \
+    typing/type_immediacy.cmi \
     typing/printtyp.cmi \
     typing/path.cmi \
     typing/ident.cmi \
@@ -608,6 +612,7 @@ typing/includecore.cmo : \
 typing/includecore.cmx : \
     typing/types.cmx \
     typing/typedtree.cmx \
+    typing/type_immediacy.cmx \
     typing/printtyp.cmx \
     typing/path.cmx \
     typing/ident.cmx \
@@ -620,6 +625,7 @@ typing/includecore.cmx : \
 typing/includecore.cmi : \
     typing/types.cmi \
     typing/typedtree.cmi \
+    typing/type_immediacy.cmi \
     typing/path.cmi \
     parsing/location.cmi \
     typing/ident.cmi \
@@ -718,6 +724,7 @@ typing/oprint.cmx : \
 typing/oprint.cmi : \
     typing/outcometree.cmi
 typing/outcometree.cmi : \
+    typing/type_immediacy.cmi \
     parsing/asttypes.cmi
 typing/parmatch.cmo : \
     utils/warnings.cmi \
@@ -864,6 +871,7 @@ typing/printpat.cmi : \
 typing/printtyp.cmo : \
     utils/warnings.cmi \
     typing/types.cmi \
+    typing/type_immediacy.cmi \
     typing/primitive.cmi \
     typing/predef.cmi \
     typing/path.cmi \
@@ -877,13 +885,13 @@ typing/printtyp.cmo : \
     typing/env.cmi \
     typing/ctype.cmi \
     utils/clflags.cmi \
-    parsing/builtin_attributes.cmi \
     typing/btype.cmi \
     parsing/asttypes.cmi \
     typing/printtyp.cmi
 typing/printtyp.cmx : \
     utils/warnings.cmx \
     typing/types.cmx \
+    typing/type_immediacy.cmx \
     typing/primitive.cmx \
     typing/predef.cmx \
     typing/path.cmx \
@@ -897,7 +905,6 @@ typing/printtyp.cmx : \
     typing/env.cmx \
     typing/ctype.cmx \
     utils/clflags.cmx \
-    parsing/builtin_attributes.cmx \
     typing/btype.cmx \
     parsing/asttypes.cmi \
     typing/printtyp.cmi
@@ -1032,6 +1039,14 @@ typing/tast_mapper.cmi : \
     typing/typedtree.cmi \
     typing/env.cmi \
     parsing/asttypes.cmi
+typing/type_immediacy.cmo : \
+    parsing/builtin_attributes.cmi \
+    typing/type_immediacy.cmi
+typing/type_immediacy.cmx : \
+    parsing/builtin_attributes.cmx \
+    typing/type_immediacy.cmi
+typing/type_immediacy.cmi : \
+    parsing/parsetree.cmi
 typing/typeclass.cmo : \
     utils/warnings.cmi \
     typing/typetexp.cmi \
@@ -1260,21 +1275,22 @@ typing/typedecl_immediacy.cmo : \
     typing/types.cmi \
     typing/typedecl_unboxed.cmi \
     typing/typedecl_properties.cmi \
+    typing/type_immediacy.cmi \
     parsing/location.cmi \
     typing/ctype.cmi \
-    parsing/builtin_attributes.cmi \
     typing/typedecl_immediacy.cmi
 typing/typedecl_immediacy.cmx : \
     typing/types.cmx \
     typing/typedecl_unboxed.cmx \
     typing/typedecl_properties.cmx \
+    typing/type_immediacy.cmx \
     parsing/location.cmx \
     typing/ctype.cmx \
-    parsing/builtin_attributes.cmx \
     typing/typedecl_immediacy.cmi
 typing/typedecl_immediacy.cmi : \
     typing/types.cmi \
     typing/typedecl_properties.cmi \
+    typing/type_immediacy.cmi \
     parsing/location.cmi \
     typing/ident.cmi \
     typing/env.cmi
@@ -1483,6 +1499,7 @@ typing/typeopt.cmi : \
     lambda/lambda.cmi \
     typing/env.cmi
 typing/types.cmo : \
+    typing/type_immediacy.cmi \
     typing/primitive.cmi \
     typing/path.cmi \
     parsing/parsetree.cmi \
@@ -1493,6 +1510,7 @@ typing/types.cmo : \
     parsing/asttypes.cmi \
     typing/types.cmi
 typing/types.cmx : \
+    typing/type_immediacy.cmx \
     typing/primitive.cmx \
     typing/path.cmx \
     parsing/parsetree.cmi \
@@ -1503,6 +1521,7 @@ typing/types.cmx : \
     parsing/asttypes.cmi \
     typing/types.cmi
 typing/types.cmi : \
+    typing/type_immediacy.cmi \
     typing/primitive.cmi \
     typing/path.cmi \
     parsing/parsetree.cmi \
@@ -4759,6 +4778,8 @@ middle_end/flambda/invariant_params.cmi : \
 middle_end/flambda/lift_code.cmo : \
     middle_end/variable.cmi \
     utils/strongly_connected_components.cmi \
+    middle_end/flambda/base_types/mutable_variable.cmi \
+    lambda/lambda.cmi \
     utils/int_replace_polymorphic_compare.cmi \
     middle_end/flambda/flambda_iterators.cmi \
     middle_end/flambda/flambda.cmi \
@@ -4767,6 +4788,8 @@ middle_end/flambda/lift_code.cmo : \
 middle_end/flambda/lift_code.cmx : \
     middle_end/variable.cmx \
     utils/strongly_connected_components.cmx \
+    middle_end/flambda/base_types/mutable_variable.cmx \
+    lambda/lambda.cmx \
     utils/int_replace_polymorphic_compare.cmx \
     middle_end/flambda/flambda_iterators.cmx \
     middle_end/flambda/flambda.cmx \

Changes

@@ -92,6 +92,10 @@ Working version
 - #8919: lift mutable lets along with immutable ones
   (Leo White, review by Pierre Chambart)
 
+- #8806: Add an [@@immediate64] attribute for types that are known to
+  be immediate only on 64 bit platforms
+  (Jérémie Dimino, review by Vladimir Keleshev)
+
 ### Runtime system:
 
 - #8619: Ensure Gc.minor_words remains accurate after a GC.

Makefile

@@ -94,7 +94,7 @@ PARSING=parsing/location.cmo parsing/longident.cmo \
   parsing/builtin_attributes.cmo parsing/ast_invariants.cmo parsing/depend.cmo
 
 TYPING=typing/ident.cmo typing/path.cmo \
-  typing/primitive.cmo typing/types.cmo \
+  typing/primitive.cmo typing/type_immediacy.cmo typing/types.cmo \
   typing/btype.cmo typing/oprint.cmo \
   typing/subst.cmo typing/predef.cmo \
   typing/datarepr.cmo file_formats/cmi_format.cmo \

debugger/Makefile

@@ -47,8 +47,8 @@ parsing_modules := $(addprefix parsing/,\
   attr_helper builtin_attributes pprintast)
 
 typing_modules := $(addprefix typing/,\
-  ident path types btype primitive typedtree subst predef datarepr \
+  ident path type_immediacy types btype primitive typedtree subst predef \
-  persistent_env env oprint ctype printtyp mtype envaux)
+  datarepr persistent_env env oprint ctype printtyp mtype envaux)
 
 file_formats_modules := $(addprefix file_formats/,\
   cmi_format)

manual/manual/refman/exten.etex

@@ -1582,6 +1582,11 @@ Some attributes are understood by the type-checker:
   enumerated types). Mutation of these immediate types does not activate the
   garbage collector's write barrier, which can significantly boost performance in
   programs relying heavily on mutable state.
+\item
+  ``ocaml.immediate64'' or ``immediate64'' applied on an abstract type mark the
+  type as having a non-pointer implementation on 64 bit platforms. No assumption
+  is made on other platforms. In order to produce a type with the
+  ``immediate64`` attribute, one must use ``Sys.Immediate64.Make`` functor.
 \item
   "ocaml.unboxed" or "unboxed" can be used on a type definition if the
   type is a single-field record or a concrete type with a single
@@ -1679,6 +1684,32 @@ end = struct
 end
 \end{caml_example*}
 
+\begin{caml_example*}{verbatim}
+module Int_or_int64 : sig
+  type t [@@immediate64]
+  val zero : t
+  val one : t
+  val add : t -> t -> t
+end = struct
+
+  include Sys.Immediate64.Make(Int)(Int64)
+
+  module type S = sig
+    val zero : t
+    val one : t
+    val add : t -> t -> t
+  end
+
+  let impl : (module S) =
+    match repr with
+    | Immediate ->
+        (module Int : S)
+    | Non_immediate ->
+        (module Int64 : S)
+
+  include (val impl : S)
+end
+\end{caml_example*}
 
 \section{Extension nodes}\label{s:extension-nodes}
 

otherlibs/dynlink/Makefile

@@ -98,6 +98,7 @@ COMPILERLIBS_SOURCES=\
   typing/ident.ml \
   typing/path.ml \
   typing/primitive.ml \
+  typing/type_immediacy.ml \
   typing/types.ml \
   typing/btype.ml \
   typing/subst.ml \

parsing/builtin_attributes.ml

@@ -262,6 +262,13 @@ let immediate =
        | _ -> false
     )
 
+let immediate64 =
+  List.exists
+    (fun a -> match a.attr_name.txt with
+       | "ocaml.immediate64"|"immediate64" -> true
+       | _ -> false
+    )
+
 (* The "ocaml.boxed (default)" and "ocaml.unboxed (default)"
    attributes cannot be input by the user, they are added by the
    compiler when applying the default setting. This is done to record

parsing/builtin_attributes.mli

@@ -25,6 +25,7 @@
     - ocaml.warn_on_literal_pattern
     - ocaml.deprecated_mutable
     - ocaml.immediate
+    - ocaml.immediate64
     - ocaml.boxed / ocaml.unboxed
 
     {b Warning:} this module is unstable and part of
@@ -77,6 +78,7 @@ val explicit_arity: Parsetree.attributes -> bool
 
 
 val immediate: Parsetree.attributes -> bool
+val immediate64: Parsetree.attributes -> bool
 
 val has_unboxed: Parsetree.attributes -> bool
 val has_boxed: Parsetree.attributes -> bool

stdlib/sys.mli

@@ -357,3 +357,28 @@ external opaque_identity : 'a -> 'a = "%opaque"
 
     @since 4.03.0
 *)
+
+module Immediate64 : sig
+  (** This module allows to define a type [t] with the [immediate64]
+      attribute. This attribute means that the type is immediate on 64
+      bit architectures. On other architectures, it might or might not
+      be immediate.
+
+      @since 4.10.0
+  *)
+
+  module type Non_immediate = sig
+    type t
+  end
+  module type Immediate = sig
+    type t [@@immediate]
+  end
+
+  module Make(Immediate : Immediate)(Non_immediate : Non_immediate) : sig
+    type t [@@immediate64]
+    type 'a repr =
+      | Immediate : Immediate.t repr
+      | Non_immediate : Non_immediate.t repr
+    val repr : t repr
+  end
+end

stdlib/sys.mlp

@@ -131,3 +131,25 @@ let ocaml_version = "%%VERSION%%"
 (* Optimization *)
 
 external opaque_identity : 'a -> 'a = "%opaque"
+
+module Immediate64 = struct
+  module type Non_immediate = sig
+    type t
+  end
+  module type Immediate = sig
+    type t [@@immediate]
+  end
+
+  module Make(Immediate : Immediate)(Non_immediate : Non_immediate) = struct
+    type t [@@immediate64]
+    type 'a repr =
+      | Immediate : Immediate.t repr
+      | Non_immediate : Non_immediate.t repr
+    external magic : _ repr -> t repr = "%identity"
+    let repr =
+      if word_size = 64 then
+        magic Immediate
+      else
+        magic Non_immediate
+  end
+end

testsuite/tests/lib-sys/immediate64.ml

@@ -0,0 +1,32 @@
+(* TEST
+*)
+
+module M : sig
+  type t [@@immediate64]
+  val zero : t
+  val one : t
+  val add : t -> t -> t
+end = struct
+
+  include Sys.Immediate64.Make(Int)(Int64)
+
+  module type S = sig
+    val zero : t
+    val one : t
+    val add : t -> t -> t
+  end
+
+  let impl : (module S) =
+    match repr with
+    | Immediate ->
+        (module Int : S)
+    | Non_immediate ->
+        (module Int64 : S)
+
+  include (val impl : S)
+end
+
+let () =
+  match Sys.word_size with
+  | 64 -> assert (Obj.is_int (Obj.repr M.zero))
+  | _  -> assert (Obj.is_block (Obj.repr M.zero))

testsuite/tests/lib-sys/ocamltests

@@ -1 +1,2 @@
 rename.ml
+immediate64.ml

testsuite/tests/typing-immediate/immediate.ml

@@ -109,8 +109,8 @@ end;;
 Line 2, characters 2-31:
 2 |   type t = string [@@immediate]
       ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: Types marked with the immediate attribute must be
+Error: Types marked with the immediate attribute must be non-pointer types
-       non-pointer types like int or bool
+       like int or bool.
 |}];;
 
 (* Not guaranteed that t is immediate, so this is an invalid declaration *)
@@ -122,8 +122,8 @@ end;;
 Line 3, characters 2-26:
 3 |   type s = t [@@immediate]
       ^^^^^^^^^^^^^^^^^^^^^^^^
-Error: Types marked with the immediate attribute must be
+Error: Types marked with the immediate attribute must be non-pointer types
-       non-pointer types like int or bool
+       like int or bool.
 |}];;
 
 (* Can't ascribe to an immediate type signature with a non-immediate type *)
@@ -172,6 +172,6 @@ end;;
 Line 2, characters 2-26:
 2 |   type t = s [@@immediate]
       ^^^^^^^^^^^^^^^^^^^^^^^^
-Error: Types marked with the immediate attribute must be
+Error: Types marked with the immediate attribute must be non-pointer types
-       non-pointer types like int or bool
+       like int or bool.
 |}];;

typing/ctype.ml

@@ -1230,7 +1230,7 @@ let new_declaration expansion_scope manifest =
     type_expansion_scope = expansion_scope;
     type_loc = Location.none;
     type_attributes = [];
-    type_immediate = false;
+    type_immediate = Unknown;
     type_unboxed = unboxed_false_default_false;
   }
 
@@ -4772,13 +4772,21 @@ let same_constr env t1 t2 =
 let () =
   Env.same_constr := same_constr
 
-let maybe_pointer_type env typ =
+let is_immediate = function
+  | Type_immediacy.Unknown -> false
+  | Type_immediacy.Always -> true
+  | Type_immediacy.Always_on_64bits ->
+      (* In bytecode, we don't know at compile time whether we are
+         targeting 32 or 64 bits. *)
+      !Clflags.native_code && Sys.word_size = 64
+
+let immediacy env typ =
    match (repr typ).desc with
   | Tconstr(p, _args, _abbrev) ->
     begin try
       let type_decl = Env.find_type p env in
-      not type_decl.type_immediate
+      type_decl.type_immediate
-    with Not_found -> true
+    with Not_found -> Type_immediacy.Unknown
     (* This can happen due to e.g. missing -I options,
        causing some .cmi files to be unavailable.
        Maybe we should emit a warning. *)
@@ -4786,10 +4794,17 @@ let maybe_pointer_type env typ =
   | Tvariant row ->
       let row = Btype.row_repr row in
       (* if all labels are devoid of arguments, not a pointer *)
-      not row.row_closed
+      if
-      || List.exists
+        not row.row_closed
+        || List.exists
           (function
             | _, (Rpresent (Some _) | Reither (false, _, _, _)) -> true
             | _ -> false)
           row.row_fields
-  | _ -> true
+      then
+        Type_immediacy.Unknown
+      else
+        Type_immediacy.Always
+  | _ -> Type_immediacy.Unknown
+
+let maybe_pointer_type env typ = not (is_immediate (immediacy env typ))

typing/ctype.mli

@@ -359,6 +359,8 @@ val get_current_level: unit -> int
 val wrap_trace_gadt_instances: Env.t -> ('a -> 'b) -> 'a -> 'b
 val reset_reified_var_counter: unit -> unit
 
+val immediacy : Env.t -> type_expr -> Type_immediacy.t
+
 val maybe_pointer_type : Env.t -> type_expr -> bool
        (* True if type is possibly pointer, false if definitely not a pointer *)
 

typing/datarepr.ml

@@ -89,7 +89,7 @@ let constructor_args priv cd_args cd_res path rep =
           type_expansion_scope = Btype.lowest_level;
           type_loc = Location.none;
           type_attributes = [];
-          type_immediate = false;
+          type_immediate = Unknown;
           type_unboxed;
         }
       in

typing/includecore.ml

@@ -177,7 +177,7 @@ type type_mismatch =
   | Record_mismatch of record_mismatch
   | Variant_mismatch of variant_mismatch
   | Unboxed_representation of position
-  | Immediate
+  | Immediate of Type_immediacy.Violation.t
 
 let report_label_mismatch first second ppf err =
   let pr fmt = Format.fprintf ppf fmt in
@@ -267,8 +267,14 @@ let report_type_mismatch0 first second decl ppf err =
       pr "Their internal representations differ:@ %s %s %s."
          (choose ord first second) decl
          "uses unboxed representation"
-  | Immediate -> pr "%s is not an immediate type."
+  | Immediate violation ->
-                   (StringLabels.capitalize_ascii first)
+      let first = StringLabels.capitalize_ascii first in
+      match violation with
+      | Type_immediacy.Violation.Not_always_immediate ->
+          pr "%s is not an immediate type." first
+      | Type_immediacy.Violation.Not_always_immediate_on_64bits ->
+          pr "%s is not a type that is always immediate on 64 bit platforms."
+            first
 
 let report_type_mismatch first second decl ppf err =
   if err = Manifest then () else
@@ -444,11 +450,14 @@ let type_declarations ?(equality = false) ~loc env ~mark name
   (* If attempt to assign a non-immediate type (e.g. string) to a type that
    * must be immediate, then we error *)
   let err =
-    if abstr &&
+    if not abstr then
-       not decl1.type_immediate &&
+      None
-       decl2.type_immediate then
+    else
-      Some Immediate
+      match
-    else None
+        Type_immediacy.coerce decl1.type_immediate ~as_:decl2.type_immediate
+      with
+      | Ok () -> None
+      | Error violation -> Some (Immediate violation)
   in
   if err <> None then err else
   let need_variance =

typing/includecore.mli

@@ -63,7 +63,7 @@ type type_mismatch =
   | Record_mismatch of record_mismatch
   | Variant_mismatch of variant_mismatch
   | Unboxed_representation of position
-  | Immediate
+  | Immediate of Type_immediacy.Violation.t
 
 val value_descriptions:
   loc:Location.t -> Env.t -> string ->

typing/oprint.ml

@@ -654,7 +654,10 @@ and print_out_type_decl kwd ppf td =
   | Asttypes.Public -> ()
   in
   let print_immediate ppf =
-    if td.otype_immediate then fprintf ppf " [%@%@immediate]" else ()
+    match td.otype_immediate with
+    | Unknown -> ()
+    | Always -> fprintf ppf " [%@%@immediate]"
+    | Always_on_64bits -> fprintf ppf " [%@%@immediate64]"
   in
   let print_unboxed ppf =
     if td.otype_unboxed then fprintf ppf " [%@%@unboxed]" else ()

typing/outcometree.mli

@@ -113,7 +113,7 @@ and out_type_decl =
     otype_params: (string * (bool * bool)) list;
     otype_type: out_type;
     otype_private: Asttypes.private_flag;
-    otype_immediate: bool;
+    otype_immediate: Type_immediacy.t;
     otype_unboxed: bool;
     otype_cstrs: (out_type * out_type) list }
 and out_extension_constructor =

typing/predef.ml

@@ -127,11 +127,11 @@ let decl_abstr =
    type_is_newtype = false;
    type_expansion_scope = lowest_level;
    type_attributes = [];
-   type_immediate = false;
+   type_immediate = Unknown;
    type_unboxed = unboxed_false_default_false;
   }
 
-let decl_abstr_imm = {decl_abstr with type_immediate = true}
+let decl_abstr_imm = {decl_abstr with type_immediate = Always}
 
 let cstr id args =
   {
@@ -153,11 +153,11 @@ let common_initial_env add_type add_extension empty_env =
   let decl_bool =
     {decl_abstr with
      type_kind = Type_variant([cstr ident_false []; cstr ident_true []]);
-     type_immediate = true}
+     type_immediate = Always}
   and decl_unit =
     {decl_abstr with
      type_kind = Type_variant([cstr ident_void []]);
-     type_immediate = true}
+     type_immediate = Always}
   and decl_exn =
     {decl_abstr with
      type_kind = Type_open}

typing/printtyp.ml

@@ -1241,15 +1241,12 @@ let rec tree_of_type_decl id decl =
     | Type_open ->
         tree_of_manifest Otyp_open,
         decl.type_private
-  in
-  let immediate =
-    Builtin_attributes.immediate decl.type_attributes
   in
     { otype_name = name;
       otype_params = args;
       otype_type = ty;
       otype_private = priv;
-      otype_immediate = immediate;
+      otype_immediate = Type_immediacy.of_attributes decl.type_attributes;
       otype_unboxed = decl.type_unboxed.unboxed;
       otype_cstrs = constraints }
 
@@ -1570,7 +1567,7 @@ let dummy =
     type_is_newtype = false; type_expansion_scope = Btype.lowest_level;
     type_loc = Location.none;
     type_attributes = [];
-    type_immediate = false;
+    type_immediate = Unknown;
     type_unboxed = unboxed_false_default_false;
   }
 

typing/type_immediacy.ml

@@ -0,0 +1,43 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Jeremie Dimino, Jane Street Europe                   *)
+(*                                                                        *)
+(*   Copyright 2019 Jane Street Group LLC                                 *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type t =
+  | Unknown
+  | Always
+  | Always_on_64bits
+
+module Violation = struct
+  type t =
+    | Not_always_immediate
+    | Not_always_immediate_on_64bits
+end
+
+let coerce t ~as_ =
+  match t, as_ with
+  | _, Unknown
+  | Always, Always
+  | (Always | Always_on_64bits), Always_on_64bits -> Ok ()
+  | (Unknown | Always_on_64bits), Always ->
+      Error Violation.Not_always_immediate
+  | Unknown, Always_on_64bits ->
+      Error Violation.Not_always_immediate_on_64bits
+
+let of_attributes attrs =
+  match
+    Builtin_attributes.immediate attrs,
+    Builtin_attributes.immediate64 attrs
+  with
+  | true, _ -> Always
+  | false, true -> Always_on_64bits
+  | false, false -> Unknown

typing/type_immediacy.mli

@@ -0,0 +1,40 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Jeremie Dimino, Jane Street Europe                   *)
+(*                                                                        *)
+(*   Copyright 2019 Jane Street Group LLC                                 *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Immediacy status of a type *)
+
+type t =
+  | Unknown
+  (** We don't know anything *)
+  | Always
+  (** We know for sure that values of this type are always immediate *)
+  | Always_on_64bits
+  (** We know for sure that values of this type are always immediate
+      on 64 bit platforms. For other platforms, we know nothing. *)
+
+module Violation : sig
+  type t =
+    | Not_always_immediate
+    | Not_always_immediate_on_64bits
+end
+
+(** [coerce t ~as_] returns [Ok ()] iff [t] can be seen as type
+    immediacy [as_]. For instance, [Always] can be seen as
+    [Always_on_64bits] but the opposite is not true. Return [Error _]
+    if the coercion is not possible. *)
+val coerce : t -> as_:t -> (unit, Violation.t) result
+
+(** Return the immediateness of a type as indicated by the user via
+    attributes *)
+val of_attributes : Parsetree.attributes -> t

typing/typeclass.ml

@@ -1304,7 +1304,7 @@ let temp_abbrev loc env id arity =
        type_expansion_scope = Btype.lowest_level;
        type_loc = loc;
        type_attributes = []; (* or keep attrs from the class decl? *)
-       type_immediate = false;
+       type_immediate = Unknown;
        type_unboxed = unboxed_false_default_false;
       }
       env
@@ -1554,7 +1554,7 @@ let class_infos define_class kind
      type_expansion_scope = Btype.lowest_level;
      type_loc = cl.pci_loc;
      type_attributes = []; (* or keep attrs from cl? *)
-     type_immediate = false;
+     type_immediate = Unknown;
      type_unboxed = unboxed_false_default_false;
     }
   in
@@ -1574,7 +1574,7 @@ let class_infos define_class kind
      type_expansion_scope = Btype.lowest_level;
      type_loc = cl.pci_loc;
      type_attributes = []; (* or keep attrs from cl? *)
-     type_immediate = false;
+     type_immediate = Unknown;
      type_unboxed = unboxed_false_default_false;
     }
   in

typing/typecore.ml

@@ -3117,7 +3117,7 @@ and type_expect_
         type_expansion_scope = Btype.lowest_level;
         type_loc = loc;
         type_attributes = [];
-        type_immediate = false;
+        type_immediate = Unknown;
         type_unboxed = unboxed_false_default_false;
       }
       in

typing/typedecl.ml

@@ -113,7 +113,7 @@ let enter_type rec_flag env sdecl id =
       type_expansion_scope = Btype.lowest_level;
       type_loc = sdecl.ptype_loc;
       type_attributes = sdecl.ptype_attributes;
-      type_immediate = false;
+      type_immediate = Unknown;
       type_unboxed = unboxed_false_default_false;
     }
   in
@@ -129,8 +129,10 @@ let update_type temp_env env id loc =
       with Ctype.Unify trace ->
         raise (Error(loc, Type_clash (env, trace)))
 
-let get_unboxed_type_representation =
+let get_unboxed_type_representation env ty =
-  Typedecl_unboxed.get_unboxed_type_representation
+  match Typedecl_unboxed.get_unboxed_type_representation env ty with
+  | Typedecl_unboxed.This x -> Some x
+  | _ -> None
 
 (* Determine if a type's values are represented by floats at run-time. *)
 let is_float env ty =
@@ -493,7 +495,7 @@ let transl_declaration env sdecl id =
         type_expansion_scope = Btype.lowest_level;
         type_loc = sdecl.ptype_loc;
         type_attributes = sdecl.ptype_attributes;
-        type_immediate = false;
+        type_immediate = Unknown;
         type_unboxed = unboxed_status;
       } in
 
@@ -1492,7 +1494,7 @@ let transl_with_constraint env id row_path orig_decl sdecl =
       type_expansion_scope = Btype.lowest_level;
       type_loc = sdecl.ptype_loc;
       type_attributes = sdecl.ptype_attributes;
-      type_immediate = false;
+      type_immediate = Unknown;
       type_unboxed;
     }
   in
@@ -1544,7 +1546,7 @@ let abstract_type_decl arity =
       type_expansion_scope = Btype.lowest_level;
       type_loc = Location.none;
       type_attributes = [];
-      type_immediate = false;
+      type_immediate = Unknown;
       type_unboxed = unboxed_false_default_false;
      } in
   Ctype.end_def();
@@ -1724,8 +1726,8 @@ let report_error ppf = function
   | Rebind_wrong_type (lid, env, trace) ->
       Printtyp.report_unification_error ppf env trace
         (function ppf ->
-          fprintf ppf "The constructor %a@ has type"
+           fprintf ppf "The constructor %a@ has type"
-            Printtyp.longident lid)
+             Printtyp.longident lid)
         (function ppf ->
            fprintf ppf "but was expected to be of type")
   | Rebind_mismatch (lid, p, p') ->
@@ -1758,28 +1760,28 @@ let report_error ppf = function
         | _ -> "th"
       in
       (match n with
-      | Variance_not_reflected ->
+       | Variance_not_reflected ->
-        fprintf ppf "@[%s@ %s@ It"
+           fprintf ppf "@[%s@ %s@ It"
-          "In this definition, a type variable has a variance that"
+             "In this definition, a type variable has a variance that"
-          "is not reflected by its occurrence in type parameters."
+             "is not reflected by its occurrence in type parameters."
-      | No_variable ->
+       | No_variable ->
-        fprintf ppf "@[%s@ %s@]"
+           fprintf ppf "@[%s@ %s@]"
-          "In this definition, a type variable cannot be deduced"
+             "In this definition, a type variable cannot be deduced"
-          "from the type parameters."
+             "from the type parameters."
-      | Variance_not_deducible ->
+       | Variance_not_deducible ->
-        fprintf ppf "@[%s@ %s@ It"
+           fprintf ppf "@[%s@ %s@ It"
-          "In this definition, a type variable has a variance that"
+             "In this definition, a type variable has a variance that"
-          "cannot be deduced from the type parameters."
+             "cannot be deduced from the type parameters."
-      | Variance_not_satisfied n ->
+       | Variance_not_satisfied n ->
-        fprintf ppf "@[%s@ %s@ The %d%s type parameter"
+           fprintf ppf "@[%s@ %s@ The %d%s type parameter"
-          "In this definition, expected parameter"
+             "In this definition, expected parameter"
-          "variances are not satisfied."
+             "variances are not satisfied."
-          n (suffix n));
+             n (suffix n));
       (match n with
-      | No_variable -> ()
+       | No_variable -> ()
-      | _ ->
+       | _ ->
-        fprintf ppf " was expected to be %s,@ but it is %s.@]"
+           fprintf ppf " was expected to be %s,@ but it is %s.@]"
-          (variance v2) (variance v1))
+             (variance v2) (variance v1))
   | Unavailable_type_constructor p ->
       fprintf ppf "The definition of type %a@ is unavailable" Printtyp.path p
   | Bad_fixed_type r ->
@@ -1794,20 +1796,25 @@ let report_error ppf = function
       fprintf ppf "Too many [@@unboxed]/[@@untagged] attributes"
   | Cannot_unbox_or_untag_type Unboxed ->
       fprintf ppf "@[Don't know how to unbox this type.@ \
-                    Only float, int32, int64 and nativeint can be unboxed.@]"
+                   Only float, int32, int64 and nativeint can be unboxed.@]"
   | Cannot_unbox_or_untag_type Untagged ->
       fprintf ppf "@[Don't know how to untag this type.@ \
                    Only int can be untagged.@]"
   | Deep_unbox_or_untag_attribute kind ->
       fprintf ppf
         "@[The attribute '%s' should be attached to@ \
-           a direct argument or result of the primitive,@ \
+         a direct argument or result of the primitive,@ \
-           it should not occur deeply into its type.@]"
+         it should not occur deeply into its type.@]"
         (match kind with Unboxed -> "@unboxed" | Untagged -> "@untagged")
-  | Immediacy Typedecl_immediacy.Bad_immediate_attribute ->
+  | Immediacy (Typedecl_immediacy.Bad_immediacy_attribute violation) ->
-      fprintf ppf "@[%s@ %s@]"
+      fprintf ppf "@[%a@]" Format.pp_print_text
-        "Types marked with the immediate attribute must be"
+        (match violation with
-        "non-pointer types like int or bool"
+         | Type_immediacy.Violation.Not_always_immediate ->
+             "Types marked with the immediate attribute must be \
+              non-pointer types like int or bool."
+         | Type_immediacy.Violation.Not_always_immediate_on_64bits ->
+             "Types marked with the immediate64 attribute must be \
+              produced using the Stdlib.Sys.Immediate64.Make functor.")
   | Bad_unboxed_attribute msg ->
       fprintf ppf "@[This type cannot be unboxed because@ %s.@]" msg
   | Wrong_unboxed_type_float ->

typing/typedecl_immediacy.ml

@@ -16,12 +16,9 @@
 
 open Types
 
-type error = Bad_immediate_attribute
+type error = Bad_immediacy_attribute of Type_immediacy.Violation.t
 exception Error of Location.t * error
 
-let marked_as_immediate decl =
-  Builtin_attributes.immediate decl.type_attributes
-
 let compute_decl env tdecl =
   match (tdecl.type_kind, tdecl.type_manifest) with
   | (Type_variant [{cd_args = Cstr_tuple [arg]; _}], _)
@@ -29,26 +26,38 @@ let compute_decl env tdecl =
     | (Type_record ([{ld_type = arg; _}], _), _)
   when tdecl.type_unboxed.unboxed ->
     begin match Typedecl_unboxed.get_unboxed_type_representation env arg with
-    | Some argrepr -> not (Ctype.maybe_pointer_type env argrepr)
+    | Typedecl_unboxed.Unavailable -> Type_immediacy.Unknown
-    | None -> false
+    | Typedecl_unboxed.This argrepr -> Ctype.immediacy env argrepr
+    | Typedecl_unboxed.Only_on_64_bits argrepr ->
+        match Ctype.immediacy env argrepr with
+        | Type_immediacy.Always -> Type_immediacy.Always_on_64bits
+        | Type_immediacy.Always_on_64bits | Type_immediacy.Unknown as x -> x
     end
   | (Type_variant (_ :: _ as cstrs), _) ->
-    not (List.exists (fun c -> c.Types.cd_args <> Types.Cstr_tuple []) cstrs)
+    if not (List.exists (fun c -> c.Types.cd_args <> Types.Cstr_tuple []) cstrs)
-  | (Type_abstract, Some(typ)) ->
+    then
-    not (Ctype.maybe_pointer_type env typ)
+      Type_immediacy.Always
-  | (Type_abstract, None) -> marked_as_immediate tdecl
+    else
-  | _ -> false
+      Type_immediacy.Unknown
+  | (Type_abstract, Some(typ)) -> Ctype.immediacy env typ
+  | (Type_abstract, None) -> Type_immediacy.of_attributes tdecl.type_attributes
+  | _ -> Type_immediacy.Unknown
 
-let property : (bool, unit) Typedecl_properties.property =
+let property : (Type_immediacy.t, unit) Typedecl_properties.property =
   let open Typedecl_properties in
   let eq = (=) in
   let merge ~prop:_ ~new_prop = new_prop in
-  let default _decl = false in
+  let default _decl = Type_immediacy.Unknown in
   let compute env decl () = compute_decl env decl in
   let update_decl decl immediacy = { decl with type_immediate = immediacy } in
   let check _env _id decl () =
-    if (marked_as_immediate decl) && (not decl.type_immediate) then
+    let written_by_user = Type_immediacy.of_attributes decl.type_attributes in
-      raise (Error (decl.type_loc, Bad_immediate_attribute)) in
+    match Type_immediacy.coerce decl.type_immediate ~as_:written_by_user with
+    | Ok () -> ()
+    | Error violation ->
+        raise (Error (decl.type_loc,
+                      Bad_immediacy_attribute violation))
+  in
   {
     eq;
     merge;

typing/typedecl_immediacy.mli

@@ -14,12 +14,12 @@
 (*                                                                        *)
 (**************************************************************************)
 
-type error = Bad_immediate_attribute
+type error = Bad_immediacy_attribute of Type_immediacy.Violation.t
 exception Error of Location.t * error
 
-val compute_decl : Env.t -> Types.type_declaration -> bool
+val compute_decl : Env.t -> Types.type_declaration -> Type_immediacy.t
 
-val property : (bool, unit) Typedecl_properties.property
+val property : (Type_immediacy.t, unit) Typedecl_properties.property
 
 val update_decls :
   Env.t ->

typing/typedecl_unboxed.ml

@@ -16,17 +16,25 @@
 
 open Types
 
+type t =
+  | Unavailable
+  | This of type_expr
+  | Only_on_64_bits of type_expr
+
 (* We use the Ctype.expand_head_opt version of expand_head to get access
    to the manifest type of private abbreviations. *)
 let rec get_unboxed_type_representation env ty fuel =
-  if fuel < 0 then None else
+  if fuel < 0 then Unavailable else
   let ty = Ctype.repr (Ctype.expand_head_opt env ty) in
   match ty.desc with
   | Tconstr (p, args, _) ->
     begin match Env.find_type p env with
-    | exception Not_found -> Some ty
+    | exception Not_found -> This ty
-    | {type_immediate = true; _} -> Some Predef.type_int
+    | {type_immediate = Always; _} ->
-    | {type_unboxed = {unboxed = false}} -> Some ty
+        This Predef.type_int
+    | {type_immediate = Always_on_64bits; _} ->
+        Only_on_64_bits Predef.type_int
+    | {type_unboxed = {unboxed = false}} -> This ty
     | {type_params; type_kind =
          Type_record ([{ld_type = ty2; _}], _)
        | Type_variant [{cd_args = Cstr_tuple [ty2]; _}]
@@ -36,12 +44,12 @@ let rec get_unboxed_type_representation env ty fuel =
         let ty2 = match ty2.desc with Tpoly (t, _) -> t | _ -> ty2 in
         get_unboxed_type_representation env
           (Ctype.apply env type_params ty2 args) (fuel - 1)
-    | {type_kind=Type_abstract} -> None
+    | {type_kind=Type_abstract} -> Unavailable
           (* This case can occur when checking a recursive unboxed type
              declaration. *)
     | _ -> assert false (* only the above can be unboxed *)
     end
-  | _ -> Some ty
+  | _ -> This ty
 
 let get_unboxed_type_representation env ty =
   (* Do not give too much fuel: PR#7424 *)

typing/typedecl_unboxed.mli

@@ -1,4 +1,9 @@
 open Types
 
+type t =
+  | Unavailable
+  | This of type_expr
+  | Only_on_64_bits of type_expr
+
 (* for typeopt.ml *)
-val get_unboxed_type_representation: Env.t -> type_expr -> type_expr option
+val get_unboxed_type_representation: Env.t -> type_expr -> t

typing/typemod.ml

@@ -484,7 +484,7 @@ let merge_constraint initial_env remove_aliases loc sg constr =
             type_is_newtype = false;
             type_expansion_scope = Btype.lowest_level;
             type_attributes = [];
-            type_immediate = false;
+            type_immediate = Unknown;
             type_unboxed = unboxed_false_default_false;
           }
         and id_row = Ident.create_local (s^"#row") in

typing/types.ml

@@ -149,7 +149,7 @@ type type_declaration =
     type_expansion_scope: int;
     type_loc: Location.t;
     type_attributes: Parsetree.attributes;
-    type_immediate: bool;
+    type_immediate: Type_immediacy.t;
     type_unboxed: unboxed_status;
  }
 

typing/types.mli

@@ -299,7 +299,7 @@ type type_declaration =
     type_expansion_scope: int;
     type_loc: Location.t;
     type_attributes: Parsetree.attributes;
-    type_immediate: bool; (* true iff type should not be a pointer *)
+    type_immediate: Type_immediacy.t;
     type_unboxed: unboxed_status;
   }