Typedecl: split immediacy to a separate unit Typedecl_variance
get_unboxed_type_representation is used in several other modules, and split into its own Typedecl_unboxed unit. (pair-programming with Gabriel Scherer)master
parent
24ea989c02
commit
ca227428f4
55
.depend
55
.depend
|
@ -411,28 +411,40 @@ typing/typecore.cmi : typing/types.cmi typing/typedtree.cmi typing/path.cmi \
|
|||
typing/annot.cmi
|
||||
typing/typedecl.cmo : utils/warnings.cmi typing/typetexp.cmi \
|
||||
typing/types.cmi typing/typedtree.cmi typing/typedecl_variance.cmi \
|
||||
typing/typedecl_properties.cmi typing/subst.cmi typing/printtyp.cmi \
|
||||
typing/primitive.cmi typing/predef.cmi typing/path.cmi \
|
||||
parsing/parsetree.cmi typing/oprint.cmi utils/misc.cmi \
|
||||
parsing/longident.cmi parsing/location.cmi typing/includecore.cmi \
|
||||
typing/ident.cmi typing/env.cmi typing/datarepr.cmi typing/ctype.cmi \
|
||||
utils/config.cmi utils/clflags.cmi parsing/builtin_attributes.cmi \
|
||||
typing/btype.cmi parsing/attr_helper.cmi parsing/asttypes.cmi \
|
||||
parsing/ast_iterator.cmi parsing/ast_helper.cmi typing/typedecl.cmi
|
||||
typing/typedecl_unboxed.cmi typing/typedecl_immediacy.cmi \
|
||||
typing/subst.cmi typing/printtyp.cmi typing/primitive.cmi \
|
||||
typing/predef.cmi typing/path.cmi parsing/parsetree.cmi typing/oprint.cmi \
|
||||
utils/misc.cmi parsing/longident.cmi parsing/location.cmi \
|
||||
typing/includecore.cmi typing/ident.cmi typing/env.cmi \
|
||||
typing/datarepr.cmi typing/ctype.cmi utils/config.cmi utils/clflags.cmi \
|
||||
parsing/builtin_attributes.cmi typing/btype.cmi parsing/attr_helper.cmi \
|
||||
parsing/asttypes.cmi parsing/ast_iterator.cmi parsing/ast_helper.cmi \
|
||||
typing/typedecl.cmi
|
||||
typing/typedecl.cmx : utils/warnings.cmx typing/typetexp.cmx \
|
||||
typing/types.cmx typing/typedtree.cmx typing/typedecl_variance.cmx \
|
||||
typing/typedecl_properties.cmx typing/subst.cmx typing/printtyp.cmx \
|
||||
typing/primitive.cmx typing/predef.cmx typing/path.cmx \
|
||||
parsing/parsetree.cmi typing/oprint.cmx utils/misc.cmx \
|
||||
parsing/longident.cmx parsing/location.cmx typing/includecore.cmx \
|
||||
typing/ident.cmx typing/env.cmx typing/datarepr.cmx typing/ctype.cmx \
|
||||
utils/config.cmx utils/clflags.cmx parsing/builtin_attributes.cmx \
|
||||
typing/btype.cmx parsing/attr_helper.cmx parsing/asttypes.cmi \
|
||||
parsing/ast_iterator.cmx parsing/ast_helper.cmx typing/typedecl.cmi
|
||||
typing/typedecl_unboxed.cmx typing/typedecl_immediacy.cmx \
|
||||
typing/subst.cmx typing/printtyp.cmx typing/primitive.cmx \
|
||||
typing/predef.cmx typing/path.cmx parsing/parsetree.cmi typing/oprint.cmx \
|
||||
utils/misc.cmx parsing/longident.cmx parsing/location.cmx \
|
||||
typing/includecore.cmx typing/ident.cmx typing/env.cmx \
|
||||
typing/datarepr.cmx typing/ctype.cmx utils/config.cmx utils/clflags.cmx \
|
||||
parsing/builtin_attributes.cmx typing/btype.cmx parsing/attr_helper.cmx \
|
||||
parsing/asttypes.cmi parsing/ast_iterator.cmx parsing/ast_helper.cmx \
|
||||
typing/typedecl.cmi
|
||||
typing/typedecl.cmi : typing/types.cmi typing/typedtree.cmi \
|
||||
typing/typedecl_variance.cmi typing/path.cmi parsing/parsetree.cmi \
|
||||
parsing/longident.cmi parsing/location.cmi typing/includecore.cmi \
|
||||
typing/ident.cmi typing/env.cmi typing/ctype.cmi parsing/asttypes.cmi
|
||||
typing/typedecl_variance.cmi typing/typedecl_immediacy.cmi \
|
||||
typing/path.cmi parsing/parsetree.cmi parsing/longident.cmi \
|
||||
parsing/location.cmi typing/includecore.cmi typing/ident.cmi \
|
||||
typing/env.cmi typing/ctype.cmi parsing/asttypes.cmi
|
||||
typing/typedecl_immediacy.cmo : typing/types.cmi typing/typedecl_unboxed.cmi \
|
||||
typing/typedecl_properties.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 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 parsing/location.cmi typing/ident.cmi \
|
||||
typing/env.cmi
|
||||
typing/typedecl_properties.cmo : typing/types.cmi typing/ident.cmi \
|
||||
typing/env.cmi parsing/builtin_attributes.cmi \
|
||||
typing/typedecl_properties.cmi
|
||||
|
@ -441,6 +453,11 @@ typing/typedecl_properties.cmx : typing/types.cmx typing/ident.cmx \
|
|||
typing/typedecl_properties.cmi
|
||||
typing/typedecl_properties.cmi : typing/types.cmi typing/ident.cmi \
|
||||
typing/env.cmi
|
||||
typing/typedecl_unboxed.cmo : typing/types.cmi typing/predef.cmi \
|
||||
typing/env.cmi typing/ctype.cmi typing/typedecl_unboxed.cmi
|
||||
typing/typedecl_unboxed.cmx : typing/types.cmx typing/predef.cmx \
|
||||
typing/env.cmx typing/ctype.cmx typing/typedecl_unboxed.cmi
|
||||
typing/typedecl_unboxed.cmi : typing/types.cmi typing/env.cmi
|
||||
typing/typedecl_variance.cmo : typing/types.cmi typing/typedtree.cmi \
|
||||
typing/typedecl_properties.cmi parsing/parsetree.cmi parsing/location.cmi \
|
||||
typing/ident.cmi typing/env.cmi typing/ctype.cmi typing/btype.cmi \
|
||||
|
|
1
Makefile
1
Makefile
|
@ -100,6 +100,7 @@ TYPING=typing/ident.cmo typing/path.cmo \
|
|||
typing/includemod.cmo typing/typetexp.cmo typing/printpat.cmo \
|
||||
typing/parmatch.cmo typing/stypes.cmo \
|
||||
typing/typedecl_properties.cmo typing/typedecl_variance.cmo \
|
||||
typing/typedecl_unboxed.cmo typing/typedecl_immediacy.cmo \
|
||||
typing/typedecl.cmo typing/typeopt.cmo \
|
||||
typing/rec_check.cmo typing/typecore.cmo typing/typeclass.cmo \
|
||||
typing/typemod.cmo
|
||||
|
|
|
@ -55,7 +55,7 @@ type error =
|
|||
| Multiple_native_repr_attributes
|
||||
| Cannot_unbox_or_untag_type of native_repr_kind
|
||||
| Deep_unbox_or_untag_attribute of native_repr_kind
|
||||
| Bad_immediate_attribute
|
||||
| Immediacy of Typedecl_immediacy.error
|
||||
| Bad_unboxed_attribute of string
|
||||
| Wrong_unboxed_type_float
|
||||
| Boxed_and_unboxed
|
||||
|
@ -129,37 +129,8 @@ let update_type temp_env env id loc =
|
|||
with Ctype.Unify trace ->
|
||||
raise (Error(loc, Type_clash (env, trace)))
|
||||
|
||||
(* 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
|
||||
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
|
||||
| {type_params; type_kind =
|
||||
Type_record ([{ld_type = ty2; _}], _)
|
||||
| Type_variant [{cd_args = Cstr_tuple [ty2]; _}]
|
||||
| Type_variant [{cd_args = Cstr_record [{ld_type = ty2; _}]; _}]}
|
||||
|
||||
->
|
||||
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
|
||||
(* This case can occur when checking a recursive unboxed type
|
||||
declaration. *)
|
||||
| _ -> assert false (* only the above can be unboxed *)
|
||||
end
|
||||
| _ -> Some ty
|
||||
|
||||
let get_unboxed_type_representation env ty =
|
||||
(* Do not give too much fuel: PR#7424 *)
|
||||
get_unboxed_type_representation env ty 100
|
||||
;;
|
||||
let get_unboxed_type_representation =
|
||||
Typedecl_unboxed.get_unboxed_type_representation
|
||||
|
||||
(* Determine if a type's values are represented by floats at run-time. *)
|
||||
let is_float env ty =
|
||||
|
@ -839,51 +810,6 @@ let check_abbrev_recursion env id_loc_list to_check tdecl =
|
|||
let id = tdecl.typ_id in
|
||||
check_recursion env (List.assoc id id_loc_list) (Path.Pident id) decl to_check
|
||||
|
||||
let marked_as_immediate decl =
|
||||
Builtin_attributes.immediate decl.type_attributes
|
||||
|
||||
let compute_immediacy env tdecl =
|
||||
match (tdecl.type_kind, tdecl.type_manifest) with
|
||||
| (Type_variant [{cd_args = Cstr_tuple [arg]; _}], _)
|
||||
| (Type_variant [{cd_args = Cstr_record [{ld_type = arg; _}]; _}], _)
|
||||
| (Type_record ([{ld_type = arg; _}], _), _)
|
||||
when tdecl.type_unboxed.unboxed ->
|
||||
begin match get_unboxed_type_representation env arg with
|
||||
| Some argrepr -> not (Ctype.maybe_pointer_type env argrepr)
|
||||
| None -> false
|
||||
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
|
||||
|
||||
let immediacy : (bool, 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 compute env decl () =
|
||||
compute_immediacy 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
|
||||
{
|
||||
eq;
|
||||
merge;
|
||||
default;
|
||||
compute;
|
||||
update_decl;
|
||||
check;
|
||||
}
|
||||
|
||||
let compute_immediacy_decls env decls =
|
||||
Typedecl_properties.compute_property_noreq immediacy env decls
|
||||
|
||||
(* Check multiple declarations of labels/constructors *)
|
||||
|
||||
let check_duplicates sdecl_list =
|
||||
|
@ -1063,9 +989,11 @@ let transl_type_decl env rec_flag sdecl_list =
|
|||
decls
|
||||
|> name_recursion_decls sdecl_list
|
||||
|> Typedecl_variance.update_decls env sdecl_list
|
||||
|> compute_immediacy_decls env
|
||||
|> Typedecl_immediacy.update_decls env
|
||||
with
|
||||
| Typedecl_variance.Error (loc, err) -> raise (Error (loc, Variance err)) in
|
||||
| Typedecl_variance.Error (loc, err) -> raise (Error (loc, Variance err))
|
||||
| Typedecl_immediacy.Error (loc, err) -> raise (Error (loc, Immediacy err))
|
||||
in
|
||||
(* Compute the final environment with variance and immediacy *)
|
||||
let final_env = add_types_to_env decls env in
|
||||
(* Check re-exportation *)
|
||||
|
@ -1577,7 +1505,9 @@ let transl_with_constraint env id row_path orig_decl sdecl =
|
|||
env ~check:true decl (Typedecl_variance.variance_of_sdecl sdecl)
|
||||
with Typedecl_variance.Error (loc, err) ->
|
||||
raise (Error (loc, Variance err)) in
|
||||
let type_immediate = compute_immediacy env decl in
|
||||
let type_immediate =
|
||||
(* Typedecl_immediacy.compute_decl never raises *)
|
||||
Typedecl_immediacy.compute_decl env decl in
|
||||
let decl = {decl with type_variance; type_immediate} in
|
||||
Ctype.end_def();
|
||||
generalize_decl decl;
|
||||
|
@ -1866,7 +1796,7 @@ let report_error ppf = function
|
|||
a direct argument or result of the primitive,@ \
|
||||
it should not occur deeply into its type.@]"
|
||||
(match kind with Unboxed -> "@unboxed" | Untagged -> "@untagged")
|
||||
| Bad_immediate_attribute ->
|
||||
| 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"
|
||||
|
|
|
@ -57,7 +57,6 @@ val is_fixed_type : Parsetree.type_declaration -> bool
|
|||
(* for typeopt.ml *)
|
||||
val get_unboxed_type_representation: Env.t -> type_expr -> type_expr option
|
||||
|
||||
|
||||
type native_repr_kind = Unboxed | Untagged
|
||||
|
||||
type error =
|
||||
|
@ -89,7 +88,7 @@ type error =
|
|||
| Multiple_native_repr_attributes
|
||||
| Cannot_unbox_or_untag_type of native_repr_kind
|
||||
| Deep_unbox_or_untag_attribute of native_repr_kind
|
||||
| Bad_immediate_attribute
|
||||
| Immediacy of Typedecl_immediacy.error
|
||||
| Bad_unboxed_attribute of string
|
||||
| Wrong_unboxed_type_float
|
||||
| Boxed_and_unboxed
|
||||
|
|
|
@ -0,0 +1,62 @@
|
|||
(**************************************************************************)
|
||||
(* *)
|
||||
(* OCaml *)
|
||||
(* *)
|
||||
(* Gabriel Scherer, projet Parsifal, INRIA Saclay *)
|
||||
(* Rodolphe Lepigre, projet Deducteam, INRIA Saclay *)
|
||||
(* *)
|
||||
(* Copyright 2018 Institut National de Recherche en Informatique et *)
|
||||
(* en Automatique. *)
|
||||
(* *)
|
||||
(* 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. *)
|
||||
(* *)
|
||||
(**************************************************************************)
|
||||
|
||||
open Types
|
||||
|
||||
type error = Bad_immediate_attribute
|
||||
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]; _}], _)
|
||||
| (Type_variant [{cd_args = Cstr_record [{ld_type = arg; _}]; _}], _)
|
||||
| (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
|
||||
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
|
||||
|
||||
let property : (bool, 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 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
|
||||
{
|
||||
eq;
|
||||
merge;
|
||||
default;
|
||||
compute;
|
||||
update_decl;
|
||||
check;
|
||||
}
|
||||
|
||||
let update_decls env decls =
|
||||
Typedecl_properties.compute_property_noreq property env decls
|
|
@ -0,0 +1,11 @@
|
|||
type error = Bad_immediate_attribute
|
||||
exception Error of Location.t * error
|
||||
|
||||
val compute_decl : Env.t -> Types.type_declaration -> bool
|
||||
|
||||
val property : (bool, unit) Typedecl_properties.property
|
||||
|
||||
val update_decls :
|
||||
Env.t ->
|
||||
(Ident.t * Typedecl_properties.decl) list ->
|
||||
(Ident.t * Typedecl_properties.decl) list
|
|
@ -0,0 +1,49 @@
|
|||
(**************************************************************************)
|
||||
(* *)
|
||||
(* OCaml *)
|
||||
(* *)
|
||||
(* Gabriel Scherer, projet Parsifal, INRIA Saclay *)
|
||||
(* Rodolphe Lepigre, projet Deducteam, INRIA Saclay *)
|
||||
(* *)
|
||||
(* Copyright 2018 Institut National de Recherche en Informatique et *)
|
||||
(* en Automatique. *)
|
||||
(* *)
|
||||
(* 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. *)
|
||||
(* *)
|
||||
(**************************************************************************)
|
||||
|
||||
open Types
|
||||
|
||||
(* 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
|
||||
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
|
||||
| {type_params; type_kind =
|
||||
Type_record ([{ld_type = ty2; _}], _)
|
||||
| Type_variant [{cd_args = Cstr_tuple [ty2]; _}]
|
||||
| Type_variant [{cd_args = Cstr_record [{ld_type = ty2; _}]; _}]}
|
||||
|
||||
->
|
||||
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
|
||||
(* This case can occur when checking a recursive unboxed type
|
||||
declaration. *)
|
||||
| _ -> assert false (* only the above can be unboxed *)
|
||||
end
|
||||
| _ -> Some ty
|
||||
|
||||
let get_unboxed_type_representation env ty =
|
||||
(* Do not give too much fuel: PR#7424 *)
|
||||
get_unboxed_type_representation env ty 100
|
||||
;;
|
|
@ -0,0 +1,4 @@
|
|||
open Types
|
||||
|
||||
(* for typeopt.ml *)
|
||||
val get_unboxed_type_representation: Env.t -> type_expr -> type_expr option
|
Loading…
Reference in New Issue