diff options
Diffstat (limited to 'typing')
| -rw-r--r-- | typing/btype.ml | 14 | ||||
| -rw-r--r-- | typing/ctype.ml | 14 | ||||
| -rw-r--r-- | typing/env.ml | 12 | ||||
| -rw-r--r-- | typing/subst.ml | 61 | ||||
| -rw-r--r-- | typing/subst.mli | 2 |
5 files changed, 71 insertions, 32 deletions
diff --git a/typing/btype.ml b/typing/btype.ml index dd5ec5d4f6..35d18909b4 100644 --- a/typing/btype.ml +++ b/typing/btype.ml @@ -149,6 +149,7 @@ let rec iter_abbrev f = function | Mlink rem -> iter_abbrev f !rem let copy_row f fixed row keep more = + let bound = ref [] in let fields = List.map (fun (l, fi) -> l, match row_field_repr fi with @@ -156,15 +157,19 @@ let copy_row f fixed row keep more = | Reither(c, tl, m, e) -> let e = if keep then e else ref None in let m = if row.row_fixed then fixed else m in - Reither(c, List.map f tl, m , e) + let tl = List.map f tl in + bound := List.filter + (function {desc=Tconstr(_,[],_)} -> false | _ -> true) + (List.map repr tl) + @ !bound; + Reither(c, tl, m, e) | _ -> fi) row.row_fields in let name = match row.row_name with None -> None | Some (path, tl) -> Some (path, List.map f tl) in { row_fields = fields; row_more = more; - row_bound = List.map f row.row_bound; - row_fixed = row.row_fixed && fixed; + row_bound = !bound; row_fixed = row.row_fixed && fixed; row_closed = row.row_closed; row_name = name; } let rec copy_kind = function @@ -194,6 +199,9 @@ let rec copy_type_desc f = function | Tunivar -> Tunivar | Tpoly (ty, tyl) -> Tpoly (f ty, List.map f tyl) + +(* Utilities for copying *) + let saved_desc = ref [] (* Saved association of generic nodes with their description. *) diff --git a/typing/ctype.ml b/typing/ctype.ml index 3a22b553c1..1bfe2538bf 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -2786,12 +2786,15 @@ let rec normalize_type_rec env ty = f else f | _ -> f) - row.row_fields + row.row_fields in + let fields = + List.sort (fun (p,_) (q,_) -> compare p q) + (List.filter (fun (_,fi) -> fi <> Rabsent) fields) and bound = List.fold_left (fun tyl ty -> if List.memq ty tyl then tyl else ty :: tyl) [] (List.map repr row.row_bound) in ty.desc <- Tvariant {row with row_fields = fields; row_bound = bound} - | Tobject (_, nm) -> + | Tobject (fi, nm) -> begin match !nm with | None -> () | Some (n, v :: l) -> @@ -2803,7 +2806,12 @@ let rec normalize_type_rec env ty = end | _ -> fatal_error "Ctype.normalize_type_rec" - end + end; + let fi = repr fi in + if fi.level < lowest_level then () else + let fields, row = flatten_fields fi in + let fi' = build_fields fi.level fields row in + fi.desc <- fi'.desc | _ -> () end; iter_type_expr (normalize_type_rec env) ty diff --git a/typing/env.ml b/typing/env.ml index 060363b2be..ddaa92e28a 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -719,9 +719,8 @@ let imported_units() = let save_signature sg modname filename = Btype.cleanup_abbrev (); - let comps = - components_of_module empty Subst.identity - (Pident(Ident.create_persistent modname)) (Tmty_signature sg) in + Subst.reset_for_saving (); + let sg = Subst.signature (Subst.for_saving Subst.identity) sg in let oc = open_out_bin filename in try output_string oc cmi_magic_number; @@ -730,16 +729,19 @@ let save_signature sg modname filename = let crc = Digest.file filename in let crcs = (modname, crc) :: imported_units() in output_value oc crcs; + close_out oc; (* Enter signature in persistent table so that imported_unit() will also return its crc *) + let comps = + components_of_module empty Subst.identity + (Pident(Ident.create_persistent modname)) (Tmty_signature sg) in let ps = { ps_name = modname; ps_sig = sg; ps_comps = comps; ps_crcs = crcs; ps_filename = filename } in - Hashtbl.add persistent_structures modname ps; - close_out oc + Hashtbl.add persistent_structures modname ps with exn -> close_out oc; remove_file filename; diff --git a/typing/subst.ml b/typing/subst.ml index 45fe325756..66646c157c 100644 --- a/typing/subst.ml +++ b/typing/subst.ml @@ -22,25 +22,20 @@ open Btype type t = { types: (Ident.t, Path.t) Tbl.t; modules: (Ident.t, Path.t) Tbl.t; - modtypes: (Ident.t, module_type) Tbl.t } + modtypes: (Ident.t, module_type) Tbl.t; + for_saving: bool } let identity = - { types = Tbl.empty; modules = Tbl.empty; modtypes = Tbl.empty } + { types = Tbl.empty; modules = Tbl.empty; modtypes = Tbl.empty; + for_saving = false } -let add_type id p s = - { types = Tbl.add id p s.types; - modules = s.modules; - modtypes = s.modtypes } +let add_type id p s = { s with types = Tbl.add id p s.types } -let add_module id p s = - { types = s.types; - modules = Tbl.add id p s.modules; - modtypes = s.modtypes } +let add_module id p s = { s with modules = Tbl.add id p s.modules } -let add_modtype id ty s = - { types = s.types; - modules = s.modules; - modtypes = Tbl.add id ty s.modtypes } +let add_modtype id ty s = { s with modtypes = Tbl.add id ty s.modtypes } + +let for_saving s = { s with for_saving = true } let rec module_path s = function Pident id as p -> @@ -58,12 +53,23 @@ let type_path s = function | Papply(p1, p2) -> fatal_error "Subst.type_path" +(* Special type ids for saved signatures *) + +let new_id = ref (-1) +let reset_for_saving () = new_id := -1 + +let newpersty desc = + decr new_id; { desc = desc; level = generic_level; id = !new_id } + (* Similar to [Ctype.nondep_type_rec]. *) let rec typexp s ty = let ty = repr ty in match ty.desc with Tvar | Tunivar -> - ty + if s.for_saving then + let ty' = newpersty ty.desc in + save_desc ty ty.desc; ty.desc <- Tsubst ty'; ty' + else ty | Tsubst ty -> ty (* cannot do it, since it would omit subsitution @@ -73,7 +79,8 @@ let rec typexp s ty = | _ -> let desc = ty.desc in save_desc ty desc; - let ty' = newgenvar () in (* Stub *) + (* Make a stub *) + let ty' = if s.for_saving then newpersty Tvar else newgenvar () in ty.desc <- Tsubst ty'; ty'.desc <- begin match desc with @@ -90,18 +97,27 @@ let rec typexp s ty = let more = repr row.row_more in (* We must substitute in a subtle way *) begin match more.desc with - Tsubst ty2 -> + Tsubst ({desc=Tvariant _} as ty2) -> (* This variant type has been already copied *) ty.desc <- Tsubst ty2; (* avoid Tlink in the new type *) Tlink ty2 | _ -> let static = static_row row in + (* Various cases for the row variable *) + let more' = + match more.desc with Tsubst ty -> ty + | _ -> + if s.for_saving then newpersty more.desc else + if static then newgenvar () else more + in (* Register new type first for recursion *) save_desc more more.desc; more.desc <- ty.desc; - let more' = if static then newgenvar () else more in (* Return a new copy *) - let row = copy_row (typexp s) true row true more' in + let row = + copy_row (typexp s) true row (not s.for_saving) more' in + let row = + if s.for_saving then {row with row_bound = []} else row in match row.row_name with Some (p, tl) -> Tvariant {row with row_name = Some (type_path s p, tl)} @@ -115,6 +131,7 @@ let rec typexp s ty = | Fabsent -> Tlink (typexp s t2) | Fvar _ (* {contents = None} *) as k -> + let k = if s.for_saving then Fvar(ref None) else k in Tfield(label, k, typexp s t1, typexp s t2) end | _ -> copy_type_desc (typexp s) desc @@ -183,7 +200,8 @@ let class_declaration s decl = | Some ty -> Some (typexp s ty) end } in - cleanup_types (); + (* Do not clean up if saving: next is cltype_declaration *) + if not s.for_saving then cleanup_types (); decl let cltype_declaration s decl = @@ -192,7 +210,8 @@ let cltype_declaration s decl = clty_type = class_type s decl.clty_type; clty_path = type_path s decl.clty_path } in - cleanup_types (); + (* Do not clean up if saving: next is type_declaration *) + if not s.for_saving then cleanup_types (); decl let class_type s cty = diff --git a/typing/subst.mli b/typing/subst.mli index 1da0cd18c0..b2220bb49e 100644 --- a/typing/subst.mli +++ b/typing/subst.mli @@ -35,6 +35,8 @@ val identity: t val add_type: Ident.t -> Path.t -> t -> t val add_module: Ident.t -> Path.t -> t -> t val add_modtype: Ident.t -> module_type -> t -> t +val for_saving: t -> t +val reset_for_saving: unit -> unit val type_expr: t -> type_expr -> type_expr val class_type: t -> class_type -> class_type |