Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Add support for [@@immediate64] 

Signed-off-by: Jeremie Dimino <jeremie@dimino.org>
master
Jeremie Dimino 2019-03-12 08:11:27 +00:00 committed by Jérémie Dimino
parent 31d75f7526
commit 2d31ebfc8b
36 changed files with 395 additions and 109 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
.depend
View File

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

4
Changes
View File

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

2
Makefile
View File

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

BIN
boot/ocamlc
View File

Binary file not shown.

BIN
boot/ocamllex
View File

Binary file not shown.

4
debugger/Makefile
View File

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

31
manual/manual/refman/exten.etex
View File

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

1
otherlibs/dynlink/Makefile
View File

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

7
parsing/builtin_attributes.ml
View File

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

2
parsing/builtin_attributes.mli
View File

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

25
stdlib/sys.mli
View File

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

22
stdlib/sys.mlp
View File

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

32
testsuite/tests/lib-sys/immediate64.ml Normal file
View File

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

1
testsuite/tests/lib-sys/ocamltests
View File

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

12
testsuite/tests/typing-immediate/immediate.ml
View File

@ -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.
|}];;

29
typing/ctype.ml
View File

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

2
typing/ctype.mli
View File

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

2
typing/datarepr.ml
View File

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

25
typing/includecore.ml
View File

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

2
typing/includecore.mli
View File

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

5
typing/oprint.ml
View File

@ -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 ()

2
typing/outcometree.mli
View File

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

8
typing/predef.ml
View File

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

7
typing/printtyp.ml
View File

@ -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;
}

43
typing/type_immediacy.ml Normal file
View File

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

40
typing/type_immediacy.mli Normal file
View File

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

6
typing/typeclass.ml
View File

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

2
typing/typecore.ml
View File

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

79
typing/typedecl.ml
View File

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

39
typing/typedecl_immediacy.ml
View File

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

6
typing/typedecl_immediacy.mli
View File

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

20
typing/typedecl_unboxed.ml
View File

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

7
typing/typedecl_unboxed.mli
View File

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

2
typing/typemod.ml
View File

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

2
typing/types.ml
View File

@ -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;
}

2
typing/types.mli
View File

@ -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;
}