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

Fix PR#7519, but high cost in update_level

master
Jacques Garrigue 2017-08-02 14:25:58 +09:00
parent 177713ec02
commit 9aea65451d
2 changed files with 45 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

71
typing/ctype.ml
View File

@ -658,6 +658,35 @@ let rec generalize_spine ty =
List.iter generalize_spine tyl
| _ -> ()
(*
Check whether the abbreviation expands to a well-defined type.
During the typing of a class, abbreviations for correspondings
types expand to non-generic types.
*)
let generic_abbrev env path =
try
let (_, body, _) = Env.find_type_expansion path env in
(repr body).level = generic_level
with
Not_found ->
false
let generic_private_abbrev env path =
try
match Env.find_type path env with
{type_kind = Type_abstract;
type_private = Private;
type_manifest = Some body} ->
(repr body).level = generic_level
| _ -> false
with Not_found -> false
let is_contractive env p =
try
let decl = Env.find_type p env in
in_pervasives p && decl.type_manifest = None || is_datatype decl
with Not_found -> false
let forward_try_expand_once = (* Forward declaration *)
ref (fun _env _ty -> raise Cannot_expand)
@ -719,6 +748,19 @@ let rec update_level env level ty =
if level < get_level env p then raise (Unify [(ty, newvar2 level)]);
iter_type_expr (update_level env level) ty
end
| Tconstr(p, _tl, _abbrev) when generic_abbrev env p ->
let snap = snapshot () in
begin try
set_level ty level;
iter_type_expr (update_level env level) ty
with Unify _ -> try
backtrack snap;
link_type ty (!forward_try_expand_once env ty);
update_level env level ty
with Cannot_expand ->
set_level ty level;
iter_type_expr (update_level env level) ty
end
| Tpackage (p, nl, tl) when level < Path.binding_time p ->
let p' = normalize_package_path env p in
if Path.same p p' then raise (Unify [(ty, newvar2 level)]);
@ -1545,35 +1587,6 @@ let full_expand env ty =
| _ ->
ty
(*
Check whether the abbreviation expands to a well-defined type.
During the typing of a class, abbreviations for correspondings
types expand to non-generic types.
*)
let generic_abbrev env path =
try
let (_, body, _) = Env.find_type_expansion path env in
(repr body).level = generic_level
with
Not_found ->
false
let generic_private_abbrev env path =
try
match Env.find_type path env with
{type_kind = Type_abstract;
type_private = Private;
type_manifest = Some body} ->
(repr body).level = generic_level
| _ -> false
with Not_found -> false
let is_contractive env p =
try
let decl = Env.find_type p env in
in_pervasives p && decl.type_manifest = None || is_datatype decl
with Not_found -> false
(*****************)
(* Occur check *)

6
typing/typecore.ml
View File

@ -2800,7 +2800,7 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
let (id, new_env) = Env.enter_module name.txt modl.mod_type env in
Ctype.init_def(Ident.current_time());
Typetexp.widen context;
let body = type_expect new_env sbody ty_expected in
let body = type_expect new_env sbody (correct_levels ty_expected) in
(* go back to original level *)
end_def ();
(* Unification of body.exp_type with the fresh variable ty
@ -2809,11 +2809,11 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
type body.exp_type. Thus, this unification enforces the
scoping condition on "let module". *)
begin try
Ctype.unify_var new_env ty body.exp_type
Ctype.unify_var new_env ty body.exp_type;
with Unify _ ->
raise(Error(loc, env, Scoping_let_module(name.txt, body.exp_type)))
end;
re {
rue {
exp_desc = Texp_letmodule(id, name, modl, body);
exp_loc = loc; exp_extra = [];
exp_type = ty;