diff --git a/.depend b/.depend index a0cc32081..6a58826ba 100644 --- a/.depend +++ b/.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 \ diff --git a/Changes b/Changes index add5cfffc..83eb120d0 100644 --- a/Changes +++ b/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. diff --git a/Makefile b/Makefile index 0338197a9..ee11c370c 100644 --- a/Makefile +++ b/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 \ diff --git a/boot/ocamlc b/boot/ocamlc index 800a680b7..43bba224e 100755 Binary files a/boot/ocamlc and b/boot/ocamlc differ diff --git a/boot/ocamllex b/boot/ocamllex index 75e383d11..1265c0599 100755 Binary files a/boot/ocamllex and b/boot/ocamllex differ diff --git a/debugger/Makefile b/debugger/Makefile index 7824849e8..978b408e1 100644 --- a/debugger/Makefile +++ b/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 \ - persistent_env env oprint ctype printtyp mtype envaux) + ident path type_immediacy types btype primitive typedtree subst predef \ + datarepr persistent_env env oprint ctype printtyp mtype envaux) file_formats_modules := $(addprefix file_formats/,\ cmi_format) diff --git a/manual/manual/refman/exten.etex b/manual/manual/refman/exten.etex index 1f47c558c..0907ae7d9 100644 --- a/manual/manual/refman/exten.etex +++ b/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} diff --git a/otherlibs/dynlink/Makefile b/otherlibs/dynlink/Makefile index efe617997..2e25139d3 100644 --- a/otherlibs/dynlink/Makefile +++ b/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 \ diff --git a/parsing/builtin_attributes.ml b/parsing/builtin_attributes.ml index dbebed807..e270d5a4c 100644 --- a/parsing/builtin_attributes.ml +++ b/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 diff --git a/parsing/builtin_attributes.mli b/parsing/builtin_attributes.mli index 03949eea7..6200fd74e 100644 --- a/parsing/builtin_attributes.mli +++ b/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 diff --git a/stdlib/sys.mli b/stdlib/sys.mli index 808e8817c..eed700a86 100644 --- a/stdlib/sys.mli +++ b/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 diff --git a/stdlib/sys.mlp b/stdlib/sys.mlp index 2da2b7784..e89dd4584 100644 --- a/stdlib/sys.mlp +++ b/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 diff --git a/testsuite/tests/lib-sys/immediate64.ml b/testsuite/tests/lib-sys/immediate64.ml new file mode 100644 index 000000000..0f7dea7c4 --- /dev/null +++ b/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)) diff --git a/testsuite/tests/lib-sys/ocamltests b/testsuite/tests/lib-sys/ocamltests index cdb154ed8..ea913e7fb 100644 --- a/testsuite/tests/lib-sys/ocamltests +++ b/testsuite/tests/lib-sys/ocamltests @@ -1 +1,2 @@ rename.ml +immediate64.ml diff --git a/testsuite/tests/typing-immediate/immediate.ml b/testsuite/tests/typing-immediate/immediate.ml index 3834aa6f4..74575aa71 100644 --- a/testsuite/tests/typing-immediate/immediate.ml +++ b/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 - non-pointer types like int or bool +Error: Types marked with the immediate attribute must be non-pointer types + 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 - non-pointer types like int or bool +Error: Types marked with the immediate attribute must be non-pointer types + 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 - non-pointer types like int or bool +Error: Types marked with the immediate attribute must be non-pointer types + like int or bool. |}];; diff --git a/typing/ctype.ml b/typing/ctype.ml index e4d385db3..02b97214e 100644 --- a/typing/ctype.ml +++ b/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 - with Not_found -> true + type_decl.type_immediate + 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 - || List.exists + if + 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)) diff --git a/typing/ctype.mli b/typing/ctype.mli index 2403668d9..2a4aa8c5f 100644 --- a/typing/ctype.mli +++ b/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 *) diff --git a/typing/datarepr.ml b/typing/datarepr.ml index 9c997a78c..61d79bac6 100644 --- a/typing/datarepr.ml +++ b/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 diff --git a/typing/includecore.ml b/typing/includecore.ml index e4615354c..87f02b8c9 100644 --- a/typing/includecore.ml +++ b/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." - (StringLabels.capitalize_ascii first) + | Immediate violation -> + 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 && - not decl1.type_immediate && - decl2.type_immediate then - Some Immediate - else None + if not abstr then + None + else + match + 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 = diff --git a/typing/includecore.mli b/typing/includecore.mli index 68524f663..560d0ac19 100644 --- a/typing/includecore.mli +++ b/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 -> diff --git a/typing/oprint.ml b/typing/oprint.ml index 47efee611..5377534bc 100644 --- a/typing/oprint.ml +++ b/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 () diff --git a/typing/outcometree.mli b/typing/outcometree.mli index ec92d15fe..109afb78d 100644 --- a/typing/outcometree.mli +++ b/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 = diff --git a/typing/predef.ml b/typing/predef.ml index 5399656d5..24f51deca 100644 --- a/typing/predef.ml +++ b/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} diff --git a/typing/printtyp.ml b/typing/printtyp.ml index 069173e90..7ed29f8c4 100644 --- a/typing/printtyp.ml +++ b/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; } diff --git a/typing/type_immediacy.ml b/typing/type_immediacy.ml new file mode 100644 index 000000000..557ed4271 --- /dev/null +++ b/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 diff --git a/typing/type_immediacy.mli b/typing/type_immediacy.mli new file mode 100644 index 000000000..3fc2e3b4f --- /dev/null +++ b/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 diff --git a/typing/typeclass.ml b/typing/typeclass.ml index 3e39991ce..7f01b352a 100644 --- a/typing/typeclass.ml +++ b/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 diff --git a/typing/typecore.ml b/typing/typecore.ml index 4b9198a9d..55bb55f80 100644 --- a/typing/typecore.ml +++ b/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 diff --git a/typing/typedecl.ml b/typing/typedecl.ml index 4ad1fb6e8..13a92610a 100644 --- a/typing/typedecl.ml +++ b/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 = - Typedecl_unboxed.get_unboxed_type_representation +let get_unboxed_type_representation env ty = + 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" - Printtyp.longident lid) + fprintf ppf "The constructor %a@ has type" + 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 -> - fprintf ppf "@[%s@ %s@ It" - "In this definition, a type variable has a variance that" - "is not reflected by its occurrence in type parameters." - | No_variable -> - fprintf ppf "@[%s@ %s@]" - "In this definition, a type variable cannot be deduced" - "from the type parameters." - | Variance_not_deducible -> - fprintf ppf "@[%s@ %s@ It" - "In this definition, a type variable has a variance that" - "cannot be deduced from the type parameters." - | Variance_not_satisfied n -> - fprintf ppf "@[%s@ %s@ The %d%s type parameter" - "In this definition, expected parameter" - "variances are not satisfied." - n (suffix n)); + | Variance_not_reflected -> + fprintf ppf "@[%s@ %s@ It" + "In this definition, a type variable has a variance that" + "is not reflected by its occurrence in type parameters." + | No_variable -> + fprintf ppf "@[%s@ %s@]" + "In this definition, a type variable cannot be deduced" + "from the type parameters." + | Variance_not_deducible -> + fprintf ppf "@[%s@ %s@ It" + "In this definition, a type variable has a variance that" + "cannot be deduced from the type parameters." + | Variance_not_satisfied n -> + fprintf ppf "@[%s@ %s@ The %d%s type parameter" + "In this definition, expected parameter" + "variances are not satisfied." + n (suffix n)); (match n with - | No_variable -> () - | _ -> - fprintf ppf " was expected to be %s,@ but it is %s.@]" - (variance v2) (variance v1)) + | No_variable -> () + | _ -> + fprintf ppf " was expected to be %s,@ but it is %s.@]" + (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,@ \ - it should not occur deeply into its type.@]" + a direct argument or result of the primitive,@ \ + it should not occur deeply into its type.@]" (match kind with Unboxed -> "@unboxed" | Untagged -> "@untagged") - | Immediacy Typedecl_immediacy.Bad_immediate_attribute -> - fprintf ppf "@[%s@ %s@]" - "Types marked with the immediate attribute must be" - "non-pointer types like int or bool" + | Immediacy (Typedecl_immediacy.Bad_immediacy_attribute violation) -> + fprintf ppf "@[%a@]" Format.pp_print_text + (match violation with + | 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 -> diff --git a/typing/typedecl_immediacy.ml b/typing/typedecl_immediacy.ml index 3bb6907af..ccd09e810 100644 --- a/typing/typedecl_immediacy.ml +++ b/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) - | None -> false + | Typedecl_unboxed.Unavailable -> Type_immediacy.Unknown + | 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) - | (Type_abstract, Some(typ)) -> - not (Ctype.maybe_pointer_type env typ) - | (Type_abstract, None) -> marked_as_immediate tdecl - | _ -> false + if not (List.exists (fun c -> c.Types.cd_args <> Types.Cstr_tuple []) cstrs) + then + Type_immediacy.Always + else + 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 - raise (Error (decl.type_loc, Bad_immediate_attribute)) in + let written_by_user = Type_immediacy.of_attributes decl.type_attributes 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; diff --git a/typing/typedecl_immediacy.mli b/typing/typedecl_immediacy.mli index 6a9c3d911..17fb985c8 100644 --- a/typing/typedecl_immediacy.mli +++ b/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 -> diff --git a/typing/typedecl_unboxed.ml b/typing/typedecl_unboxed.ml index 8a1f0e28a..e2d29a863 100644 --- a/typing/typedecl_unboxed.ml +++ b/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 - | {type_immediate = true; _} -> Some Predef.type_int - | {type_unboxed = {unboxed = false}} -> Some ty + | exception Not_found -> This ty + | {type_immediate = Always; _} -> + 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 *) diff --git a/typing/typedecl_unboxed.mli b/typing/typedecl_unboxed.mli index 88a056de8..b8c172b4b 100644 --- a/typing/typedecl_unboxed.mli +++ b/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 diff --git a/typing/typemod.ml b/typing/typemod.ml index 260ec2275..b3ef7686f 100644 --- a/typing/typemod.ml +++ b/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 diff --git a/typing/types.ml b/typing/types.ml index 24012dd8c..d187c6a9a 100644 --- a/typing/types.ml +++ b/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; } diff --git a/typing/types.mli b/typing/types.mli index 80010b62c..33f92ab0a 100644 --- a/typing/types.mli +++ b/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; }