diff options
| author |  Pierre-Marie Pédrot <pierre-marie.pedrot@inria.fr> | 2016-09-09 16:37:35 +0200 |
|---|---|---|
| committer | Pierre-Marie Pédrot <pierre-marie.pedrot@inria.fr> | 2016-09-09 17:07:39 +0200 |
| commit | ff980722521812d19bc1e25cd504567b4a6b549a (patch) | |
| tree | 548c8e5b872305ee6e10bc007a0a940a7e18ccd7 /proofs/clenvtac.ml | |
| parent | 306dfe775009681e492a2a59e3dcdc5b67bd9d73 (diff) | |
Fast path in Clenvtac.clenv_refine typeclass resolution.
This legacy function is still used by destruct, and is a hotspot in various
examples from the wild. We hijack the check from Typeclass and perform a
double check at once not to mark unresolvable evars in vain a lot.
Diffstat (limited to 'proofs/clenvtac.ml')
| -rw-r--r-- | proofs/clenvtac.ml | 26 |
1 files changed, 23 insertions, 3 deletions
diff --git a/proofs/clenvtac.ml b/proofs/clenvtac.ml index 04a2eb487..98b5bc8b0 100644 --- a/proofs/clenvtac.ml +++ b/proofs/clenvtac.ml @@ -59,6 +59,19 @@ let clenv_pose_dependent_evars with_evars clenv = (RefinerError (UnresolvedBindings (List.map (meta_name clenv.evd) dep_mvs))); clenv_pose_metas_as_evars clenv dep_mvs +(** Use our own fast path, more informative than from Typeclasses *) +let check_tc evd = + let has_resolvable = ref false in + let check _ evi = + let res = Typeclasses.is_resolvable evi in + if res then + let () = has_resolvable := true in + Typeclasses.is_class_evar evd evi + else false + in + let has_typeclass = Evar.Map.exists check (Evd.undefined_map evd) in + (has_typeclass, !has_resolvable) + let clenv_refine with_evars ?(with_classes=true) clenv = (** ppedrot: a Goal.enter here breaks things, because the tactic below may solve goals by side effects, while the compatibility layer keeps those @@ -67,9 +80,16 @@ let clenv_refine with_evars ?(with_classes=true) clenv = let clenv = clenv_pose_dependent_evars with_evars clenv in let evd' = if with_classes then - let evd' = Typeclasses.resolve_typeclasses ~filter:Typeclasses.all_evars - ~fail:(not with_evars) clenv.env clenv.evd - in Typeclasses.mark_unresolvables ~filter:Typeclasses.all_goals evd' + let (has_typeclass, has_resolvable) = check_tc clenv.evd in + let evd' = + if has_typeclass then + Typeclasses.resolve_typeclasses ~fast_path:false ~filter:Typeclasses.all_evars + ~fail:(not with_evars) clenv.env clenv.evd + else clenv.evd + in + if has_resolvable then + Typeclasses.mark_unresolvables ~filter:Typeclasses.all_goals evd' + else evd' else clenv.evd in let clenv = { clenv with evd = evd' } in |