diff options
Diffstat (limited to 'typing')
| -rw-r--r-- | typing/env.ml | 158 | ||||
| -rw-r--r-- | typing/env.mli | 8 | ||||
| -rw-r--r-- | typing/envaux.ml | 4 | ||||
| -rw-r--r-- | typing/typecore.ml | 152 |
4 files changed, 90 insertions, 232 deletions
diff --git a/typing/env.ml b/typing/env.ml index d5e3f3557b..15808875ac 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -79,7 +79,7 @@ type summary = | Env_open of summary * Path.t | Env_functor_arg of summary * Ident.t | Env_constraints of summary * type_declaration Path.Map.t - | Env_copy_types of summary * string list + | Env_copy_types of summary | Env_persistent of summary * Ident.t type address = @@ -207,29 +207,37 @@ module IdTbl = current: 'a Ident.tbl; (** Local bindings since the last open *) - opened: 'a opened option; + layer: 'a layer; (** Symbolic representation of the last (innermost) open, if any. *) } - and 'a opened = { - root: Path.t; - (** The path of the opened module, to be prefixed in front of - its local names to produce a valid path in the current - environment. *) + and 'a layer = + | Open of { + root: Path.t; + (** The path of the opened module, to be prefixed in front of + its local names to produce a valid path in the current + environment. *) - components: 'a NameMap.t; - (** Components from the opened module. *) + components: 'a NameMap.t; + (** Components from the opened module. *) - using: (string -> ('a * 'a) option -> unit) option; - (** A callback to be applied when a component is used from this - "open". This is used to detect unused "opens". The - arguments are used to detect shadowing. *) + using: (string -> ('a * 'a) option -> unit) option; + (** A callback to be applied when a component is used from this + "open". This is used to detect unused "opens". The + arguments are used to detect shadowing. *) - next: 'a t; - (** The table before opening the module. *) - } + next: 'a t; + (** The table before opening the module. *) + } - let empty = { current = Ident.empty; opened = None } + | Map of { + f: ('a -> 'a); + next: 'a t; + } + + | Nothing + + let empty = { current = Ident.empty; layer = Nothing } let add id x tbl = {tbl with current = Ident.add id x tbl.current} @@ -245,15 +253,22 @@ module IdTbl = in { current = Ident.empty; - opened = Some {using; root; components; next}; + layer = Open {using; root; components; next}; + } + + let map f next = + { + current = Ident.empty; + layer = Map {f; next} } let rec find_same id tbl = try Ident.find_same id tbl.current with Not_found as exn -> - begin match tbl.opened with - | Some {next; _} -> find_same id next - | None -> raise exn + begin match tbl.layer with + | Open {next; _} -> find_same id next + | Map {f; next} -> f (find_same id next) + | Nothing -> raise exn end let rec find_name ~mark name tbl = @@ -261,8 +276,8 @@ module IdTbl = let (id, desc) = Ident.find_name name tbl.current in Pident id, desc with Not_found as exn -> - begin match tbl.opened with - | Some {using; root; next; components} -> + begin match tbl.layer with + | Open {using; root; next; components} -> begin try let descr = NameMap.find name components in let res = Pdot (root, name), descr in @@ -278,45 +293,29 @@ module IdTbl = with Not_found -> find_name ~mark name next end - | None -> + | Map {f; next} -> + let (p, desc) = find_name ~mark name next in + p, f desc + | Nothing -> raise exn end - let rec update name f tbl = - try - let (id, desc) = Ident.find_name name tbl.current in - let new_desc = f desc in - {tbl with current = Ident.add id new_desc tbl.current} - with Not_found -> - begin match tbl.opened with - | Some {root; using; next; components} -> - begin try - let desc = NameMap.find name components in - let new_desc = f desc in - let components = NameMap.add name new_desc components in - {tbl with opened = Some {root; using; next; components}} - with Not_found -> - let next = update name f next in - {tbl with opened = Some {root; using; next; components}} - end - | None -> - tbl - end - - - let rec find_all name tbl = List.map (fun (id, desc) -> Pident id, desc) (Ident.find_all name tbl.current) @ - match tbl.opened with - | None -> [] - | Some {root; using = _; next; components} -> - try + match tbl.layer with + | Nothing -> [] + | Open {root; using = _; next; components} -> + begin try let desc = NameMap.find name components in (Pdot (root, name), desc) :: find_all name next with Not_found -> find_all name next + end + | Map {f; next} -> + List.map (fun (p, desc) -> (p, f desc)) + (find_all name next) let rec fold_name f tbl acc = let acc = @@ -324,27 +323,30 @@ module IdTbl = (fun id d -> f (Ident.name id) (Pident id, d)) tbl.current acc in - match tbl.opened with - | Some {root; using = _; next; components} -> + match tbl.layer with + | Open {root; using = _; next; components} -> acc |> NameMap.fold (fun name desc -> f name (Pdot (root, name), desc)) components |> fold_name f next - | None -> + | Nothing -> + acc + | Map {f=g; next} -> acc + |> fold_name (fun name (path, desc) -> f name (path, g desc)) next let rec local_keys tbl acc = let acc = Ident.fold_all (fun k _ accu -> k::accu) tbl.current acc in - match tbl.opened with - | Some o -> local_keys o.next acc - | None -> acc + match tbl.layer with + | Open {next; _ } | Map {next; _} -> local_keys next acc + | Nothing -> acc let rec iter f tbl = Ident.iter (fun id desc -> f id (Pident id, desc)) tbl.current; - match tbl.opened with - | Some {root; using = _; next; components} -> + match tbl.layer with + | Open {root; using = _; next; components} -> NameMap.iter (fun s x -> let root_scope = Path.scope root in @@ -352,7 +354,9 @@ module IdTbl = (Pdot (root, s), x)) components; iter f next - | None -> () + | Map {f=g; next} -> + iter (fun id (path, desc) -> f id (path, g desc)) next + | Nothing -> () let diff_keys tbl1 tbl2 = let keys2 = local_keys tbl2 [] in @@ -1219,24 +1223,26 @@ let lookup_cltype ?loc ~mark lid env = lookup (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes) ?loc ~mark lid env -type copy_of_types = { - to_copy: string list; - initial_values: (value_description * address_lazy) IdTbl.t; - new_values: (value_description * address_lazy) IdTbl.t; -} - -let make_copy_of_types l env : copy_of_types = +let make_copy_of_types env0 = + let memo = Hashtbl.create 16 in + let copy t = + try + Hashtbl.find memo t.id + with Not_found -> + let t2 = Subst.type_expr Subst.identity t in + Hashtbl.add memo t.id t2; + t2 + in let f (desc, addr) = - {desc with val_type = Subst.type_expr Subst.identity desc.val_type}, addr + {desc with val_type = copy desc.val_type}, addr in let values = - List.fold_left (fun env s -> IdTbl.update s f env) env.values l + IdTbl.map f env0.values in - {to_copy = l; initial_values = env.values; new_values = values} - -let do_copy_types { to_copy = l; initial_values; new_values = values } env = - if initial_values != env.values then fatal_error "Env.do_copy_types"; - {env with values; summary = Env_copy_types (env.summary, l)} + (fun env -> + if env.values != env0.values then fatal_error "Env.make_copy_of_types"; + {env with values; summary = Env_copy_types env.summary} + ) let mark_value_used name vd = try Hashtbl.find value_declarations (name, vd.val_loc) () @@ -2384,8 +2390,8 @@ let filter_non_loaded_persistent f env = Env_functor_arg (filter_summary s ids, id) | Env_constraints (s, cstrs) -> Env_constraints (filter_summary s ids, cstrs) - | Env_copy_types (s, types) -> - Env_copy_types (filter_summary s ids, types) + | Env_copy_types s -> + Env_copy_types (filter_summary s ids) | Env_persistent (s, id) -> if String.Set.mem (Ident.name id) ids then filter_summary s (String.Set.remove (Ident.name id) ids) diff --git a/typing/env.mli b/typing/env.mli index cf7490db83..d521942b32 100644 --- a/typing/env.mli +++ b/typing/env.mli @@ -32,7 +32,7 @@ type summary = to skip, i.e. that won't be imported in the toplevel namespace. *) | Env_functor_arg of summary * Ident.t | Env_constraints of summary * type_declaration Path.Map.t - | Env_copy_types of summary * string list + | Env_copy_types of summary | Env_persistent of summary * Ident.t type address = @@ -144,11 +144,7 @@ val lookup_cltype: ?loc:Location.t -> ?mark:bool -> Longident.t -> t -> Path.t * class_type_declaration -type copy_of_types -val make_copy_of_types: string list -> t -> copy_of_types -val do_copy_types: copy_of_types -> t -> t -(** [do_copy_types copy env] will raise a fatal error if the values in - [env] are different from the env passed to [make_copy_of_types]. *) +val make_copy_of_types: t -> (t -> t) exception Recmodule (* Raise by lookup_module when the identifier refers diff --git a/typing/envaux.ml b/typing/envaux.ml index 2780cc045b..ddb792aa9b 100644 --- a/typing/envaux.ml +++ b/typing/envaux.ml @@ -80,9 +80,9 @@ let rec env_from_summary sum subst = Env.add_local_type (Subst.type_path subst path) (Subst.type_declaration subst info)) map (env_from_summary s subst) - | Env_copy_types (s, sl) -> + | Env_copy_types s -> let env = env_from_summary s subst in - Env.do_copy_types (Env.make_copy_of_types sl env) env + Env.make_copy_of_types env env | Env_persistent (s, id) -> let env = env_from_summary s subst in Env.add_persistent_structure id env diff --git a/typing/typecore.ml b/typing/typecore.ml index 2745b685a8..92c7e0ab3f 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -177,119 +177,6 @@ let mk_expected ?explanation ty = { ty; explanation; } let case lhs rhs = {c_lhs = lhs; c_guard = None; c_rhs = rhs} -(* Upper approximation of free identifiers on the parse tree *) - -let iter_expression f e = - - let rec expr e = - f e; - match e.pexp_desc with - | Pexp_extension _ (* we don't iterate under extension point *) - | Pexp_ident _ - | Pexp_new _ - | Pexp_constant _ -> () - | Pexp_function pel -> List.iter case pel - | Pexp_fun (_, eo, _, e) -> Option.iter expr eo; expr e - | Pexp_apply (e, lel) -> expr e; List.iter (fun (_, e) -> expr e) lel - | Pexp_let (_, pel, e) -> expr e; List.iter binding pel - | Pexp_match (e, pel) - | Pexp_try (e, pel) -> expr e; List.iter case pel - | Pexp_array el - | Pexp_tuple el -> List.iter expr el - | Pexp_construct (_, eo) - | Pexp_variant (_, eo) -> Option.iter expr eo - | Pexp_record (iel, eo) -> - Option.iter expr eo; List.iter (fun (_, e) -> expr e) iel - | Pexp_open (_, e) - | Pexp_newtype (_, e) - | Pexp_poly (e, _) - | Pexp_lazy e - | Pexp_assert e - | Pexp_setinstvar (_, e) - | Pexp_send (e, _) - | Pexp_constraint (e, _) - | Pexp_coerce (e, _, _) - | Pexp_letexception (_, e) - | Pexp_field (e, _) -> expr e - | Pexp_while (e1, e2) - | Pexp_sequence (e1, e2) - | Pexp_setfield (e1, _, e2) -> expr e1; expr e2 - | Pexp_ifthenelse (e1, e2, eo) -> expr e1; expr e2; Option.iter expr eo - | Pexp_for (_, e1, e2, _, e3) -> expr e1; expr e2; expr e3 - | Pexp_override sel -> List.iter (fun (_, e) -> expr e) sel - | Pexp_letmodule (_, me, e) -> expr e; module_expr me - | Pexp_object { pcstr_fields = fs } -> List.iter class_field fs - | Pexp_letop { let_; ands; body; _ } -> - binding_op let_; List.iter binding_op ands; expr body - | Pexp_pack me -> module_expr me - | Pexp_unreachable -> () - - and case {pc_lhs = _; pc_guard; pc_rhs} = - Option.iter expr pc_guard; - expr pc_rhs - - and binding_op { pbop_exp; _ } = - expr pbop_exp - - and binding x = - expr x.pvb_expr - - and module_expr me = - match me.pmod_desc with - | Pmod_extension _ - | Pmod_ident _ -> () - | Pmod_structure str -> List.iter structure_item str - | Pmod_constraint (me, _) - | Pmod_functor (_, _, me) -> module_expr me - | Pmod_apply (me1, me2) -> module_expr me1; module_expr me2 - | Pmod_unpack e -> expr e - - - and structure_item str = - match str.pstr_desc with - | Pstr_eval (e, _) -> expr e - | Pstr_value (_, pel) -> List.iter binding pel - | Pstr_primitive _ - | Pstr_type _ - | Pstr_typext _ - | Pstr_exception _ - | Pstr_modtype _ - | Pstr_open _ - | Pstr_class_type _ - | Pstr_attribute _ - | Pstr_extension _ -> () - | Pstr_include {pincl_mod = me} - | Pstr_module {pmb_expr = me} -> module_expr me - | Pstr_recmodule l -> List.iter (fun x -> module_expr x.pmb_expr) l - | Pstr_class cdl -> List.iter (fun c -> class_expr c.pci_expr) cdl - - and class_expr ce = - match ce.pcl_desc with - | Pcl_constr _ -> () - | Pcl_structure { pcstr_fields = fs } -> List.iter class_field fs - | Pcl_fun (_, eo, _, ce) -> Option.iter expr eo; class_expr ce - | Pcl_apply (ce, lel) -> - class_expr ce; List.iter (fun (_, e) -> expr e) lel - | Pcl_let (_, pel, ce) -> - List.iter binding pel; class_expr ce - | Pcl_open (_, ce) - | Pcl_constraint (ce, _) -> class_expr ce - | Pcl_extension _ -> () - - and class_field cf = - match cf.pcf_desc with - | Pcf_inherit (_, ce, _) -> class_expr ce - | Pcf_val (_, _, Cfk_virtual _) - | Pcf_method (_, _, Cfk_virtual _ ) | Pcf_constraint _ -> () - | Pcf_val (_, _, Cfk_concrete (_, e)) - | Pcf_method (_, _, Cfk_concrete (_, e)) -> expr e - | Pcf_initializer e -> expr e - | Pcf_attribute _ | Pcf_extension _ -> () - - in - expr e - - (* Typing of constants *) let type_constant = function @@ -1070,26 +957,6 @@ type half_typed_case = unpacks: module_variable list; contains_gadt: bool; } -let all_idents_cases half_typed_cases = - let idents = Hashtbl.create 8 in - let f = function - | {pexp_desc=Pexp_ident { txt = Longident.Lident id; _ }; _} -> - Hashtbl.replace idents id () - | {pexp_desc=Pexp_letop{ let_; ands; _ }; _ } -> - Hashtbl.replace idents let_.pbop_op.txt (); - List.iter - (fun { pbop_op; _ } -> Hashtbl.replace idents pbop_op.txt ()) - ands - | _ -> () - in - List.iter - (fun { untyped_case = cp; _ } -> - Option.iter (iter_expression f) cp.pc_guard; - iter_expression f cp.pc_rhs - ) - half_typed_cases; - Hashtbl.fold (fun x () rest -> x :: rest) idents [] - let rec has_literal_pattern p = match p.ppat_desc with | Ppat_constant _ | Ppat_interval _ -> @@ -2223,17 +2090,6 @@ let check_absent_variant env = (correct_levels pat.pat_type) | _ -> ()) -(* Duplicate types of values in the environment *) -(* XXX Should we do something about global type variables too? *) - -let duplicate_ident_types half_typed_cases env = - let caselist = - List.filter (fun { typed_pat; _ } -> - contains_gadt typed_pat - ) half_typed_cases - in - Env.make_copy_of_types (all_idents_cases caselist) env - (* Getting proper location of already typed expressions. Used to avoid confusing locations on type error messages in presence of @@ -4338,10 +4194,10 @@ and type_cases ?exception_allowed ?in_function env ty_arg ty_res partial_flag let does_contain_gadt = List.exists (fun { contains_gadt; _ } -> contains_gadt) half_typed_cases in - let ty_res, duplicated_ident_types = + let ty_res, do_copy_types = if does_contain_gadt && not !Clflags.principal then - correct_levels ty_res, duplicate_ident_types half_typed_cases env - else ty_res, duplicate_ident_types [] env + correct_levels ty_res, Env.make_copy_of_types env + else ty_res, (fun env -> env) in (* Unify all cases (delayed to keep it order-free) *) let ty_arg' = newvar () in @@ -4377,7 +4233,7 @@ and type_cases ?exception_allowed ?in_function env ty_arg ty_res partial_flag contains_gadt; _ } -> let ext_env = if contains_gadt then - Env.do_copy_types duplicated_ident_types ext_env + do_copy_types ext_env else ext_env in |