diff options
Diffstat (limited to 'engine/evd.ml')
| -rw-r--r-- | engine/evd.ml | 148 |
1 files changed, 97 insertions, 51 deletions
diff --git a/engine/evd.ml b/engine/evd.ml index e7d542d12..b7b87370e 100644 --- a/engine/evd.ml +++ b/engine/evd.ml @@ -253,21 +253,8 @@ let instantiate_evar_array info c args = | [] -> c | _ -> replace_vars inst c -type evar_universe_context = UState.t -type 'a in_evar_universe_context = 'a * evar_universe_context - -let empty_evar_universe_context = UState.empty -let union_evar_universe_context = UState.union -let evar_universe_context_set = UState.context_set -let evar_universe_context_constraints = UState.constraints -let evar_context_universe_context = UState.context -let evar_universe_context_of = UState.of_context_set -let evar_universe_context_subst = UState.subst -let add_constraints_context = UState.add_constraints -let add_universe_constraints_context = UState.add_universe_constraints -let constrain_variables = UState.constrain_variables -let evar_universe_context_of_binders = UState.of_binders +type 'a in_evar_universe_context = 'a * UState.t (*******************************************************************) (* Metamaps *) @@ -421,13 +408,15 @@ let key id (_, idtoev) = end +type goal_kind = ToShelve | ToGiveUp + type evar_map = { (** Existential variables *) defn_evars : evar_info EvMap.t; undf_evars : evar_info EvMap.t; evar_names : EvNames.t; (** Universes *) - universes : evar_universe_context; + universes : UState.t; (** Conversion problems *) conv_pbs : evar_constraint list; last_mods : Evar.Set.t; @@ -445,6 +434,7 @@ type evar_map = { name) of the evar which will be instantiated with a term containing [e]. *) + future_goals_status : goal_kind EvMap.t; extras : Store.t; } @@ -484,7 +474,8 @@ let remove d e = | Some e' -> if Evar.equal e e' then None else d.principal_future_goal in let future_goals = List.filter (fun e' -> not (Evar.equal e e')) d.future_goals in - { d with undf_evars; defn_evars; principal_future_goal; future_goals } + let future_goals_status = EvMap.remove e d.future_goals_status in + { d with undf_evars; defn_evars; principal_future_goal; future_goals; future_goals_status } let find d e = try EvMap.find e d.undf_evars @@ -558,10 +549,10 @@ let existential_type d (n, args) = instantiate_evar_array info info.evar_concl args let add_constraints d c = - { d with universes = add_constraints_context d.universes c } + { d with universes = UState.add_constraints d.universes c } let add_universe_constraints d c = - { d with universes = add_universe_constraints_context d.universes c } + { d with universes = UState.add_universe_constraints d.universes c } (*** /Lifting... ***) @@ -586,7 +577,7 @@ let create_evar_defs sigma = { sigma with let empty = { defn_evars = EvMap.empty; undf_evars = EvMap.empty; - universes = empty_evar_universe_context; + universes = UState.empty; conv_pbs = []; last_mods = Evar.Set.empty; metas = Metamap.empty; @@ -594,6 +585,7 @@ let empty = { evar_names = EvNames.empty; (* id<->key for undefined evars *) future_goals = []; principal_future_goal = None; + future_goals_status = EvMap.empty; extras = Store.empty; } @@ -609,14 +601,14 @@ let evars_reset_evd ?(with_conv_pbs=false) ?(with_univs=true) evd d = let last_mods = if with_conv_pbs then evd.last_mods else d.last_mods in let universes = if not with_univs then evd.universes - else union_evar_universe_context evd.universes d.universes + else UState.union evd.universes d.universes in { evd with metas = d.metas; last_mods; conv_pbs; universes } let merge_universe_context evd uctx' = - { evd with universes = union_evar_universe_context evd.universes uctx' } + { evd with universes = UState.union evd.universes uctx' } let set_universe_context evd uctx' = { evd with universes = uctx' } @@ -798,16 +790,6 @@ let make_flexible_variable evd ~algebraic u = { evd with universes = UState.make_flexible_variable evd.universes ~algebraic u } -let make_evar_universe_context e l = - let uctx = UState.make (Environ.universes e) in - match l with - | None -> uctx - | Some us -> - List.fold_left - (fun uctx { CAst.loc; v = id } -> - fst (UState.new_univ_variable ?loc univ_rigid (Some id) uctx)) - uctx us - (****************************************) (* Operations on constants *) (****************************************) @@ -910,10 +892,6 @@ let check_eq evd s s' = let check_leq evd s s' = UGraph.check_leq (UState.ugraph evd.universes) s s' -let normalize_evar_universe_context_variables = UState.normalize_variables - -let abstract_undefined_variables = UState.abstract_undefined_variables - let fix_undefined_variables evd = { evd with universes = UState.fix_undefined_variables evd.universes } @@ -922,16 +900,14 @@ let refresh_undefined_universes evd = let evd' = cmap (subst_univs_level_constr subst) {evd with universes = uctx'} in evd', subst -let normalize_evar_universe_context = UState.normalize - -let nf_univ_variables evd = - let subst, uctx' = normalize_evar_universe_context_variables evd.universes in +let nf_univ_variables evd = + let subst, uctx' = UState.normalize_variables evd.universes in let evd' = {evd with universes = uctx'} in evd', subst -let nf_constraints evd = - let subst, uctx' = normalize_evar_universe_context_variables evd.universes in - let uctx' = normalize_evar_universe_context uctx' in +let minimize_universes evd = + let subst, uctx' = UState.normalize_variables evd.universes in + let uctx' = UState.minimize uctx' in {evd with universes = uctx'} let universe_of_name evd s = UState.universe_of_name evd.universes s @@ -958,25 +934,72 @@ let drop_side_effects evd = let eval_side_effects evd = evd.effects (* Future goals *) -let declare_future_goal evk evd = - { evd with future_goals = evk::evd.future_goals } +let declare_future_goal ?tag evk evd = + { evd with future_goals = evk::evd.future_goals; + future_goals_status = Option.fold_right (EvMap.add evk) tag evd.future_goals_status } -let declare_principal_goal evk evd = +let declare_principal_goal ?tag evk evd = match evd.principal_future_goal with | None -> { evd with future_goals = evk::evd.future_goals; - principal_future_goal=Some evk; } + principal_future_goal=Some evk; + future_goals_status = Option.fold_right (EvMap.add evk) tag evd.future_goals_status; + } | Some _ -> CErrors.user_err Pp.(str "Only one main subgoal per instantiation.") +type future_goals = Evar.t list * Evar.t option * goal_kind EvMap.t + let future_goals evd = evd.future_goals let principal_future_goal evd = evd.principal_future_goal -let reset_future_goals evd = - { evd with future_goals = [] ; principal_future_goal=None } +let save_future_goals evd = + (evd.future_goals, evd.principal_future_goal, evd.future_goals_status) -let restore_future_goals evd gls pgl = - { evd with future_goals = gls ; principal_future_goal = pgl } +let reset_future_goals evd = + { evd with future_goals = [] ; principal_future_goal = None; + future_goals_status = EvMap.empty } + +let restore_future_goals evd (gls,pgl,map) = + { evd with future_goals = gls ; principal_future_goal = pgl; + future_goals_status = map } + +let fold_future_goals f sigma (gls,pgl,map) = + List.fold_left f sigma gls + +let map_filter_future_goals f (gls,pgl,map) = + (* Note: map is now a superset of filtered evs, but its size should + not be too big, so that's probably ok not to update it *) + (List.map_filter f gls,Option.bind pgl f,map) + +let filter_future_goals f (gls,pgl,map) = + (List.filter f gls,Option.bind pgl (fun a -> if f a then Some a else None),map) + +let dispatch_future_goals_gen distinguish_shelf (gls,pgl,map) = + let rec aux (comb,shelf,givenup as acc) = function + | [] -> acc + | evk :: gls -> + let acc = + try match EvMap.find evk map with + | ToGiveUp -> (comb,shelf,evk::givenup) + | ToShelve -> + if distinguish_shelf then (comb,evk::shelf,givenup) + else raise Not_found + with Not_found -> (evk::comb,shelf,givenup) in + aux acc gls in + (* Note: this reverses the order of initial list on purpose *) + let (comb,shelf,givenup) = aux ([],[],[]) gls in + (comb,shelf,givenup,pgl) + +let dispatch_future_goals = + dispatch_future_goals_gen true + +let extract_given_up_future_goals goals = + let (comb,_,givenup,_) = dispatch_future_goals_gen false goals in + (comb,givenup) + +let shelve_on_future_goals shelved (gls,pgl,map) = + (shelved @ gls, pgl, List.fold_right (fun evk -> EvMap.add evk ToShelve) shelved map) (**********************************************************) (* Accessing metas *) @@ -993,6 +1016,7 @@ let set_metas evd metas = { effects = evd.effects; evar_names = evd.evar_names; future_goals = evd.future_goals; + future_goals_status = evd.future_goals_status; principal_future_goal = evd.principal_future_goal; extras = evd.extras; } @@ -1076,7 +1100,7 @@ let clear_metas evd = {evd with metas = Metamap.empty} let meta_merge ?(with_univs = true) evd1 evd2 = let metas = Metamap.fold Metamap.add evd1.metas evd2.metas in let universes = - if with_univs then union_evar_universe_context evd2.universes evd1.universes + if with_univs then UState.union evd2.universes evd1.universes else evd2.universes in {evd2 with universes; metas; } @@ -1176,3 +1200,25 @@ module Monad = (* Failure explanation *) type unsolvability_explanation = SeveralInstancesFound of int + +(** Deprecated *) +type evar_universe_context = UState.t +let empty_evar_universe_context = UState.empty +let union_evar_universe_context = UState.union +let evar_universe_context_set = UState.context_set +let evar_universe_context_constraints = UState.constraints +let evar_context_universe_context = UState.context +let evar_universe_context_of = UState.of_context_set +let evar_universe_context_subst = UState.subst +let add_constraints_context = UState.add_constraints +let constrain_variables = UState.constrain_variables +let evar_universe_context_of_binders = UState.of_binders +let make_evar_universe_context e l = + let g = Environ.universes e in + match l with + | None -> UState.make g + | Some l -> UState.make_with_initial_binders g l +let normalize_evar_universe_context_variables = UState.normalize_variables +let abstract_undefined_variables = UState.abstract_undefined_variables +let normalize_evar_universe_context = UState.minimize +let nf_constraints = minimize_universes |