Add support for immediate attribute
parent
ac4ce3e484
commit
50dd38d4b6
3
Changes
3
Changes
|
@ -63,6 +63,9 @@ Language features:
|
||||||
* GPR#234: allow "[]" as a user-defined constructor. Demand parenthesis
|
* GPR#234: allow "[]" as a user-defined constructor. Demand parenthesis
|
||||||
around "::" when using "::" as user-defined constructor.
|
around "::" when using "::" as user-defined constructor.
|
||||||
(Runhang Li, review by Damien Doligez)
|
(Runhang Li, review by Damien Doligez)
|
||||||
|
- GPR#188: accept [@@immediate] attribute on type declarations to mark types
|
||||||
|
that are represented at runtime by an integer
|
||||||
|
(Will Crichton, reviewed by Leo White)
|
||||||
|
|
||||||
Compilers:
|
Compilers:
|
||||||
- PR#4080, PR#6537, PR#5333: fix stack overflow in the compiler when -pack'ing
|
- PR#4080, PR#6537, PR#5333: fix stack overflow in the compiler when -pack'ing
|
||||||
|
|
BIN
boot/ocamlc
BIN
boot/ocamlc
Binary file not shown.
BIN
boot/ocamldep
BIN
boot/ocamldep
Binary file not shown.
BIN
boot/ocamllex
BIN
boot/ocamllex
Binary file not shown.
|
@ -33,35 +33,11 @@ let is_base_type env ty base_ty_path =
|
||||||
let has_base_type exp base_ty_path =
|
let has_base_type exp base_ty_path =
|
||||||
is_base_type exp.exp_env exp.exp_type base_ty_path
|
is_base_type exp.exp_env exp.exp_type base_ty_path
|
||||||
|
|
||||||
let maybe_pointer_type env typ =
|
let maybe_pointer_type env ty =
|
||||||
let maybe_pointer =
|
if Ctype.maybe_pointer_type env ty then
|
||||||
match scrape env typ with
|
Pointer
|
||||||
| Tconstr(p, args, abbrev) ->
|
else
|
||||||
not (Path.same p Predef.path_int) &&
|
Immediate
|
||||||
not (Path.same p Predef.path_char) &&
|
|
||||||
begin try
|
|
||||||
match Env.find_type p env with
|
|
||||||
| {type_kind = Type_variant []} -> true (* type exn *)
|
|
||||||
| {type_kind = Type_variant cstrs} ->
|
|
||||||
List.exists (fun c -> c.Types.cd_args <> Types.Cstr_tuple []) cstrs
|
|
||||||
| _ -> true
|
|
||||||
with Not_found -> true
|
|
||||||
(* This can happen due to e.g. missing -I options,
|
|
||||||
causing some .cmi files to be unavailable.
|
|
||||||
Maybe we should emit a warning. *)
|
|
||||||
end
|
|
||||||
| 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
|
|
||||||
(function
|
|
||||||
| _, (Rpresent (Some _) | Reither (false, _, _, _)) -> true
|
|
||||||
| _ -> false)
|
|
||||||
row.row_fields
|
|
||||||
| _ -> true
|
|
||||||
in
|
|
||||||
if maybe_pointer then Pointer else Immediate
|
|
||||||
|
|
||||||
let maybe_pointer exp = maybe_pointer_type exp.exp_env exp.exp_type
|
let maybe_pointer exp = maybe_pointer_type exp.exp_env exp.exp_type
|
||||||
|
|
||||||
|
|
|
@ -26,3 +26,4 @@ val array_kind : Typedtree.expression -> Lambda.array_kind
|
||||||
val array_pattern_kind : Typedtree.pattern -> Lambda.array_kind
|
val array_pattern_kind : Typedtree.pattern -> Lambda.array_kind
|
||||||
val bigarray_type_kind_and_layout :
|
val bigarray_type_kind_and_layout :
|
||||||
Env.t -> Types.type_expr -> Lambda.bigarray_kind * Lambda.bigarray_layout
|
Env.t -> Types.type_expr -> Lambda.bigarray_kind * Lambda.bigarray_layout
|
||||||
|
|
||||||
|
|
|
@ -0,0 +1,15 @@
|
||||||
|
#########################################################################
|
||||||
|
# #
|
||||||
|
# OCaml #
|
||||||
|
# #
|
||||||
|
# Xavier Clerc, SED, INRIA Rocquencourt #
|
||||||
|
# #
|
||||||
|
# Copyright 2010 Institut National de Recherche en Informatique et #
|
||||||
|
# en Automatique. All rights reserved. This file is distributed #
|
||||||
|
# under the terms of the Q Public License version 1.0. #
|
||||||
|
# #
|
||||||
|
#########################################################################
|
||||||
|
|
||||||
|
BASEDIR=../..
|
||||||
|
include $(BASEDIR)/makefiles/Makefile.toplevel
|
||||||
|
include $(BASEDIR)/makefiles/Makefile.common
|
|
@ -0,0 +1,86 @@
|
||||||
|
module type S = sig type t [@@immediate] end;;
|
||||||
|
module F (M : S) : S = M;;
|
||||||
|
|
||||||
|
(* VALID DECLARATIONS *)
|
||||||
|
|
||||||
|
module A = struct
|
||||||
|
(* Abstract types can be immediate *)
|
||||||
|
type t [@@immediate]
|
||||||
|
|
||||||
|
(* [@@immediate] tag here is unnecessary but valid since t has it *)
|
||||||
|
type s = t [@@immediate]
|
||||||
|
|
||||||
|
(* Again, valid alias even without tag *)
|
||||||
|
type r = s
|
||||||
|
|
||||||
|
(* Mutually recursive declarations work as well *)
|
||||||
|
type p = q [@@immediate]
|
||||||
|
and q = int
|
||||||
|
end;;
|
||||||
|
|
||||||
|
(* Valid using with constraints *)
|
||||||
|
module type X = sig type t end;;
|
||||||
|
module Y = struct type t = int end;;
|
||||||
|
module Z = ((Y : X with type t = int) : sig type t [@@immediate] end);;
|
||||||
|
|
||||||
|
(* Valid using an explicit signature *)
|
||||||
|
module M_valid : S = struct type t = int end;;
|
||||||
|
module FM_valid = F (struct type t = int end);;
|
||||||
|
|
||||||
|
(* Practical usage over modules *)
|
||||||
|
module Foo : sig type t val x : t ref end = struct
|
||||||
|
type t = int
|
||||||
|
let x = ref 0
|
||||||
|
end;;
|
||||||
|
|
||||||
|
module Bar : sig type t [@@immediate] val x : t ref end = struct
|
||||||
|
type t = int
|
||||||
|
let x = ref 0
|
||||||
|
end;;
|
||||||
|
|
||||||
|
let test f =
|
||||||
|
let start = Sys.time() in f ();
|
||||||
|
(Sys.time() -. start);;
|
||||||
|
|
||||||
|
let test_foo () =
|
||||||
|
for i = 0 to 100_000_000 do
|
||||||
|
Foo.x := !Foo.x
|
||||||
|
done;;
|
||||||
|
|
||||||
|
let test_bar () =
|
||||||
|
for i = 0 to 100_000_000 do
|
||||||
|
Bar.x := !Bar.x
|
||||||
|
done;;
|
||||||
|
|
||||||
|
(* Uncomment these to test. Should see substantial speedup!
|
||||||
|
let () = Printf.printf "No @@immediate: %fs\n" (test test_foo)
|
||||||
|
let () = Printf.printf "With @@immediate: %fs\n" (test test_bar) *)
|
||||||
|
|
||||||
|
|
||||||
|
(* INVALID DECLARATIONS *)
|
||||||
|
|
||||||
|
(* Cannot directly declare a non-immediate type as immediate *)
|
||||||
|
module B = struct
|
||||||
|
type t = string [@@immediate]
|
||||||
|
end;;
|
||||||
|
|
||||||
|
(* Not guaranteed that t is immediate, so this is an invalid declaration *)
|
||||||
|
module C = struct
|
||||||
|
type t
|
||||||
|
type s = t [@@immediate]
|
||||||
|
end;;
|
||||||
|
|
||||||
|
(* Can't ascribe to an immediate type signature with a non-immediate type *)
|
||||||
|
module D : sig type t [@@immediate] end = struct
|
||||||
|
type t = string
|
||||||
|
end;;
|
||||||
|
|
||||||
|
(* Same as above but with explicit signature *)
|
||||||
|
module M_invalid : S = struct type t = string end;;
|
||||||
|
module FM_invalid = F (struct type t = string end);;
|
||||||
|
|
||||||
|
(* Can't use a non-immediate type even if mutually recursive *)
|
||||||
|
module E = struct
|
||||||
|
type t = s [@@immediate]
|
||||||
|
and s = string
|
||||||
|
end;;
|
|
@ -0,0 +1,71 @@
|
||||||
|
|
||||||
|
# module type S = sig type t [@@immediate] end
|
||||||
|
# module F : functor (M : S) -> S
|
||||||
|
# module A :
|
||||||
|
sig
|
||||||
|
type t [@@immediate]
|
||||||
|
type s = t [@@immediate]
|
||||||
|
type r = s
|
||||||
|
type p = q [@@immediate]
|
||||||
|
and q = int
|
||||||
|
end
|
||||||
|
# module type X = sig type t end
|
||||||
|
# module Y : sig type t = int end
|
||||||
|
# module Z : sig type t [@@immediate] end
|
||||||
|
# module M_valid : S
|
||||||
|
# module FM_valid : S
|
||||||
|
# module Foo : sig type t val x : t ref end
|
||||||
|
# module Bar : sig type t [@@immediate] val x : t ref end
|
||||||
|
# val test : (unit -> 'a) -> float = <fun>
|
||||||
|
# val test_foo : unit -> unit = <fun>
|
||||||
|
# val test_bar : unit -> unit = <fun>
|
||||||
|
# * * Characters 306-335:
|
||||||
|
type t = string [@@immediate]
|
||||||
|
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
|
||||||
|
Error: Types marked with the immediate attribute must be
|
||||||
|
non-pointer types like int or bool
|
||||||
|
# Characters 106-130:
|
||||||
|
type s = t [@@immediate]
|
||||||
|
^^^^^^^^^^^^^^^^^^^^^^^^
|
||||||
|
Error: Types marked with the immediate attribute must be
|
||||||
|
non-pointer types like int or bool
|
||||||
|
# Characters 120-148:
|
||||||
|
..........................................struct
|
||||||
|
type t = string
|
||||||
|
end..
|
||||||
|
Error: Signature mismatch:
|
||||||
|
Modules do not match:
|
||||||
|
sig type t = string end
|
||||||
|
is not included in
|
||||||
|
sig type t [@@immediate] end
|
||||||
|
Type declarations do not match:
|
||||||
|
type t = string
|
||||||
|
is not included in
|
||||||
|
type t [@@immediate]
|
||||||
|
the first is not an immediate type.
|
||||||
|
# Characters 72-98:
|
||||||
|
module M_invalid : S = struct type t = string end;;
|
||||||
|
^^^^^^^^^^^^^^^^^^^^^^^^^^
|
||||||
|
Error: Signature mismatch:
|
||||||
|
Modules do not match: sig type t = string end is not included in S
|
||||||
|
Type declarations do not match:
|
||||||
|
type t = string
|
||||||
|
is not included in
|
||||||
|
type t [@@immediate]
|
||||||
|
the first is not an immediate type.
|
||||||
|
# Characters 23-49:
|
||||||
|
module FM_invalid = F (struct type t = string end);;
|
||||||
|
^^^^^^^^^^^^^^^^^^^^^^^^^^
|
||||||
|
Error: Signature mismatch:
|
||||||
|
Modules do not match: sig type t = string end is not included in S
|
||||||
|
Type declarations do not match:
|
||||||
|
type t = string
|
||||||
|
is not included in
|
||||||
|
type t [@@immediate]
|
||||||
|
the first is not an immediate type.
|
||||||
|
# Characters 85-109:
|
||||||
|
type t = s [@@immediate]
|
||||||
|
^^^^^^^^^^^^^^^^^^^^^^^^
|
||||||
|
Error: Types marked with the immediate attribute must be
|
||||||
|
non-pointer types like int or bool
|
||||||
|
#
|
|
@ -1100,6 +1100,7 @@ let new_declaration newtype manifest =
|
||||||
type_newtype_level = newtype;
|
type_newtype_level = newtype;
|
||||||
type_loc = Location.none;
|
type_loc = Location.none;
|
||||||
type_attributes = [];
|
type_attributes = [];
|
||||||
|
type_immediate = false;
|
||||||
}
|
}
|
||||||
|
|
||||||
let instance_constructor ?in_pattern cstr =
|
let instance_constructor ?in_pattern cstr =
|
||||||
|
@ -4314,6 +4315,7 @@ let nondep_type_decl env mid id is_covariant decl =
|
||||||
type_newtype_level = None;
|
type_newtype_level = None;
|
||||||
type_loc = decl.type_loc;
|
type_loc = decl.type_loc;
|
||||||
type_attributes = decl.type_attributes;
|
type_attributes = decl.type_attributes;
|
||||||
|
type_immediate = decl.type_immediate;
|
||||||
}
|
}
|
||||||
with Not_found ->
|
with Not_found ->
|
||||||
clear_hash ();
|
clear_hash ();
|
||||||
|
@ -4444,3 +4446,25 @@ let same_constr env t1 t2 =
|
||||||
|
|
||||||
let () =
|
let () =
|
||||||
Env.same_constr := same_constr
|
Env.same_constr := same_constr
|
||||||
|
|
||||||
|
let maybe_pointer_type 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
|
||||||
|
(* This can happen due to e.g. missing -I options,
|
||||||
|
causing some .cmi files to be unavailable.
|
||||||
|
Maybe we should emit a warning. *)
|
||||||
|
end
|
||||||
|
| 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
|
||||||
|
(function
|
||||||
|
| _, (Rpresent (Some _) | Reither (false, _, _, _)) -> true
|
||||||
|
| _ -> false)
|
||||||
|
row.row_fields
|
||||||
|
| _ -> true
|
||||||
|
|
|
@ -278,6 +278,9 @@ val get_current_level: unit -> int
|
||||||
val wrap_trace_gadt_instances: Env.t -> ('a -> 'b) -> 'a -> 'b
|
val wrap_trace_gadt_instances: Env.t -> ('a -> 'b) -> 'a -> 'b
|
||||||
val reset_reified_var_counter: unit -> unit
|
val reset_reified_var_counter: unit -> unit
|
||||||
|
|
||||||
|
val maybe_pointer_type : Env.t -> type_expr -> bool
|
||||||
|
(* True if type is possibly pointer, false if definitely not a pointer *)
|
||||||
|
|
||||||
(* Stubs *)
|
(* Stubs *)
|
||||||
val package_subtype :
|
val package_subtype :
|
||||||
(Env.t -> Path.t -> Longident.t list -> type_expr list ->
|
(Env.t -> Path.t -> Longident.t list -> type_expr list ->
|
||||||
|
|
|
@ -76,6 +76,7 @@ let constructor_args cd_args cd_res path rep =
|
||||||
type_newtype_level = None;
|
type_newtype_level = None;
|
||||||
type_loc = Location.none;
|
type_loc = Location.none;
|
||||||
type_attributes = [];
|
type_attributes = [];
|
||||||
|
type_immediate = false;
|
||||||
}
|
}
|
||||||
in
|
in
|
||||||
existentials,
|
existentials,
|
||||||
|
|
|
@ -124,6 +124,7 @@ type type_mismatch =
|
||||||
| Field_names of int * Ident.t * Ident.t
|
| Field_names of int * Ident.t * Ident.t
|
||||||
| Field_missing of bool * Ident.t
|
| Field_missing of bool * Ident.t
|
||||||
| Record_representation of bool
|
| Record_representation of bool
|
||||||
|
| Immediate
|
||||||
|
|
||||||
let report_type_mismatch0 first second decl ppf err =
|
let report_type_mismatch0 first second decl ppf err =
|
||||||
let pr fmt = Format.fprintf ppf fmt in
|
let pr fmt = Format.fprintf ppf fmt in
|
||||||
|
@ -150,6 +151,7 @@ let report_type_mismatch0 first second decl ppf err =
|
||||||
pr "Their internal representations differ:@ %s %s %s"
|
pr "Their internal representations differ:@ %s %s %s"
|
||||||
(if b then second else first) decl
|
(if b then second else first) decl
|
||||||
"uses unboxed float representation"
|
"uses unboxed float representation"
|
||||||
|
| Immediate -> pr "%s is not an immediate type" first
|
||||||
|
|
||||||
let report_type_mismatch first second decl ppf =
|
let report_type_mismatch first second decl ppf =
|
||||||
List.iter
|
List.iter
|
||||||
|
@ -254,9 +256,18 @@ let type_declarations ?(equality = false) env name decl1 id decl2 =
|
||||||
| (_, _) -> [Kind]
|
| (_, _) -> [Kind]
|
||||||
in
|
in
|
||||||
if err <> [] then err else
|
if err <> [] then err else
|
||||||
let abstr =
|
let abstr = decl2.type_kind = Type_abstract && decl2.type_manifest = None in
|
||||||
decl2.type_private = Private ||
|
(* If attempt to assign a non-immediate type (e.g. string) to a type that
|
||||||
decl2.type_kind = Type_abstract && decl2.type_manifest = None in
|
* must be immediate, then we error *)
|
||||||
|
let err =
|
||||||
|
if abstr &&
|
||||||
|
not decl1.type_immediate &&
|
||||||
|
decl2.type_immediate then
|
||||||
|
[Immediate]
|
||||||
|
else []
|
||||||
|
in
|
||||||
|
if err <> [] then err else
|
||||||
|
let abstr = abstr || decl2.type_private = Private in
|
||||||
let opn = decl2.type_kind = Type_open && decl2.type_manifest = None in
|
let opn = decl2.type_kind = Type_open && decl2.type_manifest = None in
|
||||||
let constrained ty = not (Btype.(is_Tvar (repr ty))) in
|
let constrained ty = not (Btype.(is_Tvar (repr ty))) in
|
||||||
if List.for_all2
|
if List.for_all2
|
||||||
|
|
|
@ -30,6 +30,7 @@ type type_mismatch =
|
||||||
| Field_names of int * Ident.t * Ident.t
|
| Field_names of int * Ident.t * Ident.t
|
||||||
| Field_missing of bool * Ident.t
|
| Field_missing of bool * Ident.t
|
||||||
| Record_representation of bool
|
| Record_representation of bool
|
||||||
|
| Immediate
|
||||||
|
|
||||||
val value_descriptions:
|
val value_descriptions:
|
||||||
Env.t -> value_description -> value_description -> module_coercion
|
Env.t -> value_description -> value_description -> module_coercion
|
||||||
|
|
|
@ -500,6 +500,9 @@ and print_out_type_decl kwd ppf td =
|
||||||
Asttypes.Private -> fprintf ppf " private"
|
Asttypes.Private -> fprintf ppf " private"
|
||||||
| Asttypes.Public -> ()
|
| Asttypes.Public -> ()
|
||||||
in
|
in
|
||||||
|
let print_immediate ppf =
|
||||||
|
if td.otype_immediate then fprintf ppf " [%@%@immediate]" else ()
|
||||||
|
in
|
||||||
let print_out_tkind ppf = function
|
let print_out_tkind ppf = function
|
||||||
| Otyp_abstract -> ()
|
| Otyp_abstract -> ()
|
||||||
| Otyp_record lbls ->
|
| Otyp_record lbls ->
|
||||||
|
@ -517,10 +520,11 @@ and print_out_type_decl kwd ppf td =
|
||||||
print_private td.otype_private
|
print_private td.otype_private
|
||||||
!out_type ty
|
!out_type ty
|
||||||
in
|
in
|
||||||
fprintf ppf "@[<2>@[<hv 2>%t%a@]%t@]"
|
fprintf ppf "@[<2>@[<hv 2>%t%a@]%t%t@]"
|
||||||
print_name_params
|
print_name_params
|
||||||
print_out_tkind ty
|
print_out_tkind ty
|
||||||
print_constraints
|
print_constraints
|
||||||
|
print_immediate
|
||||||
|
|
||||||
and print_out_constr ppf (name, tyl,ret_type_opt) =
|
and print_out_constr ppf (name, tyl,ret_type_opt) =
|
||||||
match ret_type_opt with
|
match ret_type_opt with
|
||||||
|
|
|
@ -102,6 +102,7 @@ and out_type_decl =
|
||||||
otype_params: (string * (bool * bool)) list;
|
otype_params: (string * (bool * bool)) list;
|
||||||
otype_type: out_type;
|
otype_type: out_type;
|
||||||
otype_private: Asttypes.private_flag;
|
otype_private: Asttypes.private_flag;
|
||||||
|
otype_immediate: bool;
|
||||||
otype_cstrs: (out_type * out_type) list }
|
otype_cstrs: (out_type * out_type) list }
|
||||||
and out_extension_constructor =
|
and out_extension_constructor =
|
||||||
{ oext_name: string;
|
{ oext_name: string;
|
||||||
|
|
|
@ -120,8 +120,11 @@ let decl_abstr =
|
||||||
type_variance = [];
|
type_variance = [];
|
||||||
type_newtype_level = None;
|
type_newtype_level = None;
|
||||||
type_attributes = [];
|
type_attributes = [];
|
||||||
|
type_immediate = false;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
let decl_abstr_imm = {decl_abstr with type_immediate = true}
|
||||||
|
|
||||||
let cstr id args =
|
let cstr id args =
|
||||||
{
|
{
|
||||||
cd_id = id;
|
cd_id = id;
|
||||||
|
@ -141,10 +144,12 @@ and ident_some = ident_create "Some"
|
||||||
let common_initial_env add_type add_extension empty_env =
|
let common_initial_env add_type add_extension empty_env =
|
||||||
let decl_bool =
|
let decl_bool =
|
||||||
{decl_abstr with
|
{decl_abstr with
|
||||||
type_kind = Type_variant([cstr ident_false []; cstr ident_true []])}
|
type_kind = Type_variant([cstr ident_false []; cstr ident_true []]);
|
||||||
|
type_immediate = true}
|
||||||
and decl_unit =
|
and decl_unit =
|
||||||
{decl_abstr with
|
{decl_abstr with
|
||||||
type_kind = Type_variant([cstr ident_void []])}
|
type_kind = Type_variant([cstr ident_void []]);
|
||||||
|
type_immediate = true}
|
||||||
and decl_exn =
|
and decl_exn =
|
||||||
{decl_abstr with
|
{decl_abstr with
|
||||||
type_kind = Type_open}
|
type_kind = Type_open}
|
||||||
|
@ -214,8 +219,8 @@ let common_initial_env add_type add_extension empty_env =
|
||||||
add_type ident_bool decl_bool (
|
add_type ident_bool decl_bool (
|
||||||
add_type ident_float decl_abstr (
|
add_type ident_float decl_abstr (
|
||||||
add_type ident_string decl_abstr (
|
add_type ident_string decl_abstr (
|
||||||
add_type ident_char decl_abstr (
|
add_type ident_char decl_abstr_imm (
|
||||||
add_type ident_int decl_abstr (
|
add_type ident_int decl_abstr_imm (
|
||||||
add_type ident_extension_constructor decl_abstr (
|
add_type ident_extension_constructor decl_abstr (
|
||||||
empty_env)))))))))))))))))))))))))))
|
empty_env)))))))))))))))))))))))))))
|
||||||
|
|
||||||
|
|
|
@ -1,3 +1,4 @@
|
||||||
|
|
||||||
(***********************************************************************)
|
(***********************************************************************)
|
||||||
(* *)
|
(* *)
|
||||||
(* OCaml *)
|
(* OCaml *)
|
||||||
|
@ -863,11 +864,15 @@ let rec tree_of_type_decl id decl =
|
||||||
| Type_open ->
|
| Type_open ->
|
||||||
tree_of_manifest Otyp_open,
|
tree_of_manifest Otyp_open,
|
||||||
Public
|
Public
|
||||||
|
in
|
||||||
|
let immediate =
|
||||||
|
List.exists (fun (loc, _) -> loc.txt = "immediate") decl.type_attributes
|
||||||
in
|
in
|
||||||
{ otype_name = name;
|
{ otype_name = name;
|
||||||
otype_params = args;
|
otype_params = args;
|
||||||
otype_type = ty;
|
otype_type = ty;
|
||||||
otype_private = priv;
|
otype_private = priv;
|
||||||
|
otype_immediate = immediate;
|
||||||
otype_cstrs = constraints }
|
otype_cstrs = constraints }
|
||||||
|
|
||||||
and tree_of_constructor_arguments = function
|
and tree_of_constructor_arguments = function
|
||||||
|
@ -1161,6 +1166,7 @@ let dummy =
|
||||||
type_private = Public; type_manifest = None; type_variance = [];
|
type_private = Public; type_manifest = None; type_variance = [];
|
||||||
type_newtype_level = None; type_loc = Location.none;
|
type_newtype_level = None; type_loc = Location.none;
|
||||||
type_attributes = [];
|
type_attributes = [];
|
||||||
|
type_immediate = false;
|
||||||
}
|
}
|
||||||
|
|
||||||
let hide_rec_items = function
|
let hide_rec_items = function
|
||||||
|
|
|
@ -250,6 +250,7 @@ let type_declaration s decl =
|
||||||
type_newtype_level = None;
|
type_newtype_level = None;
|
||||||
type_loc = loc s decl.type_loc;
|
type_loc = loc s decl.type_loc;
|
||||||
type_attributes = attrs s decl.type_attributes;
|
type_attributes = attrs s decl.type_attributes;
|
||||||
|
type_immediate = decl.type_immediate;
|
||||||
}
|
}
|
||||||
in
|
in
|
||||||
cleanup_types ();
|
cleanup_types ();
|
||||||
|
|
|
@ -1213,6 +1213,7 @@ let temp_abbrev loc env id arity =
|
||||||
type_newtype_level = None;
|
type_newtype_level = None;
|
||||||
type_loc = loc;
|
type_loc = loc;
|
||||||
type_attributes = []; (* or keep attrs from the class decl? *)
|
type_attributes = []; (* or keep attrs from the class decl? *)
|
||||||
|
type_immediate = false;
|
||||||
}
|
}
|
||||||
env
|
env
|
||||||
in
|
in
|
||||||
|
@ -1459,6 +1460,7 @@ let class_infos define_class kind
|
||||||
type_newtype_level = None;
|
type_newtype_level = None;
|
||||||
type_loc = cl.pci_loc;
|
type_loc = cl.pci_loc;
|
||||||
type_attributes = []; (* or keep attrs from cl? *)
|
type_attributes = []; (* or keep attrs from cl? *)
|
||||||
|
type_immediate = false;
|
||||||
}
|
}
|
||||||
in
|
in
|
||||||
let (cl_params, cl_ty) =
|
let (cl_params, cl_ty) =
|
||||||
|
@ -1476,6 +1478,7 @@ let class_infos define_class kind
|
||||||
type_newtype_level = None;
|
type_newtype_level = None;
|
||||||
type_loc = cl.pci_loc;
|
type_loc = cl.pci_loc;
|
||||||
type_attributes = []; (* or keep attrs from cl? *)
|
type_attributes = []; (* or keep attrs from cl? *)
|
||||||
|
type_immediate = false;
|
||||||
}
|
}
|
||||||
in
|
in
|
||||||
((cl, id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, ci_params,
|
((cl, id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr, ci_params,
|
||||||
|
|
|
@ -2820,6 +2820,7 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
|
||||||
type_newtype_level = Some (level, level);
|
type_newtype_level = Some (level, level);
|
||||||
type_loc = loc;
|
type_loc = loc;
|
||||||
type_attributes = [];
|
type_attributes = [];
|
||||||
|
type_immediate = false;
|
||||||
}
|
}
|
||||||
in
|
in
|
||||||
Ident.set_current_time ty.level;
|
Ident.set_current_time ty.level;
|
||||||
|
|
|
@ -51,6 +51,7 @@ type error =
|
||||||
| Multiple_native_repr_attributes
|
| Multiple_native_repr_attributes
|
||||||
| Cannot_unbox_or_untag_type of native_repr_kind
|
| Cannot_unbox_or_untag_type of native_repr_kind
|
||||||
| Deep_unbox_or_untag_attribute of native_repr_kind
|
| Deep_unbox_or_untag_attribute of native_repr_kind
|
||||||
|
| Bad_immediate_attribute
|
||||||
|
|
||||||
open Typedtree
|
open Typedtree
|
||||||
|
|
||||||
|
@ -72,6 +73,7 @@ let enter_type env sdecl id =
|
||||||
type_newtype_level = None;
|
type_newtype_level = None;
|
||||||
type_loc = sdecl.ptype_loc;
|
type_loc = sdecl.ptype_loc;
|
||||||
type_attributes = sdecl.ptype_attributes;
|
type_attributes = sdecl.ptype_attributes;
|
||||||
|
type_immediate = false;
|
||||||
}
|
}
|
||||||
in
|
in
|
||||||
Env.add_type ~check:true id decl env
|
Env.add_type ~check:true id decl env
|
||||||
|
@ -301,6 +303,7 @@ let transl_declaration env sdecl id =
|
||||||
type_newtype_level = None;
|
type_newtype_level = None;
|
||||||
type_loc = sdecl.ptype_loc;
|
type_loc = sdecl.ptype_loc;
|
||||||
type_attributes = sdecl.ptype_attributes;
|
type_attributes = sdecl.ptype_attributes;
|
||||||
|
type_immediate = false;
|
||||||
} in
|
} in
|
||||||
|
|
||||||
(* Check constraints *)
|
(* Check constraints *)
|
||||||
|
@ -879,11 +882,28 @@ let is_sharp id =
|
||||||
let s = Ident.name id in
|
let s = Ident.name id in
|
||||||
String.length s > 0 && s.[0] = '#'
|
String.length s > 0 && s.[0] = '#'
|
||||||
|
|
||||||
let rec compute_variance_fixpoint env decls required variances =
|
let marked_as_immediate decl =
|
||||||
|
List.exists
|
||||||
|
(fun (loc, _) -> loc.txt = "immediate")
|
||||||
|
decl.type_attributes
|
||||||
|
|
||||||
|
let compute_immediacy env tdecl =
|
||||||
|
match (tdecl.type_kind, tdecl.type_manifest) with
|
||||||
|
| (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
|
||||||
|
|
||||||
|
(* Computes the fixpoint for the variance and immediacy of type declarations *)
|
||||||
|
|
||||||
|
let rec compute_properties_fixpoint env decls required variances immediacies =
|
||||||
let new_decls =
|
let new_decls =
|
||||||
List.map2
|
List.map2
|
||||||
(fun (id, decl) variance -> id, {decl with type_variance = variance})
|
(fun (id, decl) (variance, immediacy) ->
|
||||||
decls variances
|
id, {decl with type_variance = variance; type_immediate = immediacy})
|
||||||
|
decls (List.combine variances immediacies)
|
||||||
in
|
in
|
||||||
let new_env =
|
let new_env =
|
||||||
List.fold_right
|
List.fold_right
|
||||||
|
@ -897,8 +917,13 @@ let rec compute_variance_fixpoint env decls required variances =
|
||||||
in
|
in
|
||||||
let new_variances =
|
let new_variances =
|
||||||
List.map2 (List.map2 Variance.union) new_variances variances in
|
List.map2 (List.map2 Variance.union) new_variances variances in
|
||||||
if new_variances <> variances then
|
let new_immediacies =
|
||||||
compute_variance_fixpoint env decls required new_variances
|
List.map
|
||||||
|
(fun (id, decl) -> compute_immediacy new_env decl)
|
||||||
|
new_decls
|
||||||
|
in
|
||||||
|
if new_variances <> variances || new_immediacies <> immediacies then
|
||||||
|
compute_properties_fixpoint env decls required new_variances new_immediacies
|
||||||
else begin
|
else begin
|
||||||
(* List.iter (fun (id, decl) ->
|
(* List.iter (fun (id, decl) ->
|
||||||
Printf.eprintf "%s:" (Ident.name id);
|
Printf.eprintf "%s:" (Ident.name id);
|
||||||
|
@ -907,6 +932,11 @@ let rec compute_variance_fixpoint env decls required variances =
|
||||||
decl.type_variance;
|
decl.type_variance;
|
||||||
prerr_endline "")
|
prerr_endline "")
|
||||||
new_decls; *)
|
new_decls; *)
|
||||||
|
List.iter (fun (_, decl) ->
|
||||||
|
if (marked_as_immediate decl) && (not decl.type_immediate) then
|
||||||
|
raise (Error (decl.type_loc, Bad_immediate_attribute))
|
||||||
|
else ())
|
||||||
|
new_decls;
|
||||||
List.iter2
|
List.iter2
|
||||||
(fun (id, decl) req -> if not (is_sharp id) then
|
(fun (id, decl) req -> if not (is_sharp id) then
|
||||||
ignore (compute_variance_decl new_env true decl req))
|
ignore (compute_variance_decl new_env true decl req))
|
||||||
|
@ -935,8 +965,11 @@ let compute_variance_decls env cldecls =
|
||||||
(add_injectivity variance, ci.ci_loc) :: req)
|
(add_injectivity variance, ci.ci_loc) :: req)
|
||||||
cldecls ([],[])
|
cldecls ([],[])
|
||||||
in
|
in
|
||||||
let variances = List.map init_variance decls in
|
let (decls, _) =
|
||||||
let (decls, _) = compute_variance_fixpoint env decls required variances in
|
compute_properties_fixpoint env decls required
|
||||||
|
(List.map init_variance decls)
|
||||||
|
(List.map (fun _ -> false) decls)
|
||||||
|
in
|
||||||
List.map2
|
List.map2
|
||||||
(fun (_,decl) (_, _, cl_abbr, clty, cltydef, _) ->
|
(fun (_,decl) (_, _, cl_abbr, clty, cltydef, _) ->
|
||||||
let variance = decl.type_variance in
|
let variance = decl.type_variance in
|
||||||
|
@ -1117,7 +1150,9 @@ let transl_type_decl env rec_flag sdecl_list =
|
||||||
sdecl_list
|
sdecl_list
|
||||||
in
|
in
|
||||||
let final_decls, final_env =
|
let final_decls, final_env =
|
||||||
compute_variance_fixpoint env decls required (List.map init_variance decls)
|
compute_properties_fixpoint env decls required
|
||||||
|
(List.map init_variance decls)
|
||||||
|
(List.map (fun _ -> false) decls)
|
||||||
in
|
in
|
||||||
(* Check re-exportation *)
|
(* Check re-exportation *)
|
||||||
List.iter2 (check_abbrev final_env) sdecl_list final_decls;
|
List.iter2 (check_abbrev final_env) sdecl_list final_decls;
|
||||||
|
@ -1541,6 +1576,7 @@ let transl_with_constraint env id row_path orig_decl sdecl =
|
||||||
type_newtype_level = None;
|
type_newtype_level = None;
|
||||||
type_loc = sdecl.ptype_loc;
|
type_loc = sdecl.ptype_loc;
|
||||||
type_attributes = sdecl.ptype_attributes;
|
type_attributes = sdecl.ptype_attributes;
|
||||||
|
type_immediate = false;
|
||||||
}
|
}
|
||||||
in
|
in
|
||||||
begin match row_path with None -> ()
|
begin match row_path with None -> ()
|
||||||
|
@ -1550,10 +1586,12 @@ let transl_with_constraint env id row_path orig_decl sdecl =
|
||||||
| Some ty -> raise(Error(sdecl.ptype_loc, Unbound_type_var(ty,decl)))
|
| Some ty -> raise(Error(sdecl.ptype_loc, Unbound_type_var(ty,decl)))
|
||||||
end;
|
end;
|
||||||
let decl = name_recursion sdecl id decl in
|
let decl = name_recursion sdecl id decl in
|
||||||
let decl =
|
let type_variance =
|
||||||
{decl with type_variance =
|
|
||||||
compute_variance_decl env true decl
|
compute_variance_decl env true decl
|
||||||
(add_injectivity (List.map snd sdecl.ptype_params), sdecl.ptype_loc)} in
|
(add_injectivity (List.map snd sdecl.ptype_params), sdecl.ptype_loc)
|
||||||
|
in
|
||||||
|
let type_immediate = compute_immediacy env decl in
|
||||||
|
let decl = {decl with type_variance; type_immediate} in
|
||||||
Ctype.end_def();
|
Ctype.end_def();
|
||||||
generalize_decl decl;
|
generalize_decl decl;
|
||||||
{
|
{
|
||||||
|
@ -1585,6 +1623,7 @@ let abstract_type_decl arity =
|
||||||
type_newtype_level = None;
|
type_newtype_level = None;
|
||||||
type_loc = Location.none;
|
type_loc = Location.none;
|
||||||
type_attributes = [];
|
type_attributes = [];
|
||||||
|
type_immediate = false;
|
||||||
} in
|
} in
|
||||||
Ctype.end_def();
|
Ctype.end_def();
|
||||||
generalize_decl decl;
|
generalize_decl decl;
|
||||||
|
@ -1826,6 +1865,10 @@ let report_error ppf = function
|
||||||
"The attribute '%s' should be attached to a direct argument or \
|
"The attribute '%s' should be attached to a direct argument or \
|
||||||
result of the primitive, it should not occur deeply into its type"
|
result of the primitive, it should not occur deeply into its type"
|
||||||
(match kind with Unboxed -> "@unboxed" | Untagged -> "@untagged")
|
(match kind with Unboxed -> "@unboxed" | Untagged -> "@untagged")
|
||||||
|
| Bad_immediate_attribute ->
|
||||||
|
fprintf ppf "@[%s@ %s@]"
|
||||||
|
"Types marked with the immediate attribute must be"
|
||||||
|
"non-pointer types like int or bool"
|
||||||
|
|
||||||
let () =
|
let () =
|
||||||
Location.register_error_of_exn
|
Location.register_error_of_exn
|
||||||
|
|
|
@ -88,6 +88,7 @@ type error =
|
||||||
| Multiple_native_repr_attributes
|
| Multiple_native_repr_attributes
|
||||||
| Cannot_unbox_or_untag_type of native_repr_kind
|
| Cannot_unbox_or_untag_type of native_repr_kind
|
||||||
| Deep_unbox_or_untag_attribute of native_repr_kind
|
| Deep_unbox_or_untag_attribute of native_repr_kind
|
||||||
|
| Bad_immediate_attribute
|
||||||
|
|
||||||
exception Error of Location.t * error
|
exception Error of Location.t * error
|
||||||
|
|
||||||
|
|
|
@ -177,6 +177,7 @@ let merge_constraint initial_env loc sg constr =
|
||||||
type_loc = sdecl.ptype_loc;
|
type_loc = sdecl.ptype_loc;
|
||||||
type_newtype_level = None;
|
type_newtype_level = None;
|
||||||
type_attributes = [];
|
type_attributes = [];
|
||||||
|
type_immediate = false;
|
||||||
}
|
}
|
||||||
and id_row = Ident.create (s^"#row") in
|
and id_row = Ident.create (s^"#row") in
|
||||||
let initial_env =
|
let initial_env =
|
||||||
|
|
|
@ -145,6 +145,7 @@ type type_declaration =
|
||||||
type_newtype_level: (int * int) option;
|
type_newtype_level: (int * int) option;
|
||||||
type_loc: Location.t;
|
type_loc: Location.t;
|
||||||
type_attributes: Parsetree.attributes;
|
type_attributes: Parsetree.attributes;
|
||||||
|
type_immediate: bool;
|
||||||
}
|
}
|
||||||
|
|
||||||
and type_kind =
|
and type_kind =
|
||||||
|
|
|
@ -290,6 +290,7 @@ type type_declaration =
|
||||||
(* definition level * expansion level *)
|
(* definition level * expansion level *)
|
||||||
type_loc: Location.t;
|
type_loc: Location.t;
|
||||||
type_attributes: Parsetree.attributes;
|
type_attributes: Parsetree.attributes;
|
||||||
|
type_immediate: bool; (* true iff type should not be a pointer *)
|
||||||
}
|
}
|
||||||
|
|
||||||
and type_kind =
|
and type_kind =
|
||||||
|
|
Loading…
Reference in New Issue