diff options
| author |  Matthieu Sozeau <mattam@mattam.org> | 2012-10-10 15:35:36 -0400 |
|---|---|---|
| committer | Matthieu Sozeau <mattam@mattam.org> | 2014-05-06 09:58:53 +0200 |
| commit | a4043608f704f026de7eb5167a109ca48e00c221 (patch) | |
| tree | 938b6b8cb8d6d5dbaf7be3c62abcc8fdfcd45fc2 /pretyping | |
| parent | a2a249211c2ac1e18eff0d4f28e5afc98c137f97 (diff) | |
This commit adds full universe polymorphism and fast projections to Coq.
Add [Polymorphic] and [Monomorphic] local flag for definitions as well as
[Set Universe Polymorphism] global flag to make all following definitions
polymorphic. Mainly syntax for now.
First part of the big changes to the kernel:
- Const, Ind, Construct now come with a universe level instance
- It is used for type inference in the kernel, which now also takes
a graph as input: actually a set of local universe variables and their
constraints. Type inference just checks that the constraints are enough
to satisfy its own rules.
- Remove polymorphic_arity and _knowing_parameters everywhere: we
don't need full applications for polymorphism to apply anymore, as
we generate fresh variables at each constant/inductive/constructor
application. However knowing_parameters variants might be reinstated
later for optimization.
- New structures exported in univ.mli:
- universe_list for universe level instances
- universe_context(_set) for the local universe constraints, also
recording which variables will be local and hence generalized after
inference if defining a polymorphic ind/constant.
- this patch makes coq stop compiling at indtypes.ml
Adapt kernel, library, pretyping, tactics and toplevel to universe polymorphism.
Various degrees of integration, places where I was not sure what to do or
just postponed bigger reorganizations of the code are marked with FIXMEs.
Main changes:
- Kernel now checks constraints and does not infer them anymore.
- The inference functions produce a context of constraints that were checked
during inference, useful to do double-checking of the univ. poly. code
but might be removed later.
- Constant, Inductive entries now have a universe context (local variables
and constraints) associated to them.
- Printing, debugging functions for the new structures are also implemented.
- Now stopping at Logic.v
- Lots of new code in kernel/univ.ml that should be reviewed.
- kernel/indtypes probably does not do what's right when inferring inductive
type constraints.
- Adapted evd to use the new universe context structure.
- Did not deal with unification/evar_conv.
- Add externalisation code for universe level instances.
- Support for polymorphism in pretyping/command and proofs/proofview etc.
Needed wrapping of [fresh_.._instance] through the evar_map, which
contains the local state of universes during type-checking.
- Correct the inductive scheme generation to support polymorphism as well.
- Have to review kernel code for correctness, and especially rework the
computation of universe constraints for inductives.
Stops somewhat later in Logic.v
- Fix naming of local/toplevel universes to be correctly done at typechecking time:
local variables have no dirpath.
- Add code to do substitution of universes in modules, not finished yet.
- Move fresh_* functions out of kernel, it won't ever build a universe level again!
- Adapt a lot of new_Type to use the correct dirpath and declare the new types in the evar_map
so we keep track of them.
- A bit of code factorization (evd_comb moved, pretype_global).
- Refactor more code
- Adapt plugins code (sometimes wrong, marked with FIXME)
- Fix cases generating unneeded universe (not sure it's ok though)
- Fix scheme generation for good, might have opportunity to cleanup
the terms later.
Init compiles now (which means rewrite, inversion, elim etc.. work as well).
- Unsolved issue of pretyping to lower sorts properly (to Prop for example).
This has to do with the (Retyping.get_type_of) giving algebraic universes that
would appear on the right of constraints.
This makes checking for dangling universes at the end of pretyping fail,
hence the check in kernel/univ was removed. It should come back when we have
a fix for this.
- Correctly (?) compute the levels of inductive types.
Removed old code pertaining to universe polymorphism. Note that we generate
constraint variables for the conclusion of inductive types invariably.
- Shrink constraints before going to the kernel, combine substitution of the
smaller universe set with normalization of evars (maybe not done everywhere,
only ordinary inductives, definitions and proofs)
- More API reworks overall. tclPUSHCONTEXT can be used to add fresh universes
to the proof goal (used in a few places to get the right instance.
- Quick fix for auto that won't work in the long run. It should always have been
restricted to take constant references as input, without any loss of generality
over constrs.
Fix some plugins and insertion of non-polymorphic constants in a module.
Now stops in relation classes.
Cleanup and move code from kernel to library and from pretyping to library too.
Now there is a unique universe counter declared in library/universes.ml along
with all the functions to generate new universes and get fresh constant/inductive
terms.
- Various function renamings
- One important change in kernel/univ.ml: now [sup] can be applied to Prop.
- Adapt records/classes to universe polymorphism
- Now stops in EqDepFacts due to imprecise universe polymorphism.
Forgot to git add those files.
interp_constr returns the universe context
The context is then pushed through the environment (or proof goal
sigma).
- Fix insertion of constants/inductives in env, pushing constraints to
the global env for non-polymorphic ones.
- Add Prop as a universe level to do proper type inference with sorts.
It is allowed to take [sup] of [Prop] now.
- New nf_evar based on new Evd.map(_undefined)
- In proofs/logic.ml: conv_leq_goal might create some constraints that
are now recorded.
- Adapt Program code to universes.
Merge with latest trunk + fixes
-Use new constr_of_global from universes
- fix eqschemes to use polymorphic universes
- begin fixing cctac but f_equal still fails
- fix [simpl] and rest of tacred
- all the eq_constr with mkConst foo should be fixed as well, only
partially done
- Fix term hashing function to recognize equal terms up to universe instances.
- Fix congruence closure to equate terms that differ only in universe instances,
these will be resolved by constraints.
Add a set of undefined universe variables to unification.
Universe variables can now be declared rigid or flexible (unifiable).
Flexible variables are resolved at the end of typechecking by instantiating
them to their glb, adding upper bound constraints associated to them.
Also:
- Add polymorphic flag for inductives.
- Fix cooking partially
- Fix kernel/univ.ml to do normalization of universe expressions at
the end of substitution.
Correct classes/structures universe inference
- Required a bit of extension in Univ to handle Max properly (sup u
(u+1)) was returning (max(u,u+1)) for example.
- Try a version where substitution of universe expressions for universe
levels is allowed at the end of unification. By an invariant this
should only instantiate with max() types that are morally "on the
right" only.
This is controlled using a rigidity attribute of universe variables,
also allowing to properly do unification w.r.t. universes during
typechecking/inference.
- Currently fails in Vectors/Fin.v because case compilation generates
"flexible" universes that actually appear in the term...
Fix unification of universe variables.
- Fix choice of canonical universe in presence of universe constraints,
and do so by relying on a trichotomy for universe variables: rigid
(won't be substituted), flexible (might be if not substituted by an
algebraic) and flexible_alg (always substituted).
- Fix romega code and a few more plugins, most of the standard library
goes through now.
- Had to define some inductives as Polymorphic explicitly to make
proofs go through, more to come, and definitions should be polymorphic
too, otherwise inconsistencies appear quickly (two uses of the same
polymorphic ind through monomorphic functions (like nth on lists of
Props and nats) will fix the monomorphic function's universe with eq
constraints that are incompatible).
- Correct universe polymorphism handling for fixpoint/cofixpoint
definitions.
- Fix romega to use the right universes for list constructors.
- Fix internalization/externalization to deal properly with the
implicit parsing of params.
- Fix fourier tactic w.r.t. GRefs
- Fix substitution saturation of universes.
- Fix number syntax plugin.
- Fix setoid_ring to take its coefficients in a Set rather
than a Type, avoiding a large number of useless universe constraints.
- Fix minor checker decl
- Fix btauto w.r.t. GRef
- Fix proofview to normalize universes in the original types as well.
- Fix definitions of projections to not take two universes at the same level,
but at different levels instead, avoiding unnecessary constraints that could
lower the level of one component depending on the use of the other component.
Fix simpl fst, snd to use @fst @snd as they have maximal implicits now.
- More simpl snd, fst fixes.
- Try to make the nth theory of lists polymorphic.
Check with Enrico if this change is ok. Case appearing in RingMicromega's call
to congruence l417, through a call to refine -> the_conv_x_leq.
Compile everything.
- "Fix" checker by deactivating code related to polymorphism, should
be updated.
- Make most of List.v polymorphic to help with following definitions.
- When starting a lemma, normalize w.r.t. universes, so that the types
get a fixed universe, not refinable later.
- In record, don't assign a fully flexible universe variable to the record
type if it is a definitional typeclass, as translate_constant doesn't expect
an algebraic universe in the type of a constant. It certainly should though.
- Fix micromega code.
Fix after rebase.
Update printing functions to print the polymorphic status of definitions
and their universe context.
Refine printing of universe contexts
- Fix printer for universe constraints
- Rework normalization of constraints to separate the Union-Find result
from computation of lubs/glbs.
Keep universe contexts of inductives/constants in entries for correct
substitution inside modules. Abstract interface to get an instantiation
of an inductive with its universe substitution in the kernel (no
substitution if the inductive is not polymorphic, even if mind_universes
is non-empty).
Make fst and snd polymorphic, fix instances in RelationPairs to use
different universes for the two elements of a pair.
- Fix bug in nf_constraints: was removing Set <= constraints, but should
remove Prop <= constraints only.
- Make proj1_sig, projT1... polymorphic to avoid weird universe unifications,
giving rise to universe inconsistenties.
Adapt auto hints to polymorphic references.
Really produce polymorphic hints... second try
- Remove algebraic universes that can't appear in the goal when taking the
type of a lemma to start.
Proper handling of universe contexts in clenv and auto so that
polymorphic hints are really refreshed at each application.
Fix erroneous shadowing of sigma variable.
- Make apparent the universe context used in pretyping, including information
about flexibility of universe variables.
- Fix induction to generate a fresh constant instance with flexible universe variables.
Add function to do conversion w.r.t. an evar map and its local universes.
- Fix define_evar_as_sort to not forget constraints coming from the refinement.
- Do not nf_constraints while we don't have the whole term at hand to substitute in.
- Move substitution of full universes to Universes
- Normalize universes inside an evar_map when doing nf_evar_map_universes.
- Normalize universes at each call to interp_ltac (potentially expensive)
Do not normalize all evars at each call to interp_gen in tactics: rather
incrementally normalize the terms at hand, supposing the normalization of universes
will concern only those appearing in it (dangerous but much more efficient).
Do not needlessly generate new universes constraints for projections of records.
Correct polymorphic discharge of section variables.
Fix autorewrite w.r.t. universes: polymorphic rewrite hints get fresh universe
instances at each application.
Fix r2l rewrite scheme to support universe polymorphism
Fix a bug in l2r_forward scheme and fix congruence scheme to handle polymorphism correctly.
Second try at fixing autorewrite, cannot do without pushing the constraints and the set of fresh
universe variables into the proof context.
- tclPUSHCONTEXT allow to set the ctx universe variables as flexible or rigid
- Fix bug in elimschemes, not taking the right sigma
Wrong sigma used in leibniz_rewrite
Avoid recomputation of bounds for equal universes in normalization of constraints,
only the canonical one need to be computed.
Make coercions work with universe polymorphic projections.
Fix eronneous bound in universes constraint solving.
Make kernel reduction and term comparison strictly aware of universe instances,
with variants for relaxed comparison that output constraints.
Otherwise some constraints that should appear during pretyping don't and we generate
unnecessary constraints/universe variables.
Have to adapt a few tactics to this new behavior by making them universe aware.
- Fix elimschemes to minimize universe variables
- Fix coercions to not forget the universe constraints generated by an application
- Change universe substitutions to maps instead of assoc lists.
- Fix absurd tactic to handle univs properly
- Make length and app polymorphic in List, unification sets their levels otherwise.
Move to modules for namespace management instead of long names in universe code.
More putting things into modules.
Change evar_map structure to support an incremental substitution of universes
(populated from Eq constraints), allowing safe and fast inference of precise levels,
without computing lubs.
- Add many printers and reorganize code
- Extend nf_evar to normalize universe variables according to the substitution.
- Fix ChoiceFacts.v in Logic, no universe inconsistencies anymore. But Diaconescu
still has one (something fixes a universe to Set).
- Adapt omega, functional induction to the changes.
Fix congruence, eq_constr implem, discharge of polymorphic inductives.
Fix merge in auto.
The [-parameters-matter] option (formerly relevant_equality).
Add -parameters-matter to coqc
Do compute the param levels at elaboration time if parameters_matter.
- Fix generalize tactic
- add ppuniverse_subst
- Start fixing normalize_universe_context w.r.t. normalize_univ_variables.
- Fix HUGE bug in Ltac interpretation not folding the sigma correctly if interpreting a tactic application
to multiple arguments.
- Fix bug in union of universe substitution.
- rename parameters-matter to indices-matter
- Fix computation of levels from indices not parameters.
- Fixing parsing so that [Polymorphic] can be applied to gallina extensions.
- When elaborating definitions, make the universes from the type rigid when
checking the term: they should stay abstracted.
- Fix typeclasses eauto's handling of universes for exact hints.
Rework all the code for infering the levels of inductives and checking their
allowed eliminations sorts.
This is based on the computation of a natural level for an inductive type I.
The natural level [nat] of [I : args -> sort := c1 : A1 -> I t1 .. cn : An -> I tn] is
computed by taking the max of the levels of the args (if indices matter) and the
levels of the constructor arguments.
The declared level [decl] of I is [sort], which might be Prop, Set or some Type u (u fresh
or not).
If [decl >= nat && not (decl = Prop && n >= 2)], the level of the inductive is [decl],
otherwise, _smashing_ occured.
If [decl] is impredicative (Prop or Set when Set is impredicative), we accept the
declared level, otherwise it's an error.
To compute the allowed elimination sorts, we have the following situations:
- No smashing occured: all sorts are allowed. (Recall props that are not
smashed are Empty/Unitary props)
- Some smashing occured:
- if [decl] is Type, we allow all eliminations (above or below [decl],
not sure why this is justified in general).
- if [decl] is Set, we used smashing for impredicativity, so only
small sorts are allowed (Prop, Set).
- if [decl] is Prop, only logical sorts are allowed: I has either
large universes inside it or more than 1 constructor.
This does not treat the case where only a Set appeared in I which
was previously accepted it seems.
All the standard library works with these changes. Still have to cleanup
kernel/indtypes.ml. It is a good time to have a whiskey with OJ.
Thanks to Peter Lumsdaine for bug reporting:
- fix externalisation of universe instances (still appearing when no Printing Universes)
- add [convert] and [convert_leq] tactics that keep track of evars and universe constraints.
- use them in [exact_check].
Fix odd behavior in inductive type declarations allowing to silently lower a Type i parameter
to Set for squashing a naturally Type i inductive to Set. Reinstate the LargeNonPropInductiveNotInType
exception.
Fix the is_small function not dealing properly with aliases of Prop/Set in Type.
Add check_leq in Evd and use it to decide if we're trying to squash an
inductive naturally in some Type to Set.
- Fix handling of universe polymorphism in typeclasses Class/Instance declarations.
- Don't allow lowering a rigid Type universe to Set silently.
- Move Ring/Field back to Type. It was silently putting R in Set due to the definition of ring_morph.
- Rework inference of universe levels for inductive definitions.
- Make fold_left/right polymorphic on both levels A and B (the list's type). They don't have to be
at the same level.
Handle selective Polymorphic/Monomorphic flag right for records.
Remove leftover command
Fix after update with latest trunk.
Backport patches on HoTT/coq to rebased version of universe polymorphism.
- Fix autorewrite wrong handling of universe-polymorphic rewrite rules. Fixes part of issue #7.
- Fix the [eq_constr_univs] and add an [leq_constr_univs] to avoid eager equation of universe
levels that could just be inequal. Use it during kernel conversion. Fixes issue #6.
- Fix a bug in unification that was failing too early if a choice in unification of universes
raised an inconsistency.
- While normalizing universes, remove Prop in the le part of Max expressions.
- Stop rigidifying the universes on the right hand side of a : in definitions.
- Now Hints can be declared polymorphic or not. In the first case they
must be "refreshed" (undefined universes are renamed) at each application.
- Have to refresh the set of universe variables associated to a hint
when it can be used multiple times in a single proof to avoid fixing
a level... A better & less expensive solution should exist.
- Do not include the levels of let-ins as part of records levels.
- Fix a NotConvertible uncaught exception to raise a more informative
error message.
- Better substitution of algebraics in algebraics (for universe variables that
can be algebraics).
- Fix issue #2, Context was not properly normalizing the universe context.
- Fix issue with typeclasses that were not catching UniverseInconsistencies
raised by unification, resulting in early failure of proof-search.
- Let the result type of definitional classes be an algebraic.
- Adapt coercions to universe polymorphic flag (Identity Coercion etc..)
- Move away a dangerous call in autoinstance that added constraints for every
polymorphic definitions once in the environment for no use.
Forgot one part of the last patch on coercions.
- Adapt auto/eauto to polymorphic hints as well.
- Factor out the function to refresh a clenv w.r.t. undefined universes.
Use leq_univ_poly in evarconv to avoid fixing universes.
Disallow polymorphic hints based on a constr as it is not possible to infer their universe
context. Only global references can be made polymorphic. Fixes issue #8.
Fix SearchAbout bug (issue #10).
Fix program w.r.t. universes: the universe context of a definition changes
according to the successive refinements due to typechecking obligations.
This requires the Proof modules to return the generated universe substitution
when finishing a proof, and this information is passed in the closing hook.
The interface is not very clean, will certainly change in the future.
- Better treatment of polymorphic hints in auto: terms can be polymorphic now, we refresh their
context as well.
- Needs a little change in test-pattern that seems breaks multiary uses of destruct in NZDiv.v, l495.
FIX to do.
Fix [make_pattern_test] to keep the universe information around and still
allow tactics to take multiple patterns at once.
- Fix printing of universe instances that should not be factorized blindly
- Fix handling of the universe context in program definitions by allowing the
hook at the end of an interactive proof to give back the refined universe context,
before it is transformed in the kernel.
- Fix a bug in evarconv where solve_evar_evar was not checking types of instances,
resulting in a loss of constraints in unification of universes and a growing number
of useless parametric universes.
- Move from universe_level_subst to universe_subst everywhere.
- Changed representation of universes for a canonical one
- Adapt the code so that universe variables might be substituted by
arbitrary universes (including algebraics). Not used yet except for
polymorphic universe variables instances.
- Adapt code to new constraint structure.
- Fix setoid rewrite handling of evars that was forgetting the initial
universe substitution !
- Fix code that was just testing conversion instead of keeping the
resulting universe constraints around in the proof engine.
- Make a version of reduction/fconv that deals with the more general
set of universe constraints.
- [auto using] should use polymorphic versions of the constants.
- When starting a proof, don't forget about the algebraic universes in
the universe context.
Rationalize substitution and normalization functions for universes.
Also change back the structure of universes to avoid considering levels
n+k as pure levels: they are universe expressions like max.
Everything is factored out in the Universes and Univ modules now and
the normalization functions can be efficient in the sense that they
can cache the normalized universes incrementally.
- Adapt normalize_context code to new normalization/substitution functions.
- Set more things to be polymorphic, e.g. in Ring or SetoidList for the rest
of the code to work properly while the constraint generation code is not adapted.
And temporarily extend the universe constraint code in univ to solve max(is) = max(js)
by first-order unification (these constraints should actually be implied not enforced).
- Fix romega plugin to use the right universes for polymorphic lists.
- Fix auto not refreshing the poly hints correctly.
- Proper postponing of universe constraints during unification, avoid making
arbitrary choices.
- Fix nf_evars_and* to keep the substitution around for later normalizations.
- Do add simplified universe constraints coming from unification during typechecking.
- Fix solve_by_tac in obligations to handle universes right, and the corresponding
substitution function.
Test global universe equality early during simplication of constraints.
Better hashconsing, but still not good on universe lists.
- Add postponing of "lub" constraints that should not be checked early,
they are implied by the others.
- Fix constructor tactic to use a fresh constructor instance avoiding
fixing universes.
- Use [eq_constr_universes] instead of [eq_constr_univs] everywhere,
this is the comparison function that doesn't care about the universe
instances.
- Almost all the library compiles in this new setting, but some more tactics
need to be adapted.
- Reinstate hconsing.
- Keep Prop <= u constraints that can be used to set the level of a universe
metavariable.
Add better hashconsing and unionfind in normalisation of constraints.
Fix a few problems in choose_canonical, normalization and substitution functions.
Fix after merge
Fixes after rebase with latest Coq trunk, everything compiles again,
albeit slowly in some cases.
- Fix module substitution and comparison of table keys in conversion
using the wrong order (should always be UserOrd now)
- Cleanup in universes, removing commented code.
- Fix normalization of universe context which was assigning global
levels to local ones. Should always be the other way!
- Fix universe implementation to implement sorted cons of universes
preserving order. Makes Univ.sup correct again, keeping universe in
normalized form.
- In evarconv.ml, allow again a Fix to appear as head of a weak-head normal
form (due to partially applied fixpoints).
- Catch anomalies of conversion as errors in reductionops.ml, sad but
necessary as eta-expansion might build ill-typed stacks like FProd,
[shift;app Rel 1], as it expands not only if the other side is rigid.
- Fix module substitution bug in auto.ml
- Fix case compilation: impossible cases compilation was generating useless universe
levels. Use an IDProp constant instead of the polymorphic identity to not influence
the level of the original type when building the case construct for the return type.
- Simplify normalization of universe constraints.
- Compute constructor levels of records correctly.
Fall back to levels for universe instances, avoiding issues of unification.
Add more to the test-suite for universe polymorphism.
Fix after rebase with trunk
Fix substitution of universes inside fields/params of records to be made
after all normalization is done and the level of the record has been
computed.
Proper sharing of lower bounds with fixed universes.
Conflicts:
library/universes.ml
library/universes.mli
Constraints were not enforced in compilation of cases
Fix after rebase with trunk
- Canonical projections up to universes
- Fix computation of class/record universe levels to allow
squashing to Prop/Set in impredicative set mode.
- Fix descend_in_conjunctions to properly instantiate projections with universes
- Avoid Context-bound variables taking extra universes in their associated universe context.
- Fix evar_define using the wrong direction when refreshing a universe under cumulativity
- Do not instantiate a local universe with some lower bound to a global one just because
they have the same local glb (they might not have the same one globally).
- Was loosing some global constraints during normalization (brought again by the kernel), fixed now.
- Proper [abstract] with polymorphic lemmas (polymorphic if the current proof is).
- Fix silly bug in autorewrite: any hint after the first one was always monomorphic.
- Fix fourier after rebase
- Refresh universes when checking types of metas in unification (avoid (sup (sup univ))).
- Speedup a script in FSetPositive.v
Rework definitions in RelationClasses and Morphisms to share universe
levels as much as possible. This factorizes many useless x <=
RelationClasses.foo constraints in code that uses setoid rewriting.
Slight incompatible change in the implicits for Reflexivity and
Irreflexivity as well.
- Share even more universes in Morphisms using a let.
- Use splay_prod instead of splay_prod_assum which doesn't reduce let's
to find a relation in setoid_rewrite
- Fix [Declare Instance] not properly dealing with let's in typeclass contexts.
Fixes in inductiveops, evarutil.
Patch by Yves Bertot to allow naming universes in inductive definitions.
Fixes in tacinterp not propagating evars correctly.
Fix for issue #27: lowering a Type to Prop is allowed during
inference (resulting in a Type (* Set *)) but kernel reduction
was wrongly refusing the equation [Type (*Set*) = Set].
Fix in interface of canonical structures: an instantiated polymorphic
projection is not needed to lookup a structure, just the projection name
is enough (reported by C. Cohen).
Move from universe inference to universe checking in the kernel.
All tactics have to be adapted so that they carry around their generated
constraints (living in their sigma), which is mostly straightforward.
The more important changes are when refering to Coq constants, the
tactics code is adapted so that primitive eq, pairing and sigma types might
be polymorphic.
Fix another few places in tacinterp and evarconv/evarsolve where the sigma
was not folded correctly.
- Fix discharge adding spurious global constraints on polymorphic universe variables
appearing in assumptions.
- Fixes in inductiveops not taking into account universe polymorphic inductives.
WIP on checked universe polymorphism, it is clearly incompatible
with the previous usage of polymorphic inductives + non-polymorphic
definitions on them as universe levels now appear in the inductive type,
and add equality constraints between universes that were otherwise just
in a cumulativity relation (not sure that was actually correct).
Refined version of unification of universe instances for first-order unification,
prefering unfolding to arbitrary identification of universes.
Moved kernel to universe checking only.
Adapt the code to properly infer constraints during typechecking and
refinement (tactics) and only check constraints when adding
constants/inductives to the environment. Exception made of module
subtyping that needs inference of constraints... The kernel conversion
(fconv) has two modes: checking only and inference, the later being used
by modules only. Evarconv/unification make use of a different strategy for
conversion of constants that prefer unfolding to blind unification of
rigid universes. Likewise, conversion checking backtracks on different universe
instances (modulo the constraints).
- adapt congruence/funind/ring plugins to this new mode, forcing them to
declare their constraints.
- To avoid big performance penalty with reification, make ring/field non-polymorphic
(non-linear explosion in run time to be investigated further).
- pattern and change tactics need special treatment: as they are not _reduction_
but conversion functions, their operation requires to update an evar_map with
new universe constraints.
- Fix vm_compute to work better with universes. If the normal
form is made only of constructors then the readback is correct. However a deeper change will
be needed to treat substitution of universe instances when unfolding constants.
Remove libtypes.ml
Fix after merge.
Fix after rebase with trunk.
**** Add projections to the kernel, as optimized implementations of constants.
- New constructor Proj expects a projection constant applied to its principal
inductive argument.
- Reduction machines shortcut the expansion to a case and directly project the
right argument.
- No need to keep parameters as part of the projection's arguments as they
are inferable from the type of the principal argument.
- ML code now compiles, debugging needed.
Start debugging the implementation of projections. Externalisation should
keep the information about projections.
Internalization, pattern-matching, unification and reduction
of projections.
Fix some code that used to have _ for parameters that are no longer
present in projections.
Fixes in unification, reduction, term indexing, auto hints based on projections,
add debug printers.
Fix byte-compilation of projections, unification, congruence with projections.
Adapt .v files using "@proj _ _ record" syntax, should come back on this later.
Fix coercion insertion code to properly deal with projection coercions.
Fix [simpl proj]... TODO [unfold proj], proj is not considered evaluable.
- Fix whnf of projections, now respecting opacity information.
- Fix conversion of projections to try first-order first and then
incrementally unfold them.
- Fix computation of implicit args for projections, simply dropping
the information for parameters.
- Fix a few scripts that relied on projections carrying their parameters (few at's,
rewrites).
- Fix unify_with_subterm to properly match under projections.
- Fix bug in cooking of projections.
- Add pattern PProj for projections.
- A very strange bug appeared in BigZ.v, making coqtop segfault on the export
of BigN... tofix
Fixes after rebase with trunk. Everything compiles now, with efficient
projections.
Fixes after rebase with trunk (esp. reductionops).
Remove warnings, backport patch from old univs+projs branch.
Proper expansion of projections during unification.
They are considered as maybe flexible keys in evarconv/unification. We
try firstorder unification and otherwise expand them as necessary,
completely mimicking the original behavior, when they were
constants. Fix head_constr_bound interface, the arguments are never
needed (they're outside their environment actually). [simpl] and
[red]/[intro] should behave just like before now.
Fix evarconv that was giving up on proj x = ?e problems too early.
- Port patch by Maxime Denes implementing fast projections in the native conversion.
- Backport patch to add eta-expansion for records.
Do not raise an exception but simply fails if trying to do eta on an inductive that is not a record.
Fix projections detyping/matching and unification.ml not always
recovering on first-order universe inequalities.
Correct eta-expansion for records, and change strategy for conversion
with projections to favor reduction over first-order unification a
little more. Fix a bug in Ltac pattern matching on projections.
Fix evars_reset_evd to not recheck existing constraints in case it is just an update
(performance improvement for typeclass resolution).
- Respect Global/Transparent oracle during unification. Opaque means
_never_ unfolded there.
- Add empty universes as well as the initial universes (having Prop < Set).
- Better display of universe inconsistencies.
- Add Beta Ziliani's patch to go fast avoiding imitation when possible.
- Allow instantiation by lower bound even if there are universes above
- (tentative) In refinement, avoid incremental refinement of terms
containing no holes and do it in one step (much faster on big terms).
Turned on only if not a checked command.
Remove dead code in univ/universes.ml and cleanup setup of hashconsing,
for a small speed and memory footprint improvement.
- Fix bug in unification using cumulativity when conversion should have been used.
- Fix unification of evars having type Type, no longer forcing them to be equal
(potentially more constraints): algorithm is now complete w.r.t. cumulativity.
- In clenvtac, use refine_nocheck as we are guaranteed to get well-typed terms
from unification now, including sufficient universe constraints. Small general
speedup.
- Fix inference of universe levels of inductive types to avoid smashing
inadvertently from Set to Prop.
- Fix computation of discharged hypotheses forgetting the arity in inductives.
- Fix wrong order in printing of universe inconsistency explanation
- Allow coercions between two polymorphic instances of the same inductive/constant.
- Do evar normalization and saturation by classes before trying to use program coercion
during pretyping.
- In unification, force equalities of universes when unifying the same rigid head constants.
- Fix omission of projections in constr_leq
- Fix [admit] tactic's handling of normalized universes.
Fix typing of projections not properly normalizing w.r.t. evars, resulting in anomaly sometimes.
Adapt rewrite to work with computational relations (in Type), while
maintaining backward compatibility with Propositional rewriting.
Introduce a [diff] function on evar maps and universe contexts to
properly deal with clause environments. Local hints in auto now store
just the extension of the evar map they rely on, so merging them becomes
efficient. This fixes an important performance issue in auto and typeclass
resolution in presence of a large number of universe constraints.
Change FSetPositive and MSetPositive to put their [elt] and [t] universes in
Type to avoid restricting global universes to [Set]. This is due to [flip]s
polymorphic type being fixed in monomorphic instances of Morphisms.v,
and rewriting hence forcing unification of levels that could be left unrelated.
- Try a fast_typeops implementation of kernel type inference that
allocates less by not rebuilding the term, shows a little performance
improvement, and less allocation.
- Build universe inconsistency explanations lazily, avoiding huge blowup
(x5) in check_constraints/merge_constraints in time and space (these
are stressed in universe polymorphic mode).
- Hashcons universe instances.
Add interface file for fast_typeops
Use monomorphic comparisons, little optimizations of hashconsing and
comparison in univ.ml.
Fix huge slowdown due to building huge error messages. Lazy is not
enough to tame this completely.
Fix last performance issue, due to abstracts building huge terms abstracting on parts of the section
context. Was due to wrong handling of Let... Qed.s in abstract. Performance is a tiny bit better than the
trunk now.
First step at compatibility layer for projections.
Compatibility mode for projections. c.(p), p c use primitive projs,
while @p refers to an expansion [λ params c, c.(p)]. Recovers almost
entire source compatibility with trunk scripts, except when mixing
@p and p and doing syntactic matching (they're unifiable though).
Add a [Set Primitive Projections] flag to set/unset the use of primitive
projections, selectively for each record. Adapt code to handle both the
legacy encoding and the primitive projections. Library is almost
source-to-source compatible, except for syntactic operations relying
on the presence of parameters. In primitive projections mode, @p refers
to an expansion [λ params r. p.(r)]. More information in CHANGES (to be
reformated/moved to reference manual).
Backport changes from HoTT/coq:
- Fix anomaly on uncatched NotASort in retyping.
- Better recognition of evars that are subject to typeclass resolution.
Fixes bug reported by J. Gross on coq-club.
- Print universe polymorphism information for parameters as well.
Fix interface for unsatisfiable constraints error, now a type error.
Try making ring polymorphic again, with a big slowdown, to be investigated.
Fix evar/universe leak in setoid rewrite.
- Add profiling flag
- Move setoid_ring back to non-polymorphic mode to compare perfs with trunk
- Change unification to allow using infer_conv more often (big perf culprit),
but semantics of backtracking on unification of constants is not properly
implemented there.
- Fix is_empty/union_evar_universe_context forgetting about some assignments.
- Performance is now very close to the trunk from june,
with projections deactivated.
Diffstat (limited to 'pretyping')
49 files changed, 2947 insertions, 1389 deletions
diff --git a/pretyping/arguments_renaming.ml b/pretyping/arguments_renaming.ml index 4562c5aa5..be22030ce 100644 --- a/pretyping/arguments_renaming.ml +++ b/pretyping/arguments_renaming.ml @@ -41,12 +41,12 @@ let section_segment_of_reference = function | ConstRef con -> Lib.section_segment_of_constant con | IndRef (kn,_) | ConstructRef ((kn,_),_) -> Lib.section_segment_of_mutual_inductive kn - | _ -> [] + | _ -> [], Univ.UContext.empty let discharge_rename_args = function | _, (ReqGlobal (c, names), _ as req) -> (try - let vars = section_segment_of_reference c in + let vars,_ = section_segment_of_reference c in let c' = pop_global_reference c in let var_names = List.map (fun (id, _,_,_) -> Name id) vars in let names' = List.map (fun l -> var_names @ l) names in @@ -87,22 +87,24 @@ let rename_type ty ref = with Not_found -> ty let rename_type_of_constant env c = - let ty = Typeops.type_of_constant env c in - rename_type ty (ConstRef c) + let ty = Typeops.type_of_constant_in env c in + rename_type ty (ConstRef (fst c)) let rename_type_of_inductive env ind = let ty = Inductiveops.type_of_inductive env ind in - rename_type ty (IndRef ind) + rename_type ty (IndRef (fst ind)) let rename_type_of_constructor env cstruct = let ty = Inductiveops.type_of_constructor env cstruct in - rename_type ty (ConstructRef cstruct) + rename_type ty (ConstructRef (fst cstruct)) let rename_typing env c = - let j = Typeops.typing env c in - match kind_of_term c with - | Const c -> { j with uj_type = rename_type j.uj_type (ConstRef c) } - | Ind i -> { j with uj_type = rename_type j.uj_type (IndRef i) } - | Construct k -> { j with uj_type = rename_type j.uj_type (ConstructRef k) } - | _ -> j + let j = Typeops.infer env c in + let j' = + match kind_of_term c with + | Const (c,u) -> { j with uj_type = rename_type j.uj_type (ConstRef c) } + | Ind (i,u) -> { j with uj_type = rename_type j.uj_type (IndRef i) } + | Construct (k,u) -> { j with uj_type = rename_type j.uj_type (ConstructRef k) } + | _ -> j + in j' diff --git a/pretyping/arguments_renaming.mli b/pretyping/arguments_renaming.mli index 09b8859e6..6c37f8938 100644 --- a/pretyping/arguments_renaming.mli +++ b/pretyping/arguments_renaming.mli @@ -16,7 +16,7 @@ val rename_arguments : bool -> global_reference -> Name.t list list -> unit (** [Not_found] is raised is no names are defined for [r] *) val arguments_names : global_reference -> Name.t list list -val rename_type_of_constant : env -> constant -> types -val rename_type_of_inductive : env -> inductive -> types -val rename_type_of_constructor : env -> constructor -> types +val rename_type_of_constant : env -> pconstant -> types +val rename_type_of_inductive : env -> pinductive -> types +val rename_type_of_constructor : env -> pconstructor -> types val rename_typing : env -> constr -> unsafe_judgment diff --git a/pretyping/cases.ml b/pretyping/cases.ml index d71499eda..1db3fac52 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -264,7 +264,8 @@ let rec find_row_ind = function | PatCstr(loc,c,_,_) :: _ -> Some (loc,c) let inductive_template evdref env tmloc ind = - let arsign = get_full_arity_sign env ind in + let indu = evd_comb1 (Evd.fresh_inductive_instance env) evdref ind in + let arsign = get_full_arity_sign env indu in let hole_source = match tmloc with | Some loc -> fun i -> (loc, Evar_kinds.TomatchTypeParameter (ind,i)) | None -> fun _ -> (Loc.ghost, Evar_kinds.InternalHole) in @@ -279,7 +280,7 @@ let inductive_template evdref env tmloc ind = | Some b -> (substl subst b::subst,evarl,n+1)) arsign ([],[],1) in - applist (mkInd ind,List.rev evarl) + applist (mkIndU indu,List.rev evarl) let try_find_ind env sigma typ realnames = let (IndType(_,realargs) as ind) = find_rectype env sigma typ in @@ -349,7 +350,7 @@ let coerce_to_indtype typing_fun evdref env matx tomatchl = (* Utils *) let mkExistential env ?(src=(Loc.ghost,Evar_kinds.InternalHole)) evdref = - e_new_evar evdref env ~src:src (new_Type ()) + let e, u = e_new_type_evar evdref univ_flexible_alg env ~src:src in e let evd_comb2 f evdref x y = let (evd',y) = f !evdref x y in @@ -928,13 +929,19 @@ let expand_arg tms (p,ccl) ((_,t),_,na) = let k = length_of_tomatch_type_sign na t in (p+k,liftn_predicate (k-1) (p+1) ccl tms) + +let use_unit_judge evd = + let j, ctx = coq_unit_judge () in + let evd' = Evd.merge_context_set Evd.univ_flexible_alg evd ctx in + evd', j + let adjust_impossible_cases pb pred tomatch submat = match submat with | [] -> begin match kind_of_term (whd_evar !(pb.evdref) pred) with | Evar (evk,_) when snd (evar_source evk !(pb.evdref)) == Evar_kinds.ImpossibleCase -> - let default = (coq_unit_judge ()).uj_type in - pb.evdref := Evd.define evk default !(pb.evdref); + let evd, default = use_unit_judge !(pb.evdref) in + pb.evdref := Evd.define evk default.uj_type evd; (* we add an "assert false" case *) let pats = List.map (fun _ -> PatVar (Loc.ghost,Anonymous)) tomatch in let aliasnames = @@ -1159,7 +1166,7 @@ let build_leaf pb = let build_branch initial current realargs deps (realnames,curname) pb arsign eqns const_info = (* We remember that we descend through constructor C *) let history = - push_history_pattern const_info.cs_nargs const_info.cs_cstr pb.history in + push_history_pattern const_info.cs_nargs (fst const_info.cs_cstr) pb.history in (* We prepare the matching on x1:T1 .. xn:Tn using some heuristic to *) (* build the name x1..xn from the names present in the equations *) @@ -1236,7 +1243,7 @@ let build_branch initial current realargs deps (realnames,curname) pb arsign eqn let cur_alias = lift const_info.cs_nargs current in let ind = appvect ( - applist (mkInd (inductive_of_constructor const_info.cs_cstr), + applist (mkIndU (inductive_of_constructor (fst const_info.cs_cstr), snd const_info.cs_cstr), List.map (lift const_info.cs_nargs) const_info.cs_params), const_info.cs_concl_realargs) in Alias (initial,(aliasname,cur_alias,(ci,ind))) in @@ -1293,7 +1300,7 @@ and match_current pb (initial,tomatch) = let mind,_ = dest_ind_family indf in let cstrs = get_constructors pb.env indf in let arsign, _ = get_arity pb.env indf in - let eqns,onlydflt = group_equations pb mind current cstrs pb.mat in + let eqns,onlydflt = group_equations pb (fst mind) current cstrs pb.mat in let no_cstr = Int.equal (Array.length cstrs) 0 in if (not no_cstr || not (List.is_empty pb.mat)) && onlydflt then compile_all_variables initial tomatch pb @@ -1313,7 +1320,7 @@ and match_current pb (initial,tomatch) = let (pred,typ) = find_predicate pb.caseloc pb.env pb.evdref pred current indt (names,dep) tomatch in - let ci = make_case_info pb.env mind pb.casestyle in + let ci = make_case_info pb.env (fst mind) pb.casestyle in let pred = nf_betaiota !(pb.evdref) pred in let case = mkCase (ci,pred,current,brvals) in Typing.check_allowed_sort pb.env !(pb.evdref) mind current pred; @@ -1594,10 +1601,9 @@ let build_tycon loc env tycon_env subst tycon extenv evdref t = we are in an impossible branch *) let n = rel_context_length (rel_context env) in let n' = rel_context_length (rel_context tycon_env) in - let tt = new_Type () in - let impossible_case_type = - e_new_evar evdref env ~src:(loc,Evar_kinds.ImpossibleCase) tt in - (lift (n'-n) impossible_case_type, tt) + let impossible_case_type, u = + e_new_type_evar evdref univ_flexible_alg env ~src:(loc,Evar_kinds.ImpossibleCase) in + (lift (n'-n) impossible_case_type, mkSort u) | Some t -> let t = abstract_tycon loc tycon_env evdref subst tycon extenv t in let evd,tt = Typing.e_type_of extenv !evdref t in @@ -1621,9 +1627,9 @@ let build_inversion_problem loc env sigma tms t = PatVar (Loc.ghost,Name id), ((id,t)::subst, id::avoid) in let rec reveal_pattern t (subst,avoid as acc) = match kind_of_term (whd_betadeltaiota env sigma t) with - | Construct cstr -> PatCstr (Loc.ghost,cstr,[],Anonymous), acc + | Construct (cstr,u) -> PatCstr (Loc.ghost,cstr,[],Anonymous), acc | App (f,v) when isConstruct f -> - let cstr = destConstruct f in + let cstr,u = destConstruct f in let n = constructor_nrealargs env cstr in let l = List.lastn n (Array.to_list v) in let l,acc = List.fold_map' reveal_pattern l acc in @@ -1707,11 +1713,18 @@ let build_inversion_problem loc env sigma tms t = it = None } } in (* [pb] is the auxiliary pattern-matching serving as skeleton for the return type of the original problem Xi *) + (* let sigma, s = Evd.new_sort_variable sigma in *) +(*FIXME TRY *) + (* let sigma, s = Evd.new_sort_variable univ_flexible sigma in *) + let s' = Retyping.get_sort_of env sigma t in + let sigma, s = Evd.new_sort_variable univ_flexible_alg sigma in + let sigma = Evd.set_leq_sort sigma s' s in let evdref = ref sigma in + (* let ty = evd_comb1 (refresh_universes false) evdref ty in *) let pb = { env = pb_env; evdref = evdref; - pred = new_Type(); + pred = (*ty *) mkSort s; tomatch = sub_tms; history = start_history n; mat = [eqn1;eqn2]; @@ -1744,7 +1757,7 @@ let extract_arity_signature ?(dolift=true) env0 tomatchl tmsign = str"Unexpected type annotation for a term of non inductive type.")) | IsInd (term,IndType(indf,realargs),_) -> let indf' = if dolift then lift_inductive_family n indf else indf in - let (ind,_) = dest_ind_family indf' in + let ((ind,u),_) = dest_ind_family indf' in let nparams_ctxt,nrealargs_ctxt = inductive_nargs_env env0 ind in let arsign = fst (get_arity env0 indf') in let realnal = @@ -1848,7 +1861,11 @@ let prepare_predicate loc typing_fun sigma env tomatchs arsign tycon pred = (* we use two strategies *) let sigma,t = match tycon with | Some t -> sigma,t - | None -> new_type_evar sigma env ~src:(loc, Evar_kinds.CasesType) in + | None -> + let sigma, (t, _) = + new_type_evar univ_flexible_alg sigma env ~src:(loc, Evar_kinds.CasesType) in + sigma, t + in (* First strategy: we build an "inversion" predicate *) let sigma1,pred1 = build_inversion_problem loc env sigma tomatchs t in (* Second strategy: we directly use the evar as a non dependent pred *) @@ -1858,7 +1875,7 @@ let prepare_predicate loc typing_fun sigma env tomatchs arsign tycon pred = | Some rtntyp, _ -> (* We extract the signature of the arity *) let envar = List.fold_right push_rel_context arsign env in - let sigma, newt = new_sort_variable sigma in + let sigma, newt = new_sort_variable univ_flexible_alg sigma in let evdref = ref sigma in let predcclj = typing_fun (mk_tycon (mkSort newt)) envar evdref rtntyp in let sigma = !evdref in @@ -1933,7 +1950,7 @@ let constr_of_pat env evdref arsign pat avoid = with Not_found -> error_case_not_inductive env {uj_val = ty; uj_type = Typing.type_of env !evdref ty} in - let ind, params = dest_ind_family indf in + let (ind,u), params = dest_ind_family indf in if not (eq_ind ind cind) then error_bad_constructor_loc l cstr ind; let cstrs = get_constructors env indf in let ci = cstrs.(i-1) in @@ -1954,7 +1971,7 @@ let constr_of_pat env evdref arsign pat avoid = let args = List.rev args in let patargs = List.rev patargs in let pat' = PatCstr (l, cstr, patargs, alias) in - let cstr = mkConstruct ci.cs_cstr in + let cstr = mkConstructU ci.cs_cstr in let app = applistc cstr (List.map (lift (List.length sign)) params) in let app = applistc app args in let apptype = Retyping.get_type_of env ( !evdref) app in @@ -2010,7 +2027,7 @@ let vars_of_ctx ctx = | Some t' when is_topvar t' -> prev, (GApp (Loc.ghost, - (GRef (Loc.ghost, delayed_force coq_eq_refl_ref)), + (GRef (Loc.ghost, delayed_force coq_eq_refl_ref, None)), [hole; GVar (Loc.ghost, prev)])) :: vars | _ -> match na with @@ -2282,7 +2299,7 @@ let compile_program_cases loc style (typing_function, evdref) tycon env (predopt, tomatchl, eqns) = let typing_fun tycon env = function | Some t -> typing_function tycon env evdref t - | None -> coq_unit_judge () in + | None -> Evarutil.evd_comb0 use_unit_judge evdref in (* We build the matrix of patterns and right-hand side *) let matx = matx_of_eqns env eqns in @@ -2361,7 +2378,7 @@ let compile_program_cases loc style (typing_function, evdref) tycon env let typing_function tycon env evdref = function | Some t -> typing_function tycon env evdref t - | None -> coq_unit_judge () in + | None -> evd_comb0 use_unit_judge evdref in let pb = { env = env; @@ -2435,7 +2452,7 @@ let compile_cases loc style (typing_fun, evdref) tycon env (predopt, tomatchl, e (* A typing function that provides with a canonical term for absurd cases*) let typing_fun tycon env evdref = function | Some t -> typing_fun tycon env evdref t - | None -> coq_unit_judge () in + | None -> evd_comb0 use_unit_judge evdref in let myevdref = ref sigma in diff --git a/pretyping/cbv.ml b/pretyping/cbv.ml index 1334fb285..4c1e3c3af 100644 --- a/pretyping/cbv.ml +++ b/pretyping/cbv.ml @@ -45,7 +45,7 @@ type cbv_value = | LAM of int * (Name.t * constr) list * constr * cbv_value subs | FIXP of fixpoint * cbv_value subs * cbv_value array | COFIXP of cofixpoint * cbv_value subs * cbv_value array - | CONSTR of constructor * cbv_value array + | CONSTR of constructor puniverses * cbv_value array (* type of terms with a hole. This hole can appear only under App or Case. * TOP means the term is considered without context @@ -67,6 +67,7 @@ and cbv_stack = | TOP | APP of cbv_value array * cbv_stack | CASE of constr * constr array * case_info * cbv_value subs * cbv_stack + | PROJ of projection * Declarations.projection_body * cbv_stack (* les vars pourraient etre des constr, cela permet de retarder les lift: utile ?? *) @@ -107,7 +108,7 @@ let contract_cofixp env (i,(_,_,bds as bodies)) = let make_constr_ref n = function | RelKey p -> mkRel (n+p) | VarKey id -> mkVar id - | ConstKey cst -> mkConst cst + | ConstKey cst -> mkConstU cst (* Adds an application list. Collapse APPs! *) let stack_app appl stack = @@ -121,6 +122,7 @@ let rec stack_concat stk1 stk2 = TOP -> stk2 | APP(v,stk1') -> APP(v,stack_concat stk1' stk2) | CASE(c,b,i,s,stk1') -> CASE(c,b,i,s,stack_concat stk1' stk2) + | PROJ (p,pinfo,stk1') -> PROJ (p,pinfo,stack_concat stk1' stk2) (* merge stacks when there is no shifts in between *) let mkSTACK = function @@ -136,7 +138,7 @@ open RedFlags let red_set_ref flags = function | RelKey _ -> red_set flags fDELTA | VarKey id -> red_set flags (fVAR id) - | ConstKey sp -> red_set flags (fCONST sp) + | ConstKey (sp,_) -> red_set flags (fCONST sp) (* Transfer application lists from a value to the stack * useful because fixpoints may be totally applied in several times. @@ -193,6 +195,10 @@ let rec norm_head info env t stack = norm_head info env head (stack_app nargs stack) | Case (ci,p,c,v) -> norm_head info env c (CASE(p,v,ci,env,stack)) | Cast (ct,_,_) -> norm_head info env ct stack + + | Proj (p, c) -> + let pinfo = Option.get ((Environ.lookup_constant p (info_env info)).Declarations.const_proj) in + norm_head info env c (PROJ (p, pinfo, stack)) (* constants, axioms * the first pattern is CRUCIAL, n=0 happens very often: @@ -221,7 +227,7 @@ let rec norm_head info env t stack = (CBN(t,env), stack) (* Considérer une coupure commutative ? *) | Evar ev -> - (match evar_value info ev with + (match evar_value info.i_cache ev with Some c -> norm_head info env c stack | None -> (VAL(0, t), stack)) @@ -279,14 +285,14 @@ and cbv_stack_term info stack env t = cbv_stack_term info stk envf redfix (* constructor in a Case -> IOTA *) - | (CONSTR((sp,n),[||]), APP(args,CASE(_,br,ci,env,stk))) + | (CONSTR(((sp,n),u),[||]), APP(args,CASE(_,br,ci,env,stk))) when red_set (info_flags info) fIOTA -> let cargs = Array.sub args ci.ci_npar (Array.length args - ci.ci_npar) in cbv_stack_term info (stack_app cargs stk) env br.(n-1) (* constructor of arity 0 in a Case -> IOTA *) - | (CONSTR((_,n),[||]), CASE(_,br,_,env,stk)) + | (CONSTR(((_,n),u),[||]), CASE(_,br,_,env,stk)) when red_set (info_flags info) fIOTA -> cbv_stack_term info stk env br.(n-1) @@ -312,6 +318,8 @@ let rec apply_stack info t = function (mkCase (ci, cbv_norm_term info env ty, t, Array.map (cbv_norm_term info env) br)) st + | PROJ (p, pinfo, st) -> + apply_stack info (mkProj (p, t)) st (* performs the reduction on a constr, and returns a constr *) and cbv_norm_term info env t = @@ -348,7 +356,7 @@ and cbv_norm_value info = function (* reduction under binders *) (subs_liftn (Array.length lty) env)) bds)), Array.map (cbv_norm_value info) args) | CONSTR (c,args) -> - mkApp(mkConstruct c, Array.map (cbv_norm_value info) args) + mkApp(mkConstructU c, Array.map (cbv_norm_value info) args) (* with profiling *) let cbv_norm infos constr = diff --git a/pretyping/cbv.mli b/pretyping/cbv.mli index 66aef4d14..adb2ed15d 100644 --- a/pretyping/cbv.mli +++ b/pretyping/cbv.mli @@ -30,12 +30,13 @@ type cbv_value = | LAM of int * (Name.t * constr) list * constr * cbv_value subs | FIXP of fixpoint * cbv_value subs * cbv_value array | COFIXP of cofixpoint * cbv_value subs * cbv_value array - | CONSTR of constructor * cbv_value array + | CONSTR of constructor puniverses * cbv_value array and cbv_stack = | TOP | APP of cbv_value array * cbv_stack | CASE of constr * constr array * case_info * cbv_value subs * cbv_stack + | PROJ of projection * Declarations.projection_body * cbv_stack val shift_value : int -> cbv_value -> cbv_value diff --git a/pretyping/classops.ml b/pretyping/classops.ml index 886e00e83..86b789f7d 100644 --- a/pretyping/classops.ml +++ b/pretyping/classops.ml @@ -44,7 +44,9 @@ type coe_info_typ = { coe_value : constr; coe_type : types; coe_local : bool; + coe_context : Univ.universe_context_set; coe_is_identity : bool; + coe_is_projection : bool; coe_param : int } let coe_info_typ_equal c1 c2 = @@ -52,6 +54,7 @@ let coe_info_typ_equal c1 c2 = eq_constr c1.coe_type c2.coe_type && c1.coe_local == c2.coe_local && c1.coe_is_identity == c2.coe_is_identity && + c1.coe_is_projection == c2.coe_is_projection && Int.equal c1.coe_param c2.coe_param let cl_typ_ord t1 t2 = match t1, t2 with @@ -184,16 +187,16 @@ let coercion_info coe = CoeTypMap.find coe !coercion_tab let coercion_exists coe = CoeTypMap.mem coe !coercion_tab -(* find_class_type : evar_map -> constr -> cl_typ * constr list *) +(* find_class_type : evar_map -> constr -> cl_typ * universe_list * constr list *) let find_class_type sigma t = let t', args = Reductionops.whd_betaiotazeta_stack sigma t in match kind_of_term t' with - | Var id -> CL_SECVAR id, args - | Const sp -> CL_CONST sp, args - | Ind ind_sp -> CL_IND ind_sp, args - | Prod (_,_,_) -> CL_FUN, [] - | Sort _ -> CL_SORT, [] + | Var id -> CL_SECVAR id, Univ.Instance.empty, args + | Const (sp,u) -> CL_CONST sp, u, args + | Ind (ind_sp,u) -> CL_IND ind_sp, u, args + | Prod (_,_,_) -> CL_FUN, Univ.Instance.empty, [] + | Sort _ -> CL_SORT, Univ.Instance.empty, [] | _ -> raise Not_found @@ -201,38 +204,37 @@ let subst_cl_typ subst ct = match ct with CL_SORT | CL_FUN | CL_SECVAR _ -> ct - | CL_CONST kn -> - let kn',t = subst_con subst kn in - if kn' == kn then ct else - fst (find_class_type Evd.empty t) - | CL_IND (kn,i) -> - let kn' = subst_ind subst kn in - if kn' == kn then ct else - CL_IND (kn',i) + | CL_CONST c -> + let c',t = subst_con_kn subst c in + if c' == c then ct else + pi1 (find_class_type Evd.empty t) + | CL_IND i -> + let i' = subst_ind subst i in + if i' == i then ct else CL_IND i' (*CSC: here we should change the datatype for coercions: it should be possible to declare any term as a coercion *) -let subst_coe_typ subst t = fst (subst_global subst t) +let subst_coe_typ subst t = subst_global_reference subst t (* class_of : Term.constr -> int *) let class_of env sigma t = - let (t, n1, i, args) = + let (t, n1, i, u, args) = try - let (cl,args) = find_class_type sigma t in + let (cl, u, args) = find_class_type sigma t in let (i, { cl_param = n1 } ) = class_info cl in - (t, n1, i, args) + (t, n1, i, u, args) with Not_found -> let t = Tacred.hnf_constr env sigma t in - let (cl, args) = find_class_type sigma t in + let (cl, u, args) = find_class_type sigma t in let (i, { cl_param = n1 } ) = class_info cl in - (t, n1, i, args) + (t, n1, i, u, args) in if Int.equal (List.length args) n1 then t, i else raise Not_found let inductive_class_of ind = fst (class_info (CL_IND ind)) -let class_args_of env sigma c = snd (find_class_type sigma c) +let class_args_of env sigma c = pi3 (find_class_type sigma c) let string_of_class = function | CL_FUN -> "Funclass" @@ -261,14 +263,14 @@ let lookup_path_to_sort_from_class s = let apply_on_class_of env sigma t cont = try - let (cl,args) = find_class_type sigma t in + let (cl,u,args) = find_class_type sigma t in let (i, { cl_param = n1 } ) = class_info cl in if not (Int.equal (List.length args) n1) then raise Not_found; t, cont i with Not_found -> (* Is it worth to be more incremental on the delta steps? *) let t = Tacred.hnf_constr env sigma t in - let (cl, args) = find_class_type sigma t in + let (cl, u, args) = find_class_type sigma t in let (i, { cl_param = n1 } ) = class_info cl in if not (Int.equal (List.length args) n1) then raise Not_found; t, cont i @@ -291,7 +293,7 @@ let get_coercion_constructor coe = Reductionops.whd_betadeltaiota_stack (Global.env()) Evd.empty coe.coe_value in match kind_of_term c with - | Construct cstr -> + | Construct (cstr,u) -> (cstr, Inductiveops.constructor_nrealargs (Global.env()) cstr -1) | _ -> raise Not_found @@ -303,8 +305,12 @@ let lookup_pattern_path_between (s,t) = (* coercion_value : coe_index -> unsafe_judgment * bool *) -let coercion_value { coe_value = c; coe_type = t; coe_is_identity = b } = - (make_judge c t, b) +let coercion_value { coe_value = c; coe_type = t; coe_context = ctx; + coe_is_identity = b; coe_is_projection = b' } = + let subst, ctx = Universes.fresh_universe_context_set_instance ctx in + let c' = Vars.subst_univs_level_constr subst c + and t' = Vars.subst_univs_level_constr subst t in + (make_judge c' t', b, b'), ctx (* pretty-print functions are now in Pretty *) (* rajouter une coercion dans le graphe *) @@ -323,9 +329,15 @@ let message_ambig l = (* add_coercion_in_graph : coe_index * cl_index * cl_index -> unit coercion,source,target *) -let different_class_params i j = - (snd (class_info_from_index i)).cl_param > 0 - +let different_class_params i = + let ci = class_info_from_index i in + if (snd ci).cl_param > 0 then true + else + match fst ci with + | CL_IND i -> Global.is_polymorphic (IndRef i) + | CL_CONST c -> Global.is_polymorphic (ConstRef c) + | _ -> false + let add_coercion_in_graph (ic,source,target) = let old_inheritance_graph = !inheritance_graph in let ambig_paths = @@ -333,12 +345,12 @@ let add_coercion_in_graph (ic,source,target) = let try_add_new_path (i,j as ij) p = try if Bijint.Index.equal i j then begin - if different_class_params i j then begin + if different_class_params i then begin let _ = lookup_path_between_class ij in ambig_paths := (ij,p)::!ambig_paths end end else begin - let _ = lookup_path_between_class (i,j) in + let _ = lookup_path_between_class ij in ambig_paths := (ij,p)::!ambig_paths end; false @@ -374,6 +386,7 @@ type coercion = { coercion_type : coe_typ; coercion_local : bool; coercion_is_id : bool; + coercion_is_proj : bool; coercion_source : cl_typ; coercion_target : cl_typ; coercion_params : int; @@ -382,7 +395,7 @@ type coercion = { (* Calcul de l'arité d'une classe *) let reference_arity_length ref = - let t = Global.type_of_global ref in + let t,_ = Universes.type_of_global ref in List.length (fst (Reductionops.splay_arity (Global.env()) Evd.empty t)) let class_params = function @@ -413,11 +426,15 @@ let cache_coercion (_, c) = let () = add_class c.coercion_target in let is, _ = class_info c.coercion_source in let it, _ = class_info c.coercion_target in + let value, ctx = Universes.fresh_global_instance (Global.env()) c.coercion_type in + let typ = Retyping.get_type_of (Global.env ()) Evd.empty value in let xf = - { coe_value = constr_of_global c.coercion_type; - coe_type = Global.type_of_global c.coercion_type; + { coe_value = value; + coe_type = typ; + coe_context = ctx; coe_local = c.coercion_local; coe_is_identity = c.coercion_is_id; + coe_is_projection = c.coercion_is_proj; coe_param = c.coercion_params } in let () = add_new_coercion c.coercion_type xf in add_coercion_in_graph (xf,is,it) @@ -441,7 +458,6 @@ let subst_coercion (subst, c) = if c.coercion_type == coe && c.coercion_source == cls && c.coercion_target == clt then c else { c with coercion_type = coe; coercion_source = cls; coercion_target = clt } - let discharge_cl = function | CL_CONST kn -> CL_CONST (Lib.discharge_con kn) | CL_IND ind -> CL_IND (Lib.discharge_inductive ind) @@ -453,7 +469,7 @@ let discharge_coercion (_, c) = let n = try let ins = Lib.section_instance c.coercion_type in - Array.length ins + Array.length (snd ins) with Not_found -> 0 in let nc = { c with @@ -477,10 +493,16 @@ let inCoercion : coercion -> obj = discharge_function = discharge_coercion } let declare_coercion coef ?(local = false) ~isid ~src:cls ~target:clt ~params:ps = + let isproj = + match coef with + | ConstRef c -> Environ.is_projection c (Global.env ()) + | _ -> false + in let c = { coercion_type = coef; coercion_local = local; coercion_is_id = isid; + coercion_is_proj = isproj; coercion_source = cls; coercion_target = clt; coercion_params = ps; diff --git a/pretyping/classops.mli b/pretyping/classops.mli index 7bde9e910..3251dc4eb 100644 --- a/pretyping/classops.mli +++ b/pretyping/classops.mli @@ -53,9 +53,9 @@ val class_info : cl_typ -> (cl_index * cl_info_typ) val class_info_from_index : cl_index -> cl_typ * cl_info_typ -(** [find_class_type env sigma c] returns the head reference of [c] and its - arguments *) -val find_class_type : evar_map -> types -> cl_typ * constr list +(** [find_class_type env sigma c] returns the head reference of [c], + its universe instance and its arguments *) +val find_class_type : evar_map -> types -> cl_typ * Univ.universe_instance * constr list (** raises [Not_found] if not convertible to a class *) val class_of : env -> evar_map -> types -> types * cl_index @@ -73,7 +73,7 @@ val declare_coercion : (** {6 Access to coercions infos } *) val coercion_exists : coe_typ -> bool -val coercion_value : coe_index -> (unsafe_judgment * bool) +val coercion_value : coe_index -> (unsafe_judgment * bool * bool) Univ.in_universe_context_set (** {6 Lookup functions for coercion paths } *) diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index 1db4119be..43af6ec62 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -34,19 +34,22 @@ exception NoCoercion exception NoCoercionNoUnifier of evar_map * unification_error (* Here, funj is a coercion therefore already typed in global context *) -let apply_coercion_args env argl funj = +let apply_coercion_args env evd check argl funj = + let evdref = ref evd in let rec apply_rec acc typ = function | [] -> { uj_val = applist (j_val funj,argl); uj_type = typ } | h::restl -> (* On devrait pouvoir s'arranger pour qu'on n'ait pas à faire hnf_constr *) - match kind_of_term (whd_betadeltaiota env Evd.empty typ) with + match kind_of_term (whd_betadeltaiota env evd typ) with | Prod (_,c1,c2) -> - (* Typage garanti par l'appel à app_coercion*) + if check && not (e_cumul env evdref (Retyping.get_type_of env evd h) c1) then + anomaly (Pp.str"apply_coercion_args: mismatch between arguments and coercion"); apply_rec (h::acc) (subst1 h c2) restl | _ -> anomaly (Pp.str "apply_coercion_args") in - apply_rec [] funj.uj_type argl + let res = apply_rec [] funj.uj_type argl in + !evdref, res (* appliquer le chemin de coercions de patterns p *) let apply_pattern_coercion loc pat p = @@ -78,10 +81,10 @@ let disc_subset x = match kind_of_term x with | App (c, l) -> (match kind_of_term c with - Ind i -> + Ind (i,_) -> let len = Array.length l in let sigty = delayed_force sig_typ in - if Int.equal len 2 && eq_ind i (destInd sigty) + if Int.equal len 2 && eq_ind i (fst (Term.destInd sigty)) then let (a, b) = pair_of_array l in Some (a, b) @@ -170,11 +173,11 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr) in match (kind_of_term x, kind_of_term y) with | Sort s, Sort s' -> - (match s, s' with - Prop x, Prop y when x == y -> None - | Prop _, Type _ -> None - | Type x, Type y when Univ.Universe.equal x y -> None (* false *) - | _ -> subco ()) + (match s, s' with + | Prop x, Prop y when x == y -> None + | Prop _, Type _ -> None + | Type x, Type y when Univ.Universe.eq x y -> None (* false *) + | _ -> subco ()) | Prod (name, a, b), Prod (name', a', b') -> let name' = Name (Namegen.next_ident_away (Id.of_string "x") (Termops.ids_of_context env)) in let env' = push_rel (name', None, a') env in @@ -195,15 +198,15 @@ and coerce loc env evdref (x : Term.constr) (y : Term.constr) | App (c, l), App (c', l') -> (match kind_of_term c, kind_of_term c' with - Ind i, Ind i' -> (* Inductive types *) + Ind (i, u), Ind (i', u') -> (* Inductive types *) let len = Array.length l in let sigT = delayed_force sigT_typ in let prod = delayed_force prod_typ in (* Sigma types *) if Int.equal len (Array.length l') && Int.equal len 2 && eq_ind i i' - && (eq_ind i (destInd sigT) || eq_ind i (destInd prod)) + && (eq_ind i (fst (Term.destInd sigT)) || eq_ind i (fst (Term.destInd prod))) then - if eq_ind i (destInd sigT) + if eq_ind i (fst (Term.destInd sigT)) then begin let (a, pb), (a', pb') = @@ -323,17 +326,25 @@ let saturate_evd env evd = (* appliquer le chemin de coercions p à hj *) let apply_coercion env sigma p hj typ_cl = try - fst (List.fold_left - (fun (ja,typ_cl) i -> - let fv,isid = coercion_value i in - let argl = (class_args_of env sigma typ_cl)@[ja.uj_val] in - let jres = apply_coercion_args env argl fv in - (if isid then - { uj_val = ja.uj_val; uj_type = jres.uj_type } - else - jres), - jres.uj_type) - (hj,typ_cl) p) + let j,t,evd = + List.fold_left + (fun (ja,typ_cl,sigma) i -> + let ((fv,isid,isproj),ctx) = coercion_value i in + let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx in + let argl = (class_args_of env sigma typ_cl)@[ja.uj_val] in + let sigma, jres = + apply_coercion_args env sigma (not (Univ.ContextSet.is_empty ctx)) argl fv + in + (if isid then + { uj_val = ja.uj_val; uj_type = jres.uj_type } + else if isproj then + { uj_val = mkProj (fst (destConst fv.uj_val), ja.uj_val); + uj_type = jres.uj_type } + else + jres), + jres.uj_type,sigma) + (hj,typ_cl,sigma) p + in evd, j with e when Errors.noncritical e -> anomaly (Pp.str "apply_coercion") let inh_app_fun env evd j = @@ -346,7 +357,7 @@ let inh_app_fun env evd j = | _ -> try let t,p = lookup_path_to_fun_from env evd j.uj_type in - (evd,apply_coercion env evd p j t) + apply_coercion env evd p j t with Not_found when Flags.is_program_mode () -> try let evdref = ref evd in @@ -367,7 +378,7 @@ let inh_app_fun resolve_tc env evd j = let inh_tosort_force loc env evd j = try let t,p = lookup_path_to_sort_from env evd j.uj_type in - let j1 = apply_coercion env evd p j t in + let evd,j1 = apply_coercion env evd p j t in let j2 = on_judgment_type (whd_evar evd) j1 in (evd,type_judgment env j2) with Not_found -> @@ -405,16 +416,16 @@ let inh_coerce_to_fail env evd rigidonly v t c1 = then raise NoCoercion else - let v', t' = + let evd, v', t' = try let t2,t1,p = lookup_path_between env evd (t,c1) in match v with Some v -> - let j = + let evd,j = apply_coercion env evd p {uj_val = v; uj_type = t} t2 in - Some j.uj_val, j.uj_type - | None -> None, t + evd, Some j.uj_val, j.uj_type + | None -> evd, None, t with Not_found -> raise NoCoercion in try (the_conv_x_leq env t' c1 evd, v') @@ -466,11 +477,20 @@ let inh_conv_coerce_to_gen resolve_tc rigidonly loc env evd cj t = | NoSubtacCoercion when not resolve_tc -> error_actual_type_loc loc env best_failed_evd cj t e | NoSubtacCoercion -> - let evd = saturate_evd env evd in + let evd' = saturate_evd env evd in try - inh_conv_coerce_to_fail loc env evd rigidonly (Some cj.uj_val) cj.uj_type t + if evd' == evd then + error_actual_type_loc loc env best_failed_evd cj t e + else + inh_conv_coerce_to_fail loc env evd' rigidonly (Some cj.uj_val) cj.uj_type t with NoCoercionNoUnifier (best_failed_evd,e) -> error_actual_type_loc loc env best_failed_evd cj t e + + (* let evd = saturate_evd env evd in *) + (* try *) + (* inh_conv_coerce_to_fail loc env evd rigidonly (Some cj.uj_val) cj.uj_type t *) + (* with NoCoercionNoUnifier (best_failed_evd,e) -> *) + (* error_actual_type_loc loc env best_failed_evd cj t e *) in let val' = match val' with Some v -> v | None -> assert(false) in (evd',{ uj_val = val'; uj_type = t }) diff --git a/pretyping/constrMatching.ml b/pretyping/constrMatching.ml index 45b097c00..243b563d3 100644 --- a/pretyping/constrMatching.ml +++ b/pretyping/constrMatching.ml @@ -63,7 +63,7 @@ let warn_bound_again name = let constrain n (ids, m as x) (names, terms as subst) = try let (ids', m') = Id.Map.find n terms in - if List.equal Id.equal ids ids' && eq_constr m m' then subst + if List.equal Id.equal ids ids' && eq_constr_nounivs m m' then subst else raise PatternMatchingFailure with Not_found -> let () = if Id.Map.mem n names then warn_bound_meta n in @@ -139,9 +139,18 @@ let merge_binding allow_bound_rels stk n cT subst = constrain n c subst let matches_core convert allow_partial_app allow_bound_rels pat c = - let conv = match convert with - | None -> eq_constr - | Some (env,sigma) -> is_conv env sigma in + let convref ref c = + match ref, kind_of_term c with + | VarRef id, Var id' -> Names.id_eq id id' + | ConstRef c, Const (c',_) -> Names.eq_constant c c' + | IndRef i, Ind (i', _) -> Names.eq_ind i i' + | ConstructRef c, Construct (c',u) -> Names.eq_constructor c c' + | _, _ -> (match convert with + | None -> false + | Some (env,sigma) -> + let sigma,c' = Evd.fresh_global env sigma ref in + is_conv env sigma c' c) + in let rec sorec stk subst p t = let cT = strip_outer_cast t in match p,kind_of_term cT with @@ -165,7 +174,7 @@ let matches_core convert allow_partial_app allow_bound_rels pat c = | PVar v1, Var v2 when Id.equal v1 v2 -> subst - | PRef ref, _ when conv (constr_of_global ref) cT -> subst + | PRef ref, _ when convref ref cT -> subst | PRel n1, Rel n2 when Int.equal n1 n2 -> subst @@ -193,8 +202,17 @@ let matches_core convert allow_partial_app allow_bound_rels pat c = else raise PatternMatchingFailure | PApp (c1,arg1), App (c2,arg2) -> - (try Array.fold_left2 (sorec stk) (sorec stk subst c1 c2) arg1 arg2 - with Invalid_argument _ -> raise PatternMatchingFailure) + (match c1, kind_of_term c2 with + | PRef (ConstRef r), Proj _ -> + (let subst = (sorec stk subst (PProj (r,arg1.(0))) c2) in + try Array.fold_left2 (sorec stk) subst (Array.tl arg1) arg2 + with Invalid_argument _ -> raise PatternMatchingFailure) + | _ -> + (try Array.fold_left2 (sorec stk) (sorec stk subst c1 c2) arg1 arg2 + with Invalid_argument _ -> raise PatternMatchingFailure)) + + | PProj (p1,c1), Proj (p2,c2) when eq_constant p1 p2 -> + sorec stk subst c1 c2 | PProd (na1,c1,d1), Prod(na2,c2,d2) -> sorec ((na1,na2,c2)::stk) @@ -367,6 +385,10 @@ let sub_match ?(partial_app=false) ?(closed=true) pat c = let next () = try_aux ((Array.to_list types)@(Array.to_list bodies)) next_mk_ctx next in authorized_occ partial_app closed pat c mk_ctx next + | Proj (p,c') -> + let next_mk_ctx le = mk_ctx (mkProj (p,List.hd le)) in + let next () = try_aux [c'] next_mk_ctx next in + authorized_occ partial_app closed pat c mk_ctx next | Construct _| Ind _|Evar _|Const _ | Rel _|Meta _|Var _|Sort _ -> authorized_occ partial_app closed pat c mk_ctx next diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index 9bc3d68c6..652c5acf9 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -73,10 +73,7 @@ module PrintingInductiveMake = type t = inductive let compare = ind_ord let encode = Test.encode - let subst subst (kn, ints as obj) = - let kn' = subst_ind subst kn in - if kn' == kn then obj else - kn', ints + let subst subst obj = subst_ind subst obj let printer ind = pr_global_env Id.Set.empty (IndRef ind) let key = ["Printing";Test.field] let title = Test.title @@ -373,7 +370,7 @@ let detype_sort = function | Type u -> GType (if !print_universes - then Some (Pp.string_of_ppcmds (Univ.pr_uni u)) + then Some (Pp.string_of_ppcmds (Univ.Universe.pr u)) else None) type binder_kind = BProd | BLambda | BLetIn @@ -384,6 +381,10 @@ type binder_kind = BProd | BLambda | BLetIn let detype_anonymous = ref (fun loc n -> anomaly ~label:"detype" (Pp.str "index to an anonymous variable")) let set_detype_anonymous f = detype_anonymous := f +let option_of_instance l = + if Univ.Instance.is_empty l then None + else Some l + let rec detype (isgoal:bool) avoid env t = match kind_of_term (collapse_appl t) with | Rel n -> @@ -397,7 +398,7 @@ let rec detype (isgoal:bool) avoid env t = (* Meta in constr are not user-parsable and are mapped to Evar *) GEvar (dl, Evar.unsafe_of_int n, None) | Var id -> - (try let _ = Global.lookup_named id in GRef (dl, VarRef id) + (try let _ = Global.lookup_named id in GRef (dl, VarRef id, None) with Not_found -> GVar (dl, id)) | Sort s -> GSort (dl,detype_sort s) | Cast (c1,REVERTcast,c2) when not !Flags.raw_print -> @@ -415,16 +416,26 @@ let rec detype (isgoal:bool) avoid env t = | Lambda (na,ty,c) -> detype_binder isgoal BLambda avoid env na ty c | LetIn (na,b,_,c) -> detype_binder isgoal BLetIn avoid env na b c | App (f,args) -> - GApp (dl,detype isgoal avoid env f, - Array.map_to_list (detype isgoal avoid env) args) - | Const sp -> GRef (dl, ConstRef sp) + let mkapp f' args' = + match f' with + | GApp (dl',f',args'') -> + GApp (dl,f',args''@args') + | _ -> GApp (dl,f',args') + in + mkapp (detype isgoal avoid env f) + (Array.map_to_list (detype isgoal avoid env) args) + (* GApp (dl,detype isgoal avoid env f, *) + (* Array.map_to_list (detype isgoal avoid env) args) *) + | Const (sp,u) -> GRef (dl, ConstRef sp, option_of_instance u) + | Proj (p,c) -> + GProj (dl, p, detype isgoal avoid env c) | Evar (ev,cl) -> GEvar (dl, ev, Some (List.map (detype isgoal avoid env) (Array.to_list cl))) - | Ind ind_sp -> - GRef (dl, IndRef ind_sp) - | Construct cstr_sp -> - GRef (dl, ConstructRef cstr_sp) + | Ind (ind_sp,u) -> + GRef (dl, IndRef ind_sp, option_of_instance u) + | Construct (cstr_sp,u) -> + GRef (dl, ConstructRef cstr_sp, option_of_instance u) | Case (ci,p,c,bl) -> let comp = computable p (ci.ci_pp_info.ind_nargs) in detype_case comp (detype isgoal avoid env) @@ -589,7 +600,7 @@ let rec subst_cases_pattern subst pat = match pat with | PatVar _ -> pat | PatCstr (loc,((kn,i),j),cpl,n) -> - let kn' = subst_ind subst kn + let kn' = subst_mind subst kn and cpl' = List.smartmap (subst_cases_pattern subst) cpl in if kn' == kn && cpl' == cpl then pat else PatCstr (loc,((kn',i),j),cpl',n) @@ -598,7 +609,7 @@ let (f_subst_genarg, subst_genarg_hook) = Hook.make () let rec subst_glob_constr subst raw = match raw with - | GRef (loc,ref) -> + | GRef (loc,ref,u) -> let ref',t = subst_global subst ref in if ref' == ref then raw else detype false [] [] t @@ -613,6 +624,12 @@ let rec subst_glob_constr subst raw = if r' == r && rl' == rl then raw else GApp(loc,r',rl') + | GProj (loc,p,c) -> + let p' = subst_constant subst p in + let c' = subst_glob_constr subst c in + if p' == p && c' == c then raw + else GProj (loc,p',c') + | GLambda (loc,n,bk,r1,r2) -> let r1' = subst_glob_constr subst r1 and r2' = subst_glob_constr subst r2 in if r1' == r1 && r2' == r2 then raw else @@ -635,7 +652,7 @@ let rec subst_glob_constr subst raw = let (n,topt) = x in let topt' = Option.smartmap (fun (loc,(sp,i),y as t) -> - let sp' = subst_ind subst sp in + let sp' = subst_mind subst sp in if sp == sp' then t else (loc,(sp',i),y)) topt in if a == a' && topt == topt' then y else (a',(n,topt'))) rl and branches' = List.smartmap diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index a0542cbb2..594481af3 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -27,41 +27,52 @@ let debug_unification = ref (false) let _ = Goptions.declare_bool_option { Goptions.optsync = true; Goptions.optdepr = false; Goptions.optname = - "Print states sended to Evarconv unification"; + "Print states sent to Evarconv unification"; Goptions.optkey = ["Debug";"Unification"]; Goptions.optread = (fun () -> !debug_unification); Goptions.optwrite = (fun a -> debug_unification:=a); } -let eval_flexible_term ts env c = +let unfold_projection env p c stk = + (match try Some (lookup_projection p env) with Not_found -> None with + | Some pb -> + let s = Stack.Proj (pb.Declarations.proj_npars, pb.Declarations.proj_arg, p) in + Some (c, s :: stk) + | None -> None) + +let eval_flexible_term ts env c stk = match kind_of_term c with - | Const c -> + | Const (c,u as cu) -> if is_transparent_constant ts c - then constant_opt_value env c + then Option.map (fun x -> x, stk) (constant_opt_value_in env cu) else None | Rel n -> - (try let (_,v,_) = lookup_rel n env in Option.map (lift n) v + (try let (_,v,_) = lookup_rel n env in Option.map (fun t -> lift n t, stk) v with Not_found -> None) | Var id -> (try if is_transparent_variable ts id then - let (_,v,_) = lookup_named id env in v + let (_,v,_) = lookup_named id env in Option.map (fun t -> t, stk) v else None with Not_found -> None) - | LetIn (_,b,_,c) -> Some (subst1 b c) - | Lambda _ -> Some c + | LetIn (_,b,_,c) -> Some (subst1 b c, stk) + | Lambda _ -> Some (c, stk) + | Proj (p, c) -> + if is_transparent_constant ts p + then unfold_projection env p c stk + else None | _ -> assert false type flex_kind_of_term = | Rigid - | MaybeFlexible of Constr.t (* reducible but not necessarily reduced *) + | MaybeFlexible of Constr.t * Constr.t Stack.t (* reducible but not necessarily reduced *) | Flexible of existential let flex_kind_of_term ts env c sk = match kind_of_term c with - | LetIn _ | Rel _ | Const _ | Var _ -> - Option.cata (fun x -> MaybeFlexible x) Rigid (eval_flexible_term ts env c) - | Lambda _ when not (Option.is_empty (Stack.decomp sk)) -> MaybeFlexible c + | LetIn _ | Rel _ | Const _ | Var _ | Proj _ -> + Option.cata (fun (x,y) -> MaybeFlexible (x,y)) Rigid (eval_flexible_term ts env c sk) + | Lambda _ when not (Option.is_empty (Stack.decomp sk)) -> MaybeFlexible (c, sk) | Evar ev -> Flexible ev | Lambda _ | Prod _ | Sort _ | Ind _ | Construct _ | CoFix _ -> Rigid | Meta _ -> Rigid @@ -100,36 +111,43 @@ let position_problem l2r = function projection would have been reduced) *) let check_conv_record (t1,sk1) (t2,sk2) = - let proji = global_of_constr t1 in - let canon_s,sk2_effective = - try - match kind_of_term t2 with - Prod (_,a,b) -> (* assert (l2=[]); *) + let (proji, u), arg = Universes.global_app_of_constr t1 in + let canon_s,sk2_effective = + try + match kind_of_term t2 with + Prod (_,a,b) -> (* assert (l2=[]); *) if dependent (mkRel 1) b then raise Not_found else lookup_canonical_conversion (proji, Prod_cs),(Stack.append_app [|a;pop b|] Stack.empty) - | Sort s -> - lookup_canonical_conversion - (proji, Sort_cs (family_of_sort s)),[] - | _ -> - let c2 = global_of_constr t2 in - lookup_canonical_conversion (proji, Const_cs c2),sk2 - with Not_found -> - lookup_canonical_conversion (proji,Default_cs),[] - in - let { o_DEF = c; o_INJ=n; o_TABS = bs; - o_TPARAMS = params; o_NPARAMS = nparams; o_TCOMPS = us } = canon_s in - let params1, c1, extra_args1 = + | Sort s -> + lookup_canonical_conversion + (proji, Sort_cs (family_of_sort s)),[] + | _ -> + let c2 = global_of_constr t2 in + lookup_canonical_conversion (proji, Const_cs c2),sk2 + with Not_found -> + lookup_canonical_conversion (proji,Default_cs),[] + in + let { o_DEF = c; o_CTX = ctx; o_INJ=n; o_TABS = bs; + o_TPARAMS = params; o_NPARAMS = nparams; o_TCOMPS = us } = canon_s in + let params1, c1, extra_args1 = + match arg with + | Some c -> (* A primitive projection applied to c *) + [], c, sk1 + | None -> match Stack.strip_n_app nparams sk1 with | Some (params1, c1,extra_args1) -> params1, c1, extra_args1 | _ -> raise Not_found in - let us2,extra_args2 = - let l_us = List.length us in + let us2,extra_args2 = + let l_us = List.length us in if Int.equal l_us 0 then Stack.empty,sk2_effective else match (Stack.strip_n_app (l_us-1) sk2_effective) with - | None -> raise Not_found - | Some (l',el,s') -> (l'@Stack.append_app [|el|] Stack.empty,s') in - (c,bs,(Stack.append_app_list params Stack.empty,params1),(Stack.append_app_list us Stack.empty,us2),(extra_args1,extra_args2),c1, - (n,Stack.zip(t2,sk2))) + | None -> raise Not_found + | Some (l',el,s') -> (l'@Stack.append_app [|el|] Stack.empty,s') in + let subst, ctx' = Universes.fresh_universe_context_set_instance ctx in + let c' = subst_univs_level_constr subst c in + let bs' = List.map (subst_univs_level_constr subst) bs in + ctx',c',bs',(Stack.append_app_list params Stack.empty,params1),(Stack.append_app_list us Stack.empty,us2),(extra_args1,extra_args2),c1, + (n,Stack.zip(t2,sk2)) (* Precondition: one of the terms of the pb is an uninstantiated evar, * possibly applied to arguments. *) @@ -206,6 +224,9 @@ let ise_stack2 no_app env evd f sk1 sk2 = | Success i'' -> ise_stack2 true i'' q1 q2 | UnifFailure _ as x -> fail x) | UnifFailure _ as x -> fail x) + | Stack.Proj (n1,a1,p1)::q1, Stack.Proj (n2,a2,p2)::q2 -> + if eq_constant p1 p2 then ise_stack2 true i q1 q2 + else fail (UnifFailure (i, NotSameHead)) | Stack.Fix (((li1, i1),(_,tys1,bds1 as recdef1)),a1,_)::q1, Stack.Fix (((li2, i2),(_,tys2,bds2)),a2,_)::q2 -> if Int.equal i1 i2 && Array.equal Int.equal li1 li2 then @@ -259,6 +280,13 @@ let exact_ise_stack2 env evd f sk1 sk2 = ise_stack2 evd (List.rev sk1) (List.rev sk2) else UnifFailure (evd, (* Dummy *) NotSameHead) +let eq_puniverses evd pbty f (x,u) (y,v) = + if f x y then + try + Success (Evd.set_eq_instances evd u v) + with Univ.UniverseInconsistency e -> UnifFailure (evd, UnifUnivInconsistency e) + else UnifFailure (evd, NotSameHead) + let rec evar_conv_x ts env evd pbty term1 term2 = let term1 = whd_head_evar evd term1 in let term2 = whd_head_evar evd term2 in @@ -266,15 +294,19 @@ let rec evar_conv_x ts env evd pbty term1 term2 = could have found, we do it only if the terms are free of evar. Note: incomplete heuristic... *) let ground_test = - if is_ground_term evd term1 && is_ground_term evd term2 then - if is_trans_fconv pbty ts env evd term1 term2 then - Some true - else if is_ground_env evd env then Some false - else None - else None in + if is_ground_term evd term1 && is_ground_term evd term2 then ( + let evd, b = + try infer_conv ~pb:pbty ~ts env evd term1 term2 + with Univ.UniverseInconsistency _ -> evd, false + in + if b then Some (evd, true) + else if is_ground_env evd env then Some (evd, false) + else None) + else None + in match ground_test with - | Some true -> Success evd - | Some false -> UnifFailure (evd,ConversionFailed (env,term1,term2)) + | Some (evd, true) -> Success evd + | Some (evd, false) -> UnifFailure (evd,ConversionFailed (env,term1,term2)) | None -> (* Until pattern-unification is used consistently, use nohdbeta to not destroy beta-redexes that can be used for 1st-order unification *) @@ -392,11 +424,13 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty in ise_try evd [f1; f2] - | Flexible ev1, MaybeFlexible v2 -> flex_maybeflex true ev1 (appr1,csts1) (appr2,csts2) v2 + | Flexible ev1, MaybeFlexible (v2,sk2) -> + flex_maybeflex true ev1 (appr1,csts1) ((term2,sk2),csts2) v2 - | MaybeFlexible v1, Flexible ev2 -> flex_maybeflex false ev2 (appr2,csts2) (appr1,csts1) v1 + | MaybeFlexible (v1,sk1), Flexible ev2 -> + flex_maybeflex false ev2 (appr2,csts2) ((term1,sk1),csts1) v1 - | MaybeFlexible v1, MaybeFlexible v2 -> begin + | MaybeFlexible (v1,sk1), MaybeFlexible (v2,sk2) -> begin match kind_of_term term1, kind_of_term term2 with | LetIn (na,b1,t1,c'1), LetIn (_,b2,_,c'2) -> let f1 i = @@ -414,12 +448,37 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty in ise_try evd [f1; f2] + | Proj (p, c), Proj (p', c') when eq_constant p p' -> + let f1 i = + ise_and i + [(fun i -> evar_conv_x ts env i CONV c c'); + (fun i -> exact_ise_stack2 env i (evar_conv_x ts) sk1 sk2)] + and f2 i = + if is_transparent_constant ts p then + match unfold_projection env p c sk1 with + | Some (c, sk1) -> + let out1 = whd_betaiota_deltazeta_for_iota_state ts env i csts1 (c,sk1) in + evar_eqappr_x ts env i pbty out1 (appr2, csts2) + | None -> assert false + else UnifFailure (i, NotSameHead) + in + ise_try evd [f1; f2] + | _, _ -> - let f1 i = - if eq_constr term1 term2 then - exact_ise_stack2 env i (evar_conv_x ts) sk1 sk2 - else - UnifFailure (i,NotSameHead) + let f1 i = + (* Gather the universe constraints that would make term1 and term2 equal. + If these only involve unifications of flexible universes to other universes, + allow this identification (first-order unification of universes). Otherwise + fallback to unfolding. + *) + let b,univs = eq_constr_universes term1 term2 in + if b then + ise_and i [(fun i -> + try Success (Evd.add_universe_constraints i univs) + with UniversesDiffer -> UnifFailure (i,NotSameHead) + | Univ.UniverseInconsistency p -> UnifFailure (i, UnifUnivInconsistency p)); + (fun i -> exact_ise_stack2 env i (evar_conv_x ts) sk1 sk2)] + else UnifFailure (i,NotSameHead) and f2 i = (try conv_record ts env i (try check_conv_record appr1 appr2 @@ -438,9 +497,11 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty (* false (* immediate solution without Canon Struct *)*) | Lambda _ -> assert (match args with [] -> true | _ -> false); true | LetIn (_,b,_,c) -> is_unnamed - (fst (whd_betaiota_deltazeta_for_iota_state + (fst (whd_betaiota_deltazeta_for_iota_state ts env i Cst_stack.empty (subst1 b c, args))) - | Case _| Fix _| App _| Cast _ -> assert false in + | Fix _ -> true (* Partially applied fix can be the result of a whd call *) + | Proj (p, c) -> true + | Case _ | App _| Cast _ -> assert false in let rhs_is_stuck_and_unnamed () = let applicative_stack = fst (Stack.strip_app sk2) in is_unnamed @@ -475,7 +536,7 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty | Flexible ev1, Rigid -> flex_rigid true ev1 appr1 appr2 | Rigid, Flexible ev2 -> flex_rigid false ev2 appr2 appr1 - | MaybeFlexible v1, Rigid -> + | MaybeFlexible (v1,sk1), Rigid -> let f3 i = (try conv_record ts env i (check_conv_record appr1 appr2) with Not_found -> UnifFailure (i,NoCanonicalStructure)) @@ -487,14 +548,14 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty in ise_try evd [f3; f4] - | Rigid, MaybeFlexible v2 -> + | Rigid, MaybeFlexible (v2,sk2) -> let f3 i = (try conv_record ts env i (check_conv_record appr2 appr1) with Not_found -> UnifFailure (i,NoCanonicalStructure)) and f4 i = - evar_eqappr_x ts env i pbty (appr1,csts1) - (whd_betaiota_deltazeta_for_iota_state - ts env i (Cst_stack.add_cst term2 csts2) (v2,sk2)) + evar_eqappr_x ts env i pbty (appr1,csts1) + (whd_betaiota_deltazeta_for_iota_state + ts env i (Cst_stack.add_cst term2 csts2) (v2,sk2)) in ise_try evd [f3; f4] @@ -515,8 +576,8 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty then Evd.set_eq_sort evd s1 s2 else Evd.set_leq_sort evd s1 s2 in Success evd' - with Univ.UniverseInconsistency _ -> - UnifFailure (evd,UnifUnivInconsistency) + with Univ.UniverseInconsistency p -> + UnifFailure (evd,UnifUnivInconsistency p) | e when Errors.noncritical e -> UnifFailure (evd,NotSameHead)) | Prod (n,c1,c'1), Prod (_,c2,c'2) when app_empty -> @@ -537,19 +598,19 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty else UnifFailure (evd,NotSameHead) | Const c1, Const c2 -> - if eq_constant c1 c2 then - exact_ise_stack2 env evd (evar_conv_x ts) sk1 sk2 - else UnifFailure (evd,NotSameHead) + ise_and evd + [(fun i -> eq_puniverses i pbty eq_constant c1 c2); + (fun i -> exact_ise_stack2 env i (evar_conv_x ts) sk1 sk2)] | Ind sp1, Ind sp2 -> - if eq_ind sp1 sp2 then - exact_ise_stack2 env evd (evar_conv_x ts) sk1 sk2 - else UnifFailure (evd,NotSameHead) + ise_and evd + [(fun i -> eq_puniverses i pbty eq_ind sp1 sp2); + (fun i -> exact_ise_stack2 env i (evar_conv_x ts) sk1 sk2)] | Construct sp1, Construct sp2 -> - if eq_constructor sp1 sp2 then - exact_ise_stack2 env evd (evar_conv_x ts) sk1 sk2 - else UnifFailure (evd,NotSameHead) + ise_and evd + [(fun i -> eq_puniverses i pbty eq_constructor sp1 sp2); + (fun i -> exact_ise_stack2 env i (evar_conv_x ts) sk1 sk2)] | Fix ((li1, i1),(_,tys1,bds1 as recdef1)), Fix ((li2, i2),(_,tys2,bds2)) -> (* Partially applied fixs *) if Int.equal i1 i2 && Array.equal Int.equal li1 li2 then @@ -583,13 +644,14 @@ and evar_eqappr_x ?(rhs_is_already_stuck = false) ts env evd pbty | _, (Ind _ | Construct _ | Sort _ | Prod _ | CoFix _ | Fix _ | Rel _ | Var _ | Const _) -> UnifFailure (evd,NotSameHead) - | (App _ | Cast _ | Case _), _ -> assert false + | (App _ | Cast _ | Case _ | Proj _), _ -> assert false | (LetIn _| Evar _), _ -> assert false | (Lambda _), _ -> assert false end -and conv_record trs env evd (c,bs,(params,params1),(us,us2),(ts,ts1),c1,(n,t2)) = +and conv_record trs env evd (ctx,c,bs,(params,params1),(us,us2),(ts,ts1),c1,(n,t2)) = + let evd = Evd.merge_context_set Evd.univ_flexible evd ctx in if Reductionops.Stack.compare_shape ts ts1 then let (evd',ks,_) = List.fold_left @@ -614,6 +676,28 @@ and conv_record trs env evd (c,bs,(params,params1),(us,us2),(ts,ts1),c1,(n,t2)) (fun i -> exact_ise_stack2 env i (evar_conv_x trs) ts ts1)] else UnifFailure(evd,(*dummy*)NotSameHead) +and eta_constructor ts env evd ((ind, i), u) l1 csts1 (c, csts2) = + let mib = lookup_mind (fst ind) env in + match mib.Declarations.mind_record with + | Some (exp,projs) when Array.length projs > 0 -> + let pars = mib.Declarations.mind_nparams in + (try + let l1' = Stack.tail pars l1 in + if Environ.is_projection projs.(0) env then + let sk2 = + let term = Stack.zip c in + List.map (fun p -> mkProj (p, term)) (Array.to_list projs) + in + exact_ise_stack2 env evd (evar_conv_x ts) l1' + (Stack.append_app_list sk2 Stack.empty) + else raise (Failure "") + with Failure _ -> UnifFailure(evd,NotSameHead)) + | _ -> UnifFailure (evd,NotSameHead) + +(* Profiling *) +(* let evar_conv_xkey = Profile.declare_profile "evar_conv_x";; *) +(* let evar_conv_x = Profile.profile6 evar_conv_xkey evar_conv_x *) + (* We assume here |l1| <= |l2| *) let first_order_unification ts env evd (ev1,l1) (term2,l2) = @@ -846,7 +930,7 @@ let apply_conversion_problem_heuristic ts env evd pbty t1 t2 = (* Some head evar have been instantiated, or unknown kind of problem *) evar_conv_x ts env evd pbty t1 t2 -let check_problems_are_solved evd = +let check_problems_are_solved env evd = match snd (extract_all_conv_pbs evd) with | (pbty,env,t1,t2)::_ -> Pretype_errors.error_cannot_unify env evd (t1, t2) | _ -> () @@ -890,10 +974,16 @@ let rec solve_unconstrained_evars_with_canditates ts evd = let evd = aux (List.rev l) in solve_unconstrained_evars_with_canditates ts evd -let solve_unconstrained_impossible_cases evd = +let solve_unconstrained_impossible_cases env evd = Evd.fold_undefined (fun evk ev_info evd' -> match ev_info.evar_source with - | _,Evar_kinds.ImpossibleCase -> Evd.define evk (j_type (coq_unit_judge ())) evd' + | _,Evar_kinds.ImpossibleCase -> + let j, ctx = coq_unit_judge () in + let evd' = Evd.merge_context_set Evd.univ_flexible_alg evd' ctx in + let ty = j_type j in + let conv_algo = evar_conv_x full_transparent_state in + let evd' = check_evar_instance evd' evk ty conv_algo in + Evd.define evk ty evd' | _ -> evd') evd evd let consider_remaining_unif_problems env @@ -925,8 +1015,8 @@ let consider_remaining_unif_problems env in let (evd,pbs) = extract_all_conv_pbs evd in let heuristic_solved_evd = aux evd pbs false [] in - check_problems_are_solved heuristic_solved_evd; - solve_unconstrained_impossible_cases heuristic_solved_evd + check_problems_are_solved env heuristic_solved_evd; + solve_unconstrained_impossible_cases env heuristic_solved_evd (* Main entry points *) diff --git a/pretyping/evarconv.mli b/pretyping/evarconv.mli index 3eb01439e..c99929b5e 100644 --- a/pretyping/evarconv.mli +++ b/pretyping/evarconv.mli @@ -38,12 +38,12 @@ val consider_remaining_unif_problems : env -> ?ts:transparent_state -> evar_map (** Check all pending unification problems are solved and raise an error otherwise *) -val check_problems_are_solved : evar_map -> unit +val check_problems_are_solved : env -> evar_map -> unit (** Check if a canonical structure is applicable *) val check_conv_record : constr * types Stack.t -> constr * types Stack.t -> - constr * constr list * (constr Stack.t * constr Stack.t) * + Univ.universe_context_set * constr * constr list * (constr Stack.t * constr Stack.t) * (constr Stack.t * types Stack.t) * (constr Stack.t * types Stack.t) * constr * (int * constr) diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index 4f982114a..b3c65ebaf 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -26,6 +26,24 @@ let normalize_evar evd ev = | Evar (evk,args) -> (evk,args) | _ -> assert false +let refresh_universes dir evd t = + let evdref = ref evd in + let modified = ref false in + let rec refresh t = match kind_of_term t with + | Sort (Type u as s) when Univ.universe_level u = None || + Evd.is_sort_variable evd s = None -> + (modified := true; + (* s' will appear in the term, it can't be algebraic *) + let s' = evd_comb0 (new_sort_variable Evd.univ_flexible) evdref in + evdref := + (if dir then set_leq_sort !evdref s' s else + set_leq_sort !evdref s s'); + mkSort s') + | Prod (na,u,v) -> mkProd (na,u,refresh v) + | _ -> t in + let t' = refresh t in + if !modified then !evdref, t' else evd, t + (************************) (* Unification results *) (************************) @@ -416,8 +434,8 @@ let make_projectable_subst aliases sigma evi args = let a',args = decompose_app_vect a in match kind_of_term a' with | Construct cstr -> - let l = try Constrmap.find cstr cstrs with Not_found -> [] in - Constrmap.add cstr ((args,id)::l) cstrs + let l = try Constrmap.find (fst cstr) cstrs with Not_found -> [] in + Constrmap.add (fst cstr) ((args,id)::l) cstrs | _ -> cstrs in (rest,Id.Map.add id [a,normalize_alias_opt aliases a,id] all,cstrs) | Some c, a::rest -> @@ -450,6 +468,7 @@ let make_projectable_subst aliases sigma evi args = let define_evar_from_virtual_equation define_fun env evd t_in_env sign filter inst_in_env = let ty_t_in_env = Retyping.get_type_of env evd t_in_env in + let evd,ty_t_in_env = refresh_universes false evd ty_t_in_env in let evd,evar_in_env = new_evar_instance sign evd ty_t_in_env ~filter inst_in_env in let t_in_env = whd_evar evd t_in_env in let evd = define_fun env evd None (destEvar evar_in_env) t_in_env in @@ -955,7 +974,7 @@ exception CannotProject of Filter.t option let rec is_constrainable_in k (ev,(fv_rels,fv_ids) as g) t = let f,args = decompose_app_vect t in match kind_of_term f with - | Construct (ind,_) -> + | Construct ((ind,_),u) -> let n = Inductiveops.inductive_nparams ind in if n > Array.length args then true (* We don't try to be more clever *) else @@ -1012,10 +1031,26 @@ let project_evar_on_evar g env evd aliases k2 (evk1,argsv1 as ev1) (evk2,argsv2 else raise (CannotProject filter1) +exception IllTypedInstance of env * types * types + +let check_evar_instance evd evk1 body conv_algo = + let evi = Evd.find evd evk1 in + let evenv = evar_env evi in + (* FIXME: The body might be ill-typed when this is called from w_merge *) + (* This happens in practice, cf MathClasses build failure on 2013-3-15 *) + let ty = + try Retyping.get_type_of ~lax:true evenv evd body + with Retyping.RetypeError _ -> error "Ill-typed evar instance" + in + match conv_algo evenv evd Reduction.CUMUL ty evi.evar_concl with + | Success evd -> evd + | UnifFailure _ -> raise (IllTypedInstance (evenv,ty,evi.evar_concl)) + let solve_evar_evar_l2r f g env evd aliases pbty ev1 (evk2,_ as ev2) = try let evd,body = project_evar_on_evar g env evd aliases 0 ev1 ev2 in - Evd.define evk2 body evd + let evd' = Evd.define evk2 body evd in + check_evar_instance evd' evk2 body g with EvarSolvedOnTheFly (evd,c) -> f env evd pbty ev2 c @@ -1037,27 +1072,39 @@ let solve_evar_evar ?(force=false) f g env evd pbty (evk1,args1 as ev1) (evk2,ar with CannotProject filter2 -> postpone_evar_evar f env evd pbty filter1 ev1 filter2 ev2 +let solve_evar_evar ?(force=false) f g env evd pbty (evk1,args1 as ev1) (evk2,args2 as ev2) = + let evi = Evd.find evd evk1 in + try + (* ?X : ΠΔ. Type i = ?Y : ΠΔ'. Type j. + The body of ?X and ?Y just has to be of type ΠΔ. Type k for some k <= i, j. *) + let evienv = Evd.evar_env evi in + let ctx, i = Reduction.dest_arity evienv evi.evar_concl in + let evi2 = Evd.find evd evk2 in + let evi2env = Evd.evar_env evi2 in + let ctx', j = Reduction.dest_arity evi2env evi2.evar_concl in + if i == j || Evd.check_eq evd (univ_of_sort i) (univ_of_sort j) + then (* Shortcut, i = j *) + solve_evar_evar ~force f g env evd pbty ev1 ev2 + else + let evd, k = Evd.new_sort_variable univ_flexible_alg evd in + let evd, ev3 = + Evarutil.new_pure_evar evd (Evd.evar_hyps evi) + ~src:evi.evar_source ~filter:evi.evar_filter + ?candidates:evi.evar_candidates (it_mkProd_or_LetIn (mkSort k) ctx) + in + let evd = Evd.set_leq_sort (Evd.set_leq_sort evd k i) k j in + solve_evar_evar ~force f g env + (solve_evar_evar ~force f g env evd None (ev3,args1) ev1) + pbty (ev3,args1) ev2 + with Reduction.NotArity -> + solve_evar_evar ~force f g env evd None ev1 ev2 + type conv_fun = env -> evar_map -> conv_pb -> constr -> constr -> unification_result type conv_fun_bool = env -> evar_map -> conv_pb -> constr -> constr -> bool -exception IllTypedInstance of env * types * types - -let check_evar_instance evd evk1 body conv_algo = - let evi = Evd.find evd evk1 in - let evenv = evar_env evi in - (* FIXME: The body might be ill-typed when this is called from w_merge *) - (* This happens in practice, cf MathClasses build failure on 2013-3-15 *) - let ty = - try Retyping.get_type_of ~lax:true evenv evd body - with Retyping.RetypeError _ -> error "Ill-typed evar instance" - in - match conv_algo evenv evd Reduction.CUMUL ty evi.evar_concl with - | Success evd -> evd - | UnifFailure _ -> raise (IllTypedInstance (evenv,ty,evi.evar_concl)) - (* Solve pbs ?e[t1..tn] = ?e[u1..un] which arise often in fixpoint * definitions. We try to unify the ti with the ui pairwise. The pairs * that don't unify are discarded (i.e. ?e is redefined so that it does not @@ -1137,6 +1184,9 @@ exception NotEnoughInformationEvarEvar of constr exception OccurCheckIn of evar_map * constr exception MetaOccurInBodyInternal +let fast_stats = ref 0 +let not_fast_stats = ref 0 + let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = let aliases = make_alias_map env in let evdref = ref evd in @@ -1224,7 +1274,8 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = (* Try to project (a restriction of) the left evar ... *) try let evd,body = project_evar_on_evar conv_algo env' evd aliases 0 ev'' ev' in - Evd.define evk' body evd + let evd = Evd.define evk' body evd in + check_evar_instance evd evk' body conv_algo with | EvarSolvedOnTheFly _ -> assert false (* ev has no candidates *) | CannotProject filter'' -> @@ -1237,7 +1288,7 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = match let c,args = decompose_app_vect t in match kind_of_term c with - | Construct cstr when noccur_between 1 k t -> + | Construct (cstr,u) when noccur_between 1 k t -> (* This is common case when inferring the return clause of match *) (* (currently rudimentary: we do not treat the case of multiple *) (* possible inversions; we do not treat overlap with a possible *) @@ -1268,6 +1319,19 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = map_constr_with_full_binders (fun d (env,k) -> push_rel d env, k+1) imitate envk t in + let _fast rhs = + let filter_ctxt = evar_filtered_context evi in + let names = ref Idset.empty in + let rec is_id_subst ctxt s = + match ctxt, s with + | ((id, _, _) :: ctxt'), (c :: s') -> + names := Idset.add id !names; + isVarId id c && is_id_subst ctxt' s' + | [], [] -> true + | _ -> false in + is_id_subst filter_ctxt (Array.to_list argsv) && + closed0 rhs && + Idset.subset (collect_vars rhs) !names in let rhs = whd_beta evd rhs (* heuristic *) in let fast rhs = let filter_ctxt = evar_filtered_context evi in @@ -1296,7 +1360,7 @@ let rec invert_definition conv_algo choose env evd pbty (evk,argsv as ev) rhs = * context "hyps" and not referring to itself. *) -and evar_define conv_algo ?(choose=false) env evd pbty (evk,argsv as ev) rhs = +and evar_define conv_algo ?(choose=false) ?(dir=false) env evd pbty (evk,argsv as ev) rhs = match kind_of_term rhs with | Evar (evk2,argsv2 as ev2) -> if Evar.equal evk evk2 then @@ -1315,7 +1379,7 @@ and evar_define conv_algo ?(choose=false) env evd pbty (evk,argsv as ev) rhs = (* so we recheck acyclicity *) if occur_evar evk body then raise (OccurCheckIn (evd',body)); (* needed only if an inferred type *) - let body = refresh_universes body in + let evd', body = refresh_universes dir evd' body in (* Cannot strictly type instantiations since the unification algorithm * does not unify applications from left to right. * e.g problem f x == g y yields x==y and f==g (in that order) @@ -1399,8 +1463,9 @@ let reconsider_conv_pbs conv_algo evd = let solve_simple_eqn conv_algo ?(choose=false) env evd (pbty,(evk1,args1 as ev1),t2) = try let t2 = whd_betaiota evd t2 in (* includes whd_evar *) - let evd = evar_define conv_algo ~choose env evd pbty ev1 t2 in - reconsider_conv_pbs conv_algo evd + let dir = match pbty with Some d -> d | None -> false in + let evd = evar_define conv_algo ~choose ~dir env evd pbty ev1 t2 in + reconsider_conv_pbs conv_algo evd with | NotInvertibleUsingOurAlgorithm t -> UnifFailure (evd,NotClean (ev1,t)) diff --git a/pretyping/evarsolve.mli b/pretyping/evarsolve.mli index 5d0063c47..7276669bf 100644 --- a/pretyping/evarsolve.mli +++ b/pretyping/evarsolve.mli @@ -31,9 +31,11 @@ type conv_fun = type conv_fun_bool = env -> evar_map -> conv_pb -> constr -> constr -> bool -val evar_define : conv_fun -> ?choose:bool -> env -> evar_map -> +val evar_define : conv_fun -> ?choose:bool -> ?dir:bool -> env -> evar_map -> bool option -> existential -> constr -> evar_map +val refresh_universes : bool -> evar_map -> types -> evar_map * types + val solve_refl : ?can_drop:bool -> conv_fun_bool -> env -> evar_map -> bool option -> existential_key -> constr array -> constr array -> evar_map diff --git a/pretyping/evarutil.ml b/pretyping/evarutil.ml index 1605ef7cf..908e59227 100644 --- a/pretyping/evarutil.ml +++ b/pretyping/evarutil.ml @@ -21,6 +21,27 @@ open Evd open Reductionops open Pretype_errors +let evd_comb0 f evdref = + let (evd',x) = f !evdref in + evdref := evd'; + x + +let evd_comb1 f evdref x = + let (evd',y) = f !evdref x in + evdref := evd'; + y + +let evd_comb2 f evdref x y = + let (evd',z) = f !evdref x y in + evdref := evd'; + z + +let e_new_global evdref x = + evd_comb1 (Evd.fresh_global (Global.env())) evdref x + +let new_global evd x = + Evd.fresh_global (Global.env()) evd x + (****************************************************) (* Expanding/testing/exposing existential variables *) (****************************************************) @@ -37,6 +58,8 @@ let rec flush_and_check_evars sigma c = | Some c -> flush_and_check_evars sigma c) | _ -> map_constr (flush_and_check_evars sigma) c +(* let nf_evar_key = Profile.declare_profile "nf_evar" *) +(* let nf_evar = Profile.profile2 nf_evar_key Reductionops.nf_evar *) let nf_evar = Reductionops.nf_evar let j_nf_evar sigma j = { uj_val = nf_evar sigma j.uj_val; @@ -60,24 +83,38 @@ let env_nf_betaiotaevar sigma env = (fun d e -> push_rel (map_rel_declaration (Reductionops.nf_betaiota sigma) d) e) env +let nf_evars_universes evm = + Universes.nf_evars_and_universes_opt_subst (Reductionops.safe_evar_value evm) + (Evd.universe_subst evm) + +let nf_evars_and_universes evm = + let evm = Evd.nf_constraints evm in + evm, nf_evars_universes evm + +let e_nf_evars_and_universes evdref = + evdref := Evd.nf_constraints !evdref; + nf_evars_universes !evdref, Evd.universe_subst !evdref + +let nf_evar_map_universes evm = + let evm = Evd.nf_constraints evm in + let subst = Evd.universe_subst evm in + if Univ.LMap.is_empty subst then evm, nf_evar evm + else + let f = nf_evars_universes evm in + Evd.raw_map (fun _ -> map_evar_info f) evm, f + let nf_named_context_evar sigma ctx = - Context.map_named_context (Reductionops.nf_evar sigma) ctx + Context.map_named_context (nf_evar sigma) ctx let nf_rel_context_evar sigma ctx = - Context.map_rel_context (Reductionops.nf_evar sigma) ctx + Context.map_rel_context (nf_evar sigma) ctx let nf_env_evar sigma env = let nc' = nf_named_context_evar sigma (Environ.named_context env) in let rel' = nf_rel_context_evar sigma (Environ.rel_context env) in push_rel_context rel' (reset_with_named_context (val_of_named_context nc') env) -let nf_evar_info evc info = - { info with - evar_concl = Reductionops.nf_evar evc info.evar_concl; - evar_hyps = map_named_val (Reductionops.nf_evar evc) info.evar_hyps; - evar_body = match info.evar_body with - | Evar_empty -> Evar_empty - | Evar_defined c -> Evar_defined (Reductionops.nf_evar evc c) } +let nf_evar_info evc info = map_evar_info (nf_evar evc) info let nf_evar_map evm = Evd.raw_map (fun _ evi -> nf_evar_info evm evi) evm @@ -89,7 +126,7 @@ let nf_evar_map_undefined evm = (* Auxiliary functions for the conversion algorithms modulo evars *) -let has_undefined_evars_or_sorts evd t = +let has_undefined_evars or_sorts evd t = let rec has_ev t = match kind_of_term t with | Evar (ev,args) -> @@ -98,13 +135,16 @@ let has_undefined_evars_or_sorts evd t = has_ev c; Array.iter has_ev args | Evar_empty -> raise NotInstantiatedEvar) - | Sort s when is_sort_variable evd s -> raise Not_found + | Sort (Type _) (*FIXME could be finer, excluding Prop and Set universes *) when or_sorts -> + raise Not_found + | Ind (_,l) | Const (_,l) | Construct (_,l) + when l <> Univ.Instance.empty && or_sorts -> raise Not_found | _ -> iter_constr has_ev t in try let _ = has_ev t in false with (Not_found | NotInstantiatedEvar) -> true let is_ground_term evd t = - not (has_undefined_evars_or_sorts evd t) + not (has_undefined_evars true evd t) let is_ground_env evd env = let is_ground_decl = function @@ -333,9 +373,21 @@ let new_evar evd env ?src ?filter ?candidates typ = | Some filter -> Filter.filter_list filter instance in new_evar_instance sign evd typ' ?src ?filter ?candidates instance -let new_type_evar ?src ?filter evd env = - let evd', s = new_sort_variable evd in - new_evar evd' env ?src ?filter (mkSort s) +let new_type_evar ?src ?filter rigid evd env = + let evd', s = new_sort_variable rigid evd in + let evd', e = new_evar evd' env ?src ?filter (mkSort s) in + evd', (e, s) + + (* The same using side-effect *) +let e_new_evar evdref env ?(src=(Loc.ghost,Evar_kinds.InternalHole)) ?filter ?candidates ty = + let (evd',ev) = new_evar !evdref env ~src:src ?filter ?candidates ty in + evdref := evd'; + ev + +let e_new_type_evar evdref ?src ?filter rigid env = + let evd', c = new_type_evar ?src ?filter rigid !evdref env in + evdref := evd'; + c (* The same using side-effect *) let e_new_evar evdref env ?(src=default_source) ?filter ?candidates ty = @@ -470,7 +522,6 @@ let clear_hyps_in_evi evdref hyps concl ids = in (nhyps,nconcl) - (** The following functions return the set of evars immediately contained in the object, including defined evars *) @@ -597,6 +648,7 @@ let check_evars env initial_sigma sigma c = | _ -> iter_constr proc_rec c in proc_rec c + (****************************************) (* Operations on value/type constraints *) (****************************************) @@ -639,15 +691,25 @@ let define_pure_evar_as_product evd evk = let evi = Evd.find_undefined evd evk in let evenv = evar_env evi in let id = next_ident_away idx (ids_of_named_context (evar_context evi)) in - let evd1,dom = new_type_evar evd evenv ~filter:(evar_filter evi) in + let s = destSort evi.evar_concl in + let evd1,(dom,u1) = new_type_evar univ_flexible_alg evd evenv ~filter:(evar_filter evi) in let evd2,rng = let newenv = push_named (id, None, dom) evenv in let src = evar_source evk evd1 in let filter = Filter.extend 1 (evar_filter evi) in - new_type_evar evd1 newenv ~src ~filter in + if is_prop_sort s then + (* Impredicative product, conclusion must fall in [Prop]. *) + new_evar evd1 newenv evi.evar_concl ~src ~filter + else + let evd3, (rng, srng) = + new_type_evar univ_flexible_alg evd1 newenv ~src ~filter in + let prods = Univ.sup (univ_of_sort u1) (univ_of_sort srng) in + let evd3 = Evd.set_leq_sort evd3 (Type prods) s in + evd3, rng + in let prod = mkProd (Name id, dom, subst_var id rng) in let evd3 = Evd.define evk prod evd2 in - evd3,prod + evd3,prod (* Refine an applied evar to a product and returns its instantiation *) @@ -707,15 +769,18 @@ let rec evar_absorb_arguments env evd (evk,args as ev) = function (* Refining an evar to a sort *) let define_evar_as_sort evd (ev,args) = - let evd, s = new_sort_variable evd in - Evd.define ev (mkSort s) evd, s + let evd, u = new_univ_variable univ_rigid evd in + let evi = Evd.find_undefined evd ev in + let s = Type u in + let evd' = Evd.define ev (mkSort s) evd in + Evd.set_leq_sort evd' (Type (Univ.super u)) (destSort evi.evar_concl), s (* We don't try to guess in which sort the type should be defined, since any type has type Type. May cause some trouble, but not so far... *) let judge_of_new_Type evd = - let evd', s = new_univ_variable evd in - evd', Typeops.judge_of_type s + let evd', s = new_univ_variable univ_rigid evd in + evd', { uj_val = mkSort (Type s); uj_type = mkSort (Type (Univ.super s)) } (* Propagation of constraints through application and abstraction: Given a type constraint on a functional term, returns the type diff --git a/pretyping/evarutil.mli b/pretyping/evarutil.mli index f41f1ec86..b860ce337 100644 --- a/pretyping/evarutil.mli +++ b/pretyping/evarutil.mli @@ -39,7 +39,16 @@ val e_new_evar : (** Create a new Type existential variable, as we keep track of them during type-checking and unification. *) val new_type_evar : - ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> evar_map -> env -> evar_map * constr + ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> rigid -> evar_map -> env -> + evar_map * (constr * sorts) + +val e_new_type_evar : evar_map ref -> + ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> rigid -> env -> constr * sorts + +(** Polymorphic constants *) + +val new_global : evar_map -> Globnames.global_reference -> evar_map * constr +val e_new_global : evar_map ref -> Globnames.global_reference -> constr (** Create a fresh evar in a context different from its definition context: [new_evar_instance sign evd ty inst] creates a new evar of context @@ -65,6 +74,9 @@ val head_evar : constr -> existential_key (** may raise NoHeadEvar *) (* Expand head evar if any *) val whd_head_evar : evar_map -> constr -> constr +(* [has_undefined_evars or_sorts evd c] checks if [c] has undefined evars + and optionally if it contains undefined sorts. *) +val has_undefined_evars : bool -> evar_map -> constr -> bool val is_ground_term : evar_map -> constr -> bool val is_ground_env : evar_map -> env -> bool (** [check_evars env initial_sigma extended_sigma c] fails if some @@ -160,6 +172,15 @@ val jv_nf_betaiotaevar : evar_map -> unsafe_judgment array -> unsafe_judgment array (** Presenting terms without solved evars *) +val nf_evars_universes : evar_map -> constr -> constr + +val nf_evars_and_universes : evar_map -> evar_map * (constr -> constr) +val e_nf_evars_and_universes : evar_map ref -> (constr -> constr) * Universes.universe_opt_subst + +(** Normalize the evar map w.r.t. universes, after simplification of constraints. + Return the substitution function for constrs as well. *) +val nf_evar_map_universes : evar_map -> evar_map * (constr -> constr) + (** Replacing all evars, possibly raising [Uninstantiated_evar] *) exception Uninstantiated_evar of existential_key val flush_and_check_evars : evar_map -> constr -> constr @@ -189,3 +210,9 @@ val push_rel_context_to_named_context : Environ.env -> types -> named_context_val * types * constr list * constr list * (identifier*constr) list val generalize_evar_over_rels : evar_map -> existential -> types * constr list + +(** Evar combinators *) + +val evd_comb0 : (evar_map -> evar_map * 'a) -> evar_map ref -> 'a +val evd_comb1 : (evar_map -> 'b -> evar_map * 'a) -> evar_map ref -> 'b -> 'a +val evd_comb2 : (evar_map -> 'b -> 'c -> evar_map * 'a) -> evar_map ref -> 'b -> 'c -> 'a diff --git a/pretyping/evd.ml b/pretyping/evd.ml index 8fc6b8ab2..0776988d7 100644 --- a/pretyping/evd.ml +++ b/pretyping/evd.ml @@ -207,6 +207,18 @@ let eq_evar_info ei1 ei2 = eq_evar_body ei1.evar_body ei2.evar_body (** ppedrot: [eq_constr] may be a bit too permissive here *) + +let map_evar_body f = function + | Evar_empty -> Evar_empty + | Evar_defined d -> Evar_defined (f d) + +let map_evar_info f evi = + {evi with + evar_body = map_evar_body f evi.evar_body; + evar_hyps = map_named_val f evi.evar_hyps; + evar_concl = f evi.evar_concl; + evar_candidates = Option.map (List.map f) evi.evar_candidates } + (* spiwack: Revised hierarchy : - Evar.Map ( Maps of existential_keys ) - EvarInfoMap ( .t = evar_info Evar.Map.t * evar_info Evar.Map ) @@ -250,6 +262,202 @@ let instantiate_evar_array info c args = | [] -> c | _ -> replace_vars inst c +(* 2nd part used to check consistency on the fly. *) +type evar_universe_context = + { uctx_local : Univ.universe_context_set; (** The local context of variables *) + uctx_postponed : Univ.universe_constraints; + uctx_univ_variables : Universes.universe_opt_subst; + (** The local universes that are unification variables *) + uctx_univ_algebraic : Univ.universe_set; + (** The subset of unification variables that + can be instantiated with algebraic universes as they appear in types + and universe instances only. *) + uctx_universes : Univ.universes; (** The current graph extended with the local constraints *) + } + +let empty_evar_universe_context = + { uctx_local = Univ.ContextSet.empty; + uctx_postponed = Univ.UniverseConstraints.empty; + uctx_univ_variables = Univ.LMap.empty; + uctx_univ_algebraic = Univ.LSet.empty; + uctx_universes = Univ.initial_universes } + +let evar_universe_context_from e c = + {empty_evar_universe_context with + uctx_local = c; uctx_universes = universes e} + +let is_empty_evar_universe_context ctx = + Univ.ContextSet.is_empty ctx.uctx_local && + Univ.LMap.is_empty ctx.uctx_univ_variables + +let union_evar_universe_context ctx ctx' = + if ctx == ctx' then ctx + else if is_empty_evar_universe_context ctx then ctx' + else if is_empty_evar_universe_context ctx' then ctx + else + let local = + if ctx.uctx_local == ctx'.uctx_local then ctx.uctx_local + else Univ.ContextSet.union ctx.uctx_local ctx'.uctx_local + in + { uctx_local = local; + uctx_postponed = Univ.UniverseConstraints.union ctx.uctx_postponed ctx'.uctx_postponed; + uctx_univ_variables = + Univ.LMap.subst_union ctx.uctx_univ_variables ctx'.uctx_univ_variables; + uctx_univ_algebraic = + Univ.LSet.union ctx.uctx_univ_algebraic ctx'.uctx_univ_algebraic; + uctx_universes = + if local == ctx.uctx_local then ctx.uctx_universes + else + let cstrsr = Univ.ContextSet.constraints ctx'.uctx_local in + Univ.merge_constraints cstrsr ctx.uctx_universes} + +(* let union_evar_universe_context_key = Profile.declare_profile "union_evar_universe_context";; *) +(* let union_evar_universe_context = *) +(* Profile.profile2 union_evar_universe_context_key union_evar_universe_context;; *) + +let diff_evar_universe_context ctx' ctx = + if ctx == ctx' then empty_evar_universe_context + else + let local = Univ.ContextSet.diff ctx'.uctx_local ctx.uctx_local in + { uctx_local = local; + uctx_postponed = Univ.UniverseConstraints.diff ctx'.uctx_postponed ctx.uctx_postponed; + uctx_univ_variables = + Univ.LMap.diff ctx'.uctx_univ_variables ctx.uctx_univ_variables; + uctx_univ_algebraic = + Univ.LSet.diff ctx'.uctx_univ_algebraic ctx.uctx_univ_algebraic; + uctx_universes = Univ.empty_universes } + +(* let diff_evar_universe_context_key = Profile.declare_profile "diff_evar_universe_context";; *) +(* let diff_evar_universe_context = *) +(* Profile.profile2 diff_evar_universe_context_key diff_evar_universe_context;; *) + +type 'a in_evar_universe_context = 'a * evar_universe_context + +let evar_universe_context_set ctx = ctx.uctx_local +let evar_context_universe_context ctx = Univ.ContextSet.to_context ctx.uctx_local +let evar_universe_context_of ctx = { empty_evar_universe_context with uctx_local = ctx } +let evar_universe_context_subst ctx = ctx.uctx_univ_variables + +let instantiate_variable l b v = + (* let b = Univ.subst_large_constraint (Univ.Universe.make l) Univ.type0m_univ b in *) + (* if Univ.univ_depends (Univ.Universe.make l) b then *) + (* error ("Occur-check in universe variable instantiation") *) + (* else *) v := Univ.LMap.add l (Some b) !v + +exception UniversesDiffer + +let process_universe_constraints univs postponed vars alg local cstrs = + let vars = ref vars in + let normalize = Universes.normalize_universe_opt_subst vars in + let rec unify_universes fo l d r local postponed = + let l = normalize l and r = normalize r in + if Univ.Universe.eq l r then local, postponed + else + let varinfo x = + match Univ.Universe.level x with + | None -> Inl x + | Some l -> Inr (l, Univ.LMap.mem l !vars, Univ.LSet.mem l alg) + in + if d == Univ.ULe then + if Univ.check_leq univs l r then + (** Keep Prop <= var around if var might be instantiated by prop later. *) + if Univ.is_type0m_univ l && not (Univ.is_small_univ r) then + match Univ.Universe.level l, Univ.Universe.level r with + | Some l, Some r -> Univ.Constraint.add (l,Univ.Le,r) local, postponed + | _, _ -> local, postponed + else local, postponed + else + match Univ.Universe.level r with + | None -> (local, Univ.UniverseConstraints.add (l,d,r) postponed) + | Some _ -> (Univ.enforce_leq l r local, postponed) + else if d == Univ.ULub then + match varinfo l, varinfo r with + | (Inr (l, true, _), Inr (r, _, _)) + | (Inr (r, _, _), Inr (l, true, _)) -> + instantiate_variable l (Univ.Universe.make r) vars; + Univ.enforce_eq_level l r local, postponed + | Inr (_, _, _), Inr (_, _, _) -> + unify_universes true l Univ.UEq r local postponed + | _, _ -> (* Dead code *) + if Univ.check_eq univs l r then local, postponed + else local, Univ.UniverseConstraints.add (l,d,r) postponed + else (* d = Univ.UEq *) + match varinfo l, varinfo r with + | Inr (l', lloc, _), Inr (r', rloc, _) -> + let () = + if lloc then + instantiate_variable l' (Univ.Universe.make r') vars + else if rloc then + instantiate_variable r' (Univ.Universe.make l') vars + else + (* Two rigid/global levels, one of them being Prop/Set, disallow *) + (* if Univ.is_small_univ l' || Univ.is_small_univ r' then *) + (* raise UniversesDiffer *) + (* else *) + if fo then + if not (Univ.check_eq univs l r) then + raise UniversesDiffer + in + Univ.enforce_eq_level l' r' local, postponed + | _, _ (* Algebraic or globals: + try first-order unification of formal expressions. + THIS IS WRONG: it should be postponed and the equality + turned into a common lub constraint. *) -> + if Univ.check_eq univs l r then local, postponed + else raise UniversesDiffer + (* anomaly (Pp.str"Trying to equate algebraic universes") *) + (* local, Univ.UniverseConstraints.add (l,d,r) postponed *) + in + let rec fixpoint local postponed cstrs = + let local, postponed' = + Univ.UniverseConstraints.fold (fun (l,d,r) (local, p) -> unify_universes false l d r local p) + cstrs (local, postponed) + in + if Univ.UniverseConstraints.is_empty postponed' then local, postponed' + else if Univ.UniverseConstraints.equal cstrs postponed' then local, postponed' + else (* Progress: *) + fixpoint local Univ.UniverseConstraints.empty postponed' + in + let local, pbs = fixpoint Univ.Constraint.empty postponed cstrs in + !vars, local, pbs + +let add_constraints_context ctx cstrs = + let univs, local = ctx.uctx_local in + let cstrs' = Univ.Constraint.fold (fun (l,d,r) acc -> + let l = Univ.Universe.make l and r = Univ.Universe.make r in + let cstr' = + if d == Univ.Lt then (Univ.Universe.super l, Univ.ULe, r) + else (l, (if d == Univ.Le then Univ.ULe else Univ.UEq), r) + in Univ.UniverseConstraints.add cstr' acc) + cstrs Univ.UniverseConstraints.empty + in + let vars, local', pbs = + process_universe_constraints ctx.uctx_universes ctx.uctx_postponed + ctx.uctx_univ_variables ctx.uctx_univ_algebraic + local cstrs' + in + { ctx with uctx_local = (univs, Univ.Constraint.union local local'); + uctx_postponed = pbs; + uctx_univ_variables = vars; + uctx_universes = Univ.merge_constraints cstrs ctx.uctx_universes } + +(* let addconstrkey = Profile.declare_profile "add_constraints_context";; *) +(* let add_constraints_context = Profile.profile2 addconstrkey add_constraints_context;; *) + +let add_universe_constraints_context ctx cstrs = + let univs, local = ctx.uctx_local in + let vars, local', pbs = + process_universe_constraints ctx.uctx_universes ctx.uctx_postponed + ctx.uctx_univ_variables ctx.uctx_univ_algebraic local cstrs + in + { ctx with uctx_local = (univs, Univ.Constraint.union local local'); + uctx_postponed = pbs; + uctx_univ_variables = vars; + uctx_universes = Univ.merge_constraints local' ctx.uctx_universes } + +(* let addunivconstrkey = Profile.declare_profile "add_universe_constraints_context";; *) +(* let add_universe_constraints_context = *) +(* Profile.profile2 addunivconstrkey add_universe_constraints_context;; *) (*******************************************************************) (* Metamaps *) @@ -341,8 +549,7 @@ module EvMap = Evar.Map type evar_map = { defn_evars : evar_info EvMap.t; undf_evars : evar_info EvMap.t; - universes : Univ.UniverseLSet.t; - univ_cstrs : Univ.universes; + universes : evar_universe_context; conv_pbs : evar_constraint list; last_mods : Evar.Set.t; metas : clbinding Metamap.t; @@ -448,8 +655,11 @@ let existential_type d (n, args) = anomaly (str "Evar " ++ str (string_of_existential n) ++ str " was not declared") in instantiate_evar_array info info.evar_concl args -let add_constraints d cstrs = - { d with univ_cstrs = Univ.merge_constraints cstrs d.univ_cstrs } +let add_constraints d c = + { d with universes = add_constraints_context d.universes c } + +let add_universe_constraints d c = + { d with universes = add_universe_constraints_context d.universes c } (*** /Lifting... ***) @@ -473,8 +683,8 @@ let subst_evar_info s evi = evar_body = subst_evb evi.evar_body } let subst_evar_defs_light sub evd = - assert (Univ.is_initial_universes evd.univ_cstrs); - assert (match evd.conv_pbs with [] -> true | _ -> false); + assert (Univ.is_initial_universes evd.universes.uctx_universes); + assert (List.is_empty evd.conv_pbs); let map_info i = subst_evar_info sub i in { evd with undf_evars = EvMap.smartmap map_info evd.undf_evars; @@ -483,6 +693,13 @@ let subst_evar_defs_light sub evd = let subst_evar_map = subst_evar_defs_light +let cmap f evd = + { evd with + metas = Metamap.map (map_clb f) evd.metas; + defn_evars = EvMap.map (map_evar_info f) evd.defn_evars; + undf_evars = EvMap.map (map_evar_info f) evd.defn_evars + } + (* spiwack: deprecated *) let create_evar_defs sigma = { sigma with conv_pbs=[]; last_mods=Evar.Set.empty; metas=Metamap.empty } @@ -494,20 +711,32 @@ let create_goal_evar_defs sigma = { sigma with let empty = { defn_evars = EvMap.empty; undf_evars = EvMap.empty; - universes = Univ.UniverseLSet.empty; - univ_cstrs = Univ.initial_universes; + universes = empty_evar_universe_context; conv_pbs = []; last_mods = Evar.Set.empty; metas = Metamap.empty; effects = Declareops.no_seff; } +let from_env ?(ctx=Univ.ContextSet.empty) e = + { empty with universes = evar_universe_context_from e ctx } + + let has_undefined evd = not (EvMap.is_empty evd.undf_evars) -let evars_reset_evd ?(with_conv_pbs=false) evd d = +let evars_reset_evd ?(with_conv_pbs=false) ?(with_univs=true) evd d = let conv_pbs = if with_conv_pbs then evd.conv_pbs else d.conv_pbs in let last_mods = if with_conv_pbs then evd.last_mods else d.last_mods in - { evd with metas = d.metas; last_mods; conv_pbs; } + let universes = + if not with_univs then evd.universes + else union_evar_universe_context 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' } let add_conv_pb pb d = {d with conv_pbs = pb::d.conv_pbs} @@ -608,80 +837,444 @@ let drop_side_effects evd = let eval_side_effects evd = evd.effects +let meta_diff ext orig = + Metamap.fold (fun m v acc -> + if Metamap.mem m orig then acc + else Metamap.add m v acc) + ext Metamap.empty + +(** ext is supposed to be an extension of odef: + it might have more defined evars, and more + or less undefined ones *) +let diff2 edef eundef odef oundef = + let def = + if odef == edef then EvMap.empty + else + EvMap.fold (fun e v acc -> + if EvMap.mem e odef then acc + else EvMap.add e v acc) + edef EvMap.empty + in + let undef = + if oundef == eundef then EvMap.empty + else + EvMap.fold (fun e v acc -> + if EvMap.mem e oundef then acc + else EvMap.add e v acc) + eundef EvMap.empty + in + (def, undef) + +let diff ext orig = + let defn, undf = diff2 ext.defn_evars ext.undf_evars orig.defn_evars orig.undf_evars in + { ext with + defn_evars = defn; undf_evars = undf; + universes = diff_evar_universe_context ext.universes orig.universes; + metas = meta_diff ext.metas orig.metas + } + +(** Invariant: sigma' is a partial extension of sigma: + It may define variables that are undefined in sigma, + or add new defined or undefined variables. It should not + undefine a defined variable in sigma. +*) + +let merge2 def undef def' undef' = + let def, undef = + EvMap.fold (fun n v (def,undef) -> + EvMap.add n v def, EvMap.remove n undef) + def' (def,undef) + in + let undef = EvMap.fold EvMap.add undef' undef in + (def, undef) + +let merge_metas metas1 metas2 = + List.fold_left (fun m (n,v) -> Metamap.add n v m) + metas2 (metamap_to_list metas1) + +let merge orig ext = + let defn, undf = merge2 orig.defn_evars orig.undf_evars ext.defn_evars ext.undf_evars in + let universes = union_evar_universe_context orig.universes ext.universes in + { orig with defn_evars = defn; undf_evars = undf; + universes; + metas = merge_metas orig.metas ext.metas } + (**********************************************************) (* Sort variables *) -let new_univ_variable evd = - let u = Termops.new_univ_level () in - let universes = Univ.UniverseLSet.add u evd.universes in - ({ evd with universes }, Univ.Universe.make u) +type rigid = + | UnivRigid + | UnivFlexible of bool (** Is substitution by an algebraic ok? *) + +let univ_rigid = UnivRigid +let univ_flexible = UnivFlexible false +let univ_flexible_alg = UnivFlexible true + +let evar_universe_context d = d.universes -let new_sort_variable d = - let (d', u) = new_univ_variable d in - (d', Type u) +let get_universe_context_set d = d.universes.uctx_local + +let universes evd = evd.universes.uctx_universes + +let universe_context evd = + Univ.ContextSet.to_context evd.universes.uctx_local + +let universe_subst evd = + evd.universes.uctx_univ_variables + +let merge_uctx rigid uctx ctx' = + let uctx = + match rigid with + | UnivRigid -> uctx + | UnivFlexible b -> + let uvars' = Univ.LMap.subst_union uctx.uctx_univ_variables + (Univ.LMap.of_set (Univ.ContextSet.levels ctx') None) in + if b then + { uctx with uctx_univ_variables = uvars'; + uctx_univ_algebraic = Univ.LSet.union uctx.uctx_univ_algebraic + (Univ.ContextSet.levels ctx') } + else { uctx with uctx_univ_variables = uvars' } + in + { uctx with uctx_local = Univ.ContextSet.union uctx.uctx_local ctx'; + uctx_universes = Univ.merge_constraints (Univ.ContextSet.constraints ctx') + uctx.uctx_universes } + +let merge_context_set rigid evd ctx' = + {evd with universes = merge_uctx rigid evd.universes ctx'} + +let with_context_set rigid d (a, ctx) = + (merge_context_set rigid d ctx, a) + +let uctx_new_univ_variable rigid + ({ uctx_local = ctx; uctx_univ_variables = uvars; uctx_univ_algebraic = avars} as uctx) = + let u = Universes.new_univ_level (Global.current_dirpath ()) in + let ctx' = Univ.ContextSet.union ctx (Univ.ContextSet.singleton u) in + let uctx' = + match rigid with + | UnivRigid -> uctx + | UnivFlexible b -> + let uvars' = Univ.LMap.add u None uvars in + if b then {uctx with uctx_univ_variables = uvars'; + uctx_univ_algebraic = Univ.LSet.add u avars} + else {uctx with uctx_univ_variables = Univ.LMap.add u None uvars} in + {uctx' with uctx_local = ctx'}, u + +let new_univ_variable rigid evd = + let uctx', u = uctx_new_univ_variable rigid evd.universes in + ({evd with universes = uctx'}, Univ.Universe.make u) + +let new_sort_variable rigid d = + let (d', u) = new_univ_variable rigid d in + (d', Type u) + +let make_flexible_variable evd b u = + let {uctx_univ_variables = uvars; uctx_univ_algebraic = avars} as ctx = evd.universes in + let uvars' = Univ.LMap.add u None uvars in + let avars' = + if b then + let uu = Univ.Universe.make u in + let substu_not_alg u' v = + Option.cata (fun vu -> Univ.Universe.eq uu vu && not (Univ.LSet.mem u' avars)) false v + in + if not (Univ.LMap.exists substu_not_alg uvars) + then Univ.LSet.add u avars else avars + else avars + in + {evd with universes = {ctx with uctx_univ_variables = uvars'; + uctx_univ_algebraic = avars'}} + + +let instantiate_univ_variable evd v u = + let uvars' = Univ.LMap.add v (Some u) evd.universes.uctx_univ_variables in + {evd with universes = {evd.universes with uctx_univ_variables = uvars'}} + +(****************************************) +(* Operations on constants *) +(****************************************) + +let fresh_sort_in_family env evd s = + with_context_set univ_flexible evd (Universes.fresh_sort_in_family env s) + +let fresh_constant_instance env evd c = + with_context_set univ_flexible evd (Universes.fresh_constant_instance env c) + +let fresh_inductive_instance env evd i = + with_context_set univ_flexible evd (Universes.fresh_inductive_instance env i) + +let fresh_constructor_instance env evd c = + with_context_set univ_flexible evd (Universes.fresh_constructor_instance env c) + +let fresh_global ?(rigid=univ_flexible) env evd gr = + (* match gr with *) + (* | ConstructRef c -> let evd, c = fresh_constructor_instance env evd c in *) + (* evd, mkConstructU c *) + (* | IndRef c -> let evd, c = fresh_inductive_instance env evd c in *) + (* evd, mkIndU c *) + (* | ConstRef c -> let evd, c = fresh_constant_instance env evd c in *) + (* evd, mkConstU c *) + (* | VarRef i -> evd, mkVar i *) + with_context_set rigid evd (Universes.fresh_global_instance env gr) -let is_sort_variable evd s = match s with Type u -> true | _ -> false let whd_sort_variable evd t = t -let univ_of_sort = function - | Type u -> u - | Prop Pos -> Univ.type0_univ - | Prop Null -> Univ.type0m_univ +let is_sort_variable evd s = + match s with + | Type u -> + (match Univ.universe_level u with + | Some l -> + let uctx = evd.universes in + if Univ.LSet.mem l (Univ.ContextSet.levels uctx.uctx_local) then + Some (l, not (Univ.LMap.mem l uctx.uctx_univ_variables)) + else None + | None -> None) + | _ -> None + let is_eq_sort s1 s2 = if Sorts.equal s1 s2 then None else let u1 = univ_of_sort s1 and u2 = univ_of_sort s2 in - if Univ.Universe.equal u1 u2 then None + if Univ.Universe.eq u1 u2 then None else Some (u1, u2) -let is_univ_var_or_set u = - Univ.is_univ_variable u || Univ.is_type0_univ u +let is_univ_var_or_set u = + not (Option.is_empty (Univ.universe_level u)) -let set_leq_sort evd s1 s2 = - match is_eq_sort s1 s2 with - | None -> evd - | Some (u1, u2) -> - match s1, s2 with - | Prop Null, Prop Pos -> evd - | Prop _, Prop _ -> - raise (Univ.UniverseInconsistency (Univ.Le, u1, u2,[])) - | Type u, Prop Pos -> - let cstr = Univ.enforce_leq u Univ.type0_univ Univ.empty_constraint in - add_constraints evd cstr - | Type _, Prop _ -> - raise (Univ.UniverseInconsistency (Univ.Le, u1, u2,[])) - | _, Type u -> - if is_univ_var_or_set u then - let cstr = Univ.enforce_leq u1 u2 Univ.empty_constraint in - add_constraints evd cstr - else raise (Univ.UniverseInconsistency (Univ.Le, u1, u2,[])) - -let is_univ_level_var us u = - match Univ.universe_level u with - | Some u -> Univ.UniverseLSet.mem u us - | None -> false +type universe_global = + | LocalUniv of Univ.universe_level + | GlobalUniv of Univ.universe_level + +type universe_kind = + | Algebraic of Univ.universe + | Variable of universe_global * bool -let set_eq_sort ({ universes = us; univ_cstrs = sm; } as d) s1 s2 = +let is_univ_level_var (us, cst) algs u = + match Univ.universe_level u with + | Some l -> + let glob = if Univ.LSet.mem l us then LocalUniv l else GlobalUniv l in + Variable (glob, Univ.LSet.mem l algs) + | None -> Algebraic u + +let normalize_universe evd = + let vars = ref evd.universes.uctx_univ_variables in + let normalize = Universes.normalize_universe_opt_subst vars in + normalize + +let memo_normalize_universe evd = + let vars = ref evd.universes.uctx_univ_variables in + let normalize = Universes.normalize_universe_opt_subst vars in + (fun () -> {evd with universes = {evd.universes with uctx_univ_variables = !vars}}), + normalize + +let normalize_universe_instance evd l = + let vars = ref evd.universes.uctx_univ_variables in + let normalize = Univ.level_subst_of (Universes.normalize_univ_variable_opt_subst vars) in + Univ.Instance.subst_fn normalize l + +let normalize_sort evars s = + match s with + | Prop _ -> s + | Type u -> + let u' = normalize_universe evars u in + if u' == u then s else Type u' + +(* FIXME inefficient *) +let set_eq_sort d s1 s2 = + let s1 = normalize_sort d s1 and s2 = normalize_sort d s2 in match is_eq_sort s1 s2 with | None -> d + | Some (u1, u2) -> add_universe_constraints d + (Univ.UniverseConstraints.singleton (u1,Univ.UEq,u2)) + +let has_lub evd u1 u2 = + (* let normalize = Universes.normalize_universe_opt_subst (ref univs.uctx_univ_variables) in *) + (* (\* let dref, norm = memo_normalize_universe d in *\) *) + (* let u1 = normalize u1 and u2 = normalize u2 in *) + if Univ.Universe.eq u1 u2 then evd + else add_universe_constraints evd + (Univ.UniverseConstraints.singleton (u1,Univ.ULub,u2)) + +let set_eq_level d u1 u2 = + add_constraints d (Univ.enforce_eq_level u1 u2 Univ.Constraint.empty) + +let set_leq_level d u1 u2 = + add_constraints d (Univ.enforce_leq_level u1 u2 Univ.Constraint.empty) + +let set_eq_instances d u1 u2 = + add_universe_constraints d + (Univ.enforce_eq_instances_univs false u1 u2 Univ.UniverseConstraints.empty) + +let set_leq_sort evd s1 s2 = + let s1 = normalize_sort evd s1 + and s2 = normalize_sort evd s2 in + match is_eq_sort s1 s2 with + | None -> evd | Some (u1, u2) -> match s1, s2 with - | Prop c, Type u when is_univ_level_var us u -> - add_constraints d (Univ.enforce_eq u1 u2 Univ.empty_constraint) - | Type u, Prop c when is_univ_level_var us u -> - add_constraints d (Univ.enforce_eq u1 u2 Univ.empty_constraint) - | Type u, Type v when (is_univ_level_var us u) || (is_univ_level_var us v) -> - add_constraints d (Univ.enforce_eq u1 u2 Univ.empty_constraint) - | Prop c, Type u when is_univ_var_or_set u && - Univ.lax_check_eq sm u1 u2 -> d - | Type u, Prop c when is_univ_var_or_set u && - Univ.lax_check_eq sm u1 u2 -> d - | Type u, Type v when is_univ_var_or_set u && is_univ_var_or_set v -> - add_constraints d (Univ.enforce_eq u1 u2 Univ.empty_constraint) - | _, _ -> raise (Univ.UniverseInconsistency (Univ.Eq, u1, u2, [])) - + | Prop c, Prop c' -> + if c == Null && c' == Pos then evd + else (raise (Univ.UniverseInconsistency (Univ.Le, u1, u2, []))) + | _, _ -> + add_universe_constraints evd (Univ.UniverseConstraints.singleton (u1,Univ.ULe,u2)) + +let check_eq evd s s' = + Univ.check_eq evd.universes.uctx_universes s s' + +let check_leq evd s s' = + Univ.check_leq evd.universes.uctx_universes s s' + +let subst_univs_context_with_def def usubst (ctx, cst) = + (Univ.LSet.diff ctx def, Univ.subst_univs_constraints usubst cst) + +let subst_univs_context usubst ctx = + subst_univs_context_with_def (Univ.LMap.universes usubst) (Univ.make_subst usubst) ctx + +let subst_univs_universes s g = + Univ.LMap.fold (fun u v g -> + (* Problem here: we might have instantiated an algebraic universe... *) + Univ.enforce_constraint (u, Univ.Eq, Option.get (Univ.Universe.level v)) g) s g + +let subst_univs_opt_universes s g = + Univ.LMap.fold (fun u v g -> + (* Problem here: we might have instantiated an algebraic universe... *) + match v with + | Some l -> + Univ.enforce_constraint (u, Univ.Eq, Option.get (Univ.Universe.level l)) g + | None -> g) s g + +let normalize_evar_universe_context_variables uctx = + let normalized_variables, undef, def, subst = + Universes.normalize_univ_variables uctx.uctx_univ_variables + in + let ctx_local = subst_univs_context_with_def def (Univ.make_subst subst) uctx.uctx_local in + (* let univs = subst_univs_universes subst uctx.uctx_universes in *) + let ctx_local', univs = Universes.refresh_constraints (Global.universes ()) ctx_local in + subst, { uctx with uctx_local = ctx_local'; + uctx_univ_variables = normalized_variables; + uctx_universes = univs } + +(* let normvarsconstrkey = Profile.declare_profile "normalize_evar_universe_context_variables";; *) +(* let normalize_evar_universe_context_variables = *) +(* Profile.profile1 normvarsconstrkey normalize_evar_universe_context_variables;; *) + +let mark_undefs_as_rigid uctx = + let vars' = + Univ.LMap.fold (fun u v acc -> + if v == None && not (Univ.LSet.mem u uctx.uctx_univ_algebraic) + then acc else Univ.LMap.add u v acc) + uctx.uctx_univ_variables Univ.LMap.empty + in { uctx with uctx_univ_variables = vars' } + +let mark_undefs_as_nonalg uctx = + let vars' = + Univ.LMap.fold (fun u v acc -> + if v == None then Univ.LSet.remove u acc + else acc) + uctx.uctx_univ_variables uctx.uctx_univ_algebraic + in { uctx with uctx_univ_algebraic = vars' } + +let abstract_undefined_variables evd = + {evd with universes = mark_undefs_as_nonalg evd.universes} + +let refresh_undefined_univ_variables uctx = + let subst, ctx' = Universes.fresh_universe_context_set_instance uctx.uctx_local in + let alg = Univ.LSet.fold (fun u acc -> Univ.LSet.add (Univ.subst_univs_level_level subst u) acc) + uctx.uctx_univ_algebraic Univ.LSet.empty + in + let vars = + Univ.LMap.fold + (fun u v acc -> + Univ.LMap.add (Univ.subst_univs_level_level subst u) + (Option.map (Univ.subst_univs_level_universe subst) v) acc) + uctx.uctx_univ_variables Univ.LMap.empty + in + let uctx' = {uctx_local = ctx'; + uctx_postponed = Univ.UniverseConstraints.empty;(*FIXME*) + uctx_univ_variables = vars; uctx_univ_algebraic = alg; + uctx_universes = Univ.initial_universes} in + uctx', subst + +let refresh_undefined_universes evd = + let uctx', subst = refresh_undefined_univ_variables evd.universes in + let evd' = cmap (subst_univs_level_constr subst) {evd with universes = uctx'} in + evd', subst + +let constraints_universes c = + Univ.Constraint.fold (fun (l',d,r') acc -> Univ.LSet.add l' (Univ.LSet.add r' acc)) + c Univ.LSet.empty + +let is_undefined_universe_variable l vars = + try (match Univ.LMap.find l vars with + | Some u -> false + | None -> true) + with Not_found -> false + +let normalize_evar_universe_context uctx = + let rec fixpoint uctx = + let ((vars',algs'), us') = + Universes.normalize_context_set uctx.uctx_local uctx.uctx_univ_variables + uctx.uctx_univ_algebraic + in + if Univ.LSet.equal (fst us') (fst uctx.uctx_local) then + uctx + else + let us', universes = Universes.refresh_constraints (Global.universes ()) us' in + (* let universes = subst_univs_opt_universes vars' uctx.uctx_universes in *) + let postponed = + Univ.subst_univs_universe_constraints (Universes.make_opt_subst vars') + uctx.uctx_postponed + in + let uctx' = + { uctx_local = us'; + uctx_univ_variables = vars'; + uctx_univ_algebraic = algs'; + uctx_postponed = postponed; + uctx_universes = universes} + in fixpoint uctx' + in fixpoint uctx + +let nf_univ_variables evd = + let subst, uctx' = normalize_evar_universe_context_variables evd.universes in + let evd' = {evd with universes = uctx'} in + evd', subst + +let normalize_univ_level fullsubst u = + try Univ.LMap.find u fullsubst + with Not_found -> Univ.Universe.make u + +let nf_constraints evd = + let subst, uctx' = normalize_evar_universe_context_variables evd.universes in + let uctx' = normalize_evar_universe_context uctx' in + {evd with universes = uctx'} + +(* let nfconstrkey = Profile.declare_profile "nf_constraints";; *) +(* let nf_constraints = Profile.profile1 nfconstrkey nf_constraints;; *) + +let universes evd = evd.universes.uctx_universes + +(* Conversion w.r.t. an evar map and its local universes. *) + +let conversion_gen env evd pb t u = + match pb with + | Reduction.CONV -> + Reduction.trans_conv_universes + full_transparent_state ~evars:(existential_opt_value evd) env + evd.universes.uctx_universes t u + | Reduction.CUMUL -> Reduction.trans_conv_leq_universes + full_transparent_state ~evars:(existential_opt_value evd) env + evd.universes.uctx_universes t u + +(* let conversion_gen_key = Profile.declare_profile "conversion_gen" *) +(* let conversion_gen = Profile.profile5 conversion_gen_key conversion_gen *) + +let conversion env d pb t u = + conversion_gen env d pb t u; d + +let test_conversion env d pb t u = + try conversion_gen env d pb t u; true + with _ -> false + (**********************************************************) (* Accessing metas *) @@ -691,7 +1284,6 @@ let set_metas evd metas = { defn_evars = evd.defn_evars; undf_evars = evd.undf_evars; universes = evd.universes; - univ_cstrs = evd.univ_cstrs; conv_pbs = evd.conv_pbs; last_mods = evd.last_mods; metas; @@ -787,9 +1379,12 @@ let meta_with_name evd id = (str "Binder name \"" ++ pr_id id ++ strbrk "\" occurs more than once in clause.") +let clear_metas evd = {evd with metas = Metamap.empty} + let meta_merge evd1 evd2 = let metas = Metamap.fold Metamap.add evd1.metas evd2.metas in - set_metas evd2 metas + let universes = union_evar_universe_context evd2.universes evd1.universes in + {evd2 with universes; metas; } type metabinding = metavariable * constr * instance_status @@ -907,7 +1502,7 @@ let pr_evar_source = function | Evar_kinds.ImplicitArg (c,(n,ido),b) -> let id = Option.get ido in str "parameter " ++ pr_id id ++ spc () ++ str "of" ++ - spc () ++ print_constr (constr_of_global c) + spc () ++ print_constr (printable_constr_of_global c) | Evar_kinds.InternalHole -> str "internal placeholder" | Evar_kinds.TomatchTypeParameter (ind,n) -> pr_nth n ++ str " argument of type " ++ print_constr (mkInd ind) @@ -989,6 +1584,16 @@ let evar_dependency_closure n sigma = let has_no_evar sigma = EvMap.is_empty sigma.defn_evars && EvMap.is_empty sigma.undf_evars +let pr_evar_universe_context ctx = + if is_empty_evar_universe_context ctx then mt () + else + (str"UNIVERSES:"++brk(0,1)++ h 0 (Univ.pr_universe_context_set ctx.uctx_local) ++ fnl () ++ + str"POSTPONED CONSTRAINTS:"++brk(0,1)++ + h 0 (Univ.UniverseConstraints.pr ctx.uctx_postponed) ++ fnl () ++ + str"ALGEBRAIC UNIVERSES:"++brk(0,1)++h 0 (Univ.LSet.pr ctx.uctx_univ_algebraic) ++ fnl() ++ + str"UNDEFINED UNIVERSES:"++brk(0,1)++ + h 0 (Universes.pr_universe_opt_subst ctx.uctx_univ_variables)) + let print_env_short env = let pr_body n = function | None -> pr_name n @@ -1012,17 +1617,9 @@ let pr_evar_constraints pbs = prlist_with_sep fnl pr_evconstr pbs let pr_evar_map_gen pr_evars sigma = - let { universes = uvs; univ_cstrs = univs; } = sigma in + let { universes = uvs } = sigma in let evs = if has_no_evar sigma then mt () else pr_evars sigma - and svs = - if Univ.UniverseLSet.is_empty uvs then mt () - else str "UNIVERSE VARIABLES:" ++ brk (0, 1) ++ - h 0 (prlist_with_sep fnl Univ.pr_uni_level - (Univ.UniverseLSet.elements uvs)) ++ fnl () - and cs = - if Univ.is_initial_universes univs then mt () - else str "UNIVERSES:" ++ brk (0, 1) ++ - h 0 (Univ.pr_universes univs) ++ fnl () + and svs = pr_evar_universe_context uvs and cstrs = if List.is_empty sigma.conv_pbs then mt () else @@ -1033,7 +1630,7 @@ let pr_evar_map_gen pr_evars sigma = else str "METAS:" ++ brk (0, 1) ++ pr_meta_map sigma.metas in - evs ++ svs ++ cs ++ cstrs ++ metas + evs ++ svs ++ cstrs ++ metas let pr_evar_list l = let pr (ev, evi) = diff --git a/pretyping/evd.mli b/pretyping/evd.mli index 55bce05de..18d68bebf 100644 --- a/pretyping/evd.mli +++ b/pretyping/evd.mli @@ -112,6 +112,9 @@ val evar_filter : evar_info -> Filter.t val evar_env : evar_info -> env val evar_filtered_env : evar_info -> env +val map_evar_body : (constr -> constr) -> evar_body -> evar_body +val map_evar_info : (constr -> constr) -> evar_info -> evar_info + (** {6 Unification state} **) type evar_map @@ -125,6 +128,10 @@ val progress_evar_map : evar_map -> evar_map -> bool val empty : evar_map (** The empty evar map. *) +val from_env : ?ctx:Univ.universe_context_set -> env -> evar_map +(** The empty evar map with given universe context, taking its initial + universes from env. *) + val is_empty : evar_map -> bool (** Whether an evarmap is empty. *) @@ -174,6 +181,17 @@ val define : evar -> constr -> evar_map -> evar_map {- All the evars present in the constr should be present in the evar map.} } *) +val cmap : (constr -> constr) -> evar_map -> evar_map +(** Map the function on all terms in the evar map. *) + +val diff : evar_map -> evar_map -> evar_map +(** [diff ext orig] assuming [ext] is an extension of [orig], + return an evar map containing just the extension *) + +val merge : evar_map -> evar_map -> evar_map +(** [merge orig ext] assuming [ext] is an extension of [orig], + return an evar map containing the union of the two maps *) + val is_evar : evar_map -> evar -> bool (** Alias for {!mem}. *) @@ -208,7 +226,7 @@ val instantiate_evar_array : evar_info -> constr -> constr array -> constr val subst_evar_defs_light : substitution -> evar_map -> evar_map (** Assume empty universe constraints in [evar_map] and [conv_pbs] *) -val evars_reset_evd : ?with_conv_pbs:bool -> evar_map -> evar_map -> evar_map +val evars_reset_evd : ?with_conv_pbs:bool -> ?with_univs:bool -> evar_map -> evar_map -> evar_map (** spiwack: this function seems to somewhat break the abstraction. *) (** {6 Misc} *) @@ -245,6 +263,13 @@ val whd_sort_variable : evar_map -> constr -> constr val set_leq_sort : evar_map -> sorts -> sorts -> evar_map val set_eq_sort : evar_map -> sorts -> sorts -> evar_map +exception UniversesDiffer + +val add_universe_constraints : evar_map -> Univ.universe_constraints -> evar_map +(** Add the given universe unification constraints to the evar map. + @raises UniversesDiffer in case a first-order unification fails. + @raises UniverseInconsistency +*) (** {5 Enriching with evar maps} *) type 'a sigma = { @@ -353,6 +378,8 @@ val meta_declare : val meta_assign : metavariable -> constr * instance_status -> evar_map -> evar_map val meta_reassign : metavariable -> constr * instance_status -> evar_map -> evar_map +val clear_metas : evar_map -> evar_map + (** [meta_merge evd1 evd2] returns [evd2] extended with the metas of [evd1] *) val meta_merge : evar_map -> evar_map -> evar_map @@ -366,6 +393,106 @@ val subst_defined_metas : metabinding list -> constr -> constr option (** {5 FIXME: Nothing to do here} *) +(********************************************************* + Sort/universe variables *) + +(** Rigid or flexible universe variables *) + +type rigid = + | UnivRigid + | UnivFlexible of bool (** Is substitution by an algebraic ok? *) + +val univ_rigid : rigid +val univ_flexible : rigid +val univ_flexible_alg : rigid + +(** The universe context associated to an evar map *) +type evar_universe_context + +type 'a in_evar_universe_context = 'a * evar_universe_context + +val evar_universe_context_set : evar_universe_context -> Univ.universe_context_set +val evar_context_universe_context : evar_universe_context -> Univ.universe_context +val evar_universe_context_of : Univ.universe_context_set -> evar_universe_context +val empty_evar_universe_context : evar_universe_context +val union_evar_universe_context : evar_universe_context -> evar_universe_context -> + evar_universe_context +val evar_universe_context_subst : evar_universe_context -> Universes.universe_opt_subst + +val universes : evar_map -> Univ.universes + +val add_constraints_context : evar_universe_context -> + Univ.constraints -> evar_universe_context + +val normalize_evar_universe_context_variables : evar_universe_context -> + Univ.universe_subst in_evar_universe_context + +val normalize_evar_universe_context : evar_universe_context -> + evar_universe_context + +val new_univ_variable : rigid -> evar_map -> evar_map * Univ.universe +val new_sort_variable : rigid -> evar_map -> evar_map * sorts +val make_flexible_variable : evar_map -> bool -> Univ.universe_level -> evar_map +val is_sort_variable : evar_map -> sorts -> (Univ.universe_level * bool) option +(** [is_sort_variable evm s] returns [Some (u, is_rigid)] or [None] if [s] is + not a sort variable declared in [evm] *) +val whd_sort_variable : evar_map -> constr -> constr +(* val normalize_universe_level : evar_map -> Univ.universe_level -> Univ.universe_level *) +val normalize_universe : evar_map -> Univ.universe -> Univ.universe +val normalize_universe_instance : evar_map -> Univ.universe_instance -> Univ.universe_instance + +val set_leq_sort : evar_map -> sorts -> sorts -> evar_map +val set_eq_sort : evar_map -> sorts -> sorts -> evar_map +val has_lub : evar_map -> Univ.universe -> Univ.universe -> evar_map +val set_eq_level : evar_map -> Univ.universe_level -> Univ.universe_level -> evar_map +val set_leq_level : evar_map -> Univ.universe_level -> Univ.universe_level -> evar_map +val set_eq_instances : evar_map -> Univ.universe_instance -> Univ.universe_instance -> evar_map + +val check_eq : evar_map -> Univ.universe -> Univ.universe -> bool +val check_leq : evar_map -> Univ.universe -> Univ.universe -> bool + +val evar_universe_context : evar_map -> evar_universe_context +val get_universe_context_set : evar_map -> Univ.universe_context_set +val universe_context : evar_map -> Univ.universe_context +val universe_subst : evar_map -> Universes.universe_opt_subst +val universes : evar_map -> Univ.universes + + +val merge_universe_context : evar_map -> evar_universe_context -> evar_map + +val merge_context_set : rigid -> evar_map -> Univ.universe_context_set -> evar_map + +val with_context_set : rigid -> evar_map -> 'a Univ.in_universe_context_set -> evar_map * 'a + +val nf_univ_variables : evar_map -> evar_map * Univ.universe_subst +val abstract_undefined_variables : evar_map -> evar_map + +val refresh_undefined_universes : evar_map -> evar_map * Univ.universe_level_subst + +val nf_constraints : evar_map -> evar_map + +(** Polymorphic universes *) + +val fresh_sort_in_family : env -> evar_map -> sorts_family -> evar_map * sorts +val fresh_constant_instance : env -> evar_map -> constant -> evar_map * pconstant +val fresh_inductive_instance : env -> evar_map -> inductive -> evar_map * pinductive +val fresh_constructor_instance : env -> evar_map -> constructor -> evar_map * pconstructor + +val fresh_global : ?rigid:rigid -> env -> evar_map -> Globnames.global_reference -> evar_map * constr + +(******************************************************************** + Conversion w.r.t. an evar map: might generate universe unifications + that are kept in the evarmap. + Raises [NotConvertible]. *) + +val conversion : env -> evar_map -> conv_pb -> constr -> constr -> evar_map + +(** This one forgets about the assignemts of universes. *) +val test_conversion : env -> evar_map -> conv_pb -> constr -> constr -> bool + +(******************************************************************** + constr with holes *) + type open_constr = evar_map * constr (** Partially constructed constrs. *) @@ -380,6 +507,7 @@ val pr_evar_map : int option -> evar_map -> Pp.std_ppcmds val pr_evar_map_filter : (Evar.t -> evar_info -> bool) -> evar_map -> Pp.std_ppcmds val pr_metaset : Metaset.t -> Pp.std_ppcmds +val pr_evar_universe_context : evar_universe_context -> Pp.std_ppcmds (** {5 Deprecated functions} *) diff --git a/pretyping/glob_ops.ml b/pretyping/glob_ops.ml index f1e38d0f8..73bb343ee 100644 --- a/pretyping/glob_ops.ml +++ b/pretyping/glob_ops.ml @@ -61,7 +61,7 @@ let cast_type_eq eq t1 t2 = match t1, t2 with | _ -> false let rec glob_constr_eq c1 c2 = match c1, c2 with -| GRef (_, gr1), GRef (_, gr2) -> eq_gr gr1 gr2 +| GRef (_, gr1, _), GRef (_, gr2, _) -> eq_gr gr1 gr2 | GVar (_, id1), GVar (_, id2) -> Id.equal id1 id2 | GEvar (_, ev1, arg1), GEvar (_, ev2, arg2) -> Evar.equal ev1 ev2 && @@ -156,6 +156,9 @@ let map_glob_constr_left_to_right f = function let comp2 = Util.List.map_left (fun (tm,x) -> (f tm,x)) tml in let comp3 = Util.List.map_left (fun (loc,idl,p,c) -> (loc,idl,p,f c)) pl in GCases (loc,sty,comp1,comp2,comp3) + | GProj (loc,p,c) -> + let comp1 = f c in + GProj (loc,p,comp1) | GLetTuple (loc,nal,(na,po),b,c) -> let comp1 = Option.map f po in let comp2 = f b in @@ -183,6 +186,7 @@ let fold_glob_constr f acc = let rec fold acc = function | GVar _ -> acc | GApp (_,c,args) -> List.fold_left fold (fold acc c) args + | GProj (_,p,c) -> fold acc c | GLambda (_,_,_,b,c) | GProd (_,_,_,b,c) | GLetIn (_,_,b,c) -> fold (fold acc b) c | GCases (_,_,rtntypopt,tml,pl) -> @@ -221,6 +225,7 @@ let occur_glob_constr id = let rec occur = function | GVar (loc,id') -> Id.equal id id' | GApp (loc,f,args) -> (occur f) || (List.exists occur args) + | GProj (loc,p,c) -> occur c | GLambda (loc,na,bk,ty,c) -> (occur ty) || (not (same_id na id) && (occur c)) | GProd (loc,na,bk,ty,c) -> @@ -270,6 +275,7 @@ let free_glob_vars = let rec vars bounded vs = function | GVar (loc,id') -> if Id.Set.mem id' bounded then vs else Id.Set.add id' vs | GApp (loc,f,args) -> List.fold_left (vars bounded) vs (f::args) + | GProj (loc,p,c) -> vars bounded vs c | GLambda (loc,na,_,ty,c) | GProd (loc,na,_,ty,c) | GLetIn (loc,na,ty,c) -> let vs' = vars bounded vs ty in let bounded' = add_name_to_ids bounded na in @@ -326,11 +332,12 @@ let free_glob_vars = let loc_of_glob_constr = function - | GRef (loc,_) -> loc + | GRef (loc,_,_) -> loc | GVar (loc,_) -> loc | GEvar (loc,_,_) -> loc | GPatVar (loc,_) -> loc | GApp (loc,_,_) -> loc + | GProj (loc,p,c) -> loc | GLambda (loc,_,_,_,_) -> loc | GProd (loc,_,_,_,_) -> loc | GLetIn (loc,_,_,_) -> loc @@ -354,18 +361,18 @@ let rec cases_pattern_of_glob_constr na = function | Anonymous -> PatVar (loc,Name id) end | GHole (loc,_,_) -> PatVar (loc,na) - | GRef (loc,ConstructRef cstr) -> + | GRef (loc,ConstructRef cstr,_) -> PatCstr (loc,cstr,[],na) - | GApp (loc,GRef (_,ConstructRef cstr),l) -> + | GApp (loc,GRef (_,ConstructRef cstr,_),l) -> PatCstr (loc,cstr,List.map (cases_pattern_of_glob_constr Anonymous) l,na) | _ -> raise Not_found (* Turn a closed cases pattern into a glob_constr *) let rec glob_constr_of_closed_cases_pattern_aux = function | PatCstr (loc,cstr,[],Anonymous) -> - GRef (loc,ConstructRef cstr) + GRef (loc,ConstructRef cstr,None) | PatCstr (loc,cstr,l,Anonymous) -> - let ref = GRef (loc,ConstructRef cstr) in + let ref = GRef (loc,ConstructRef cstr,None) in GApp (loc,ref, List.map glob_constr_of_closed_cases_pattern_aux l) | _ -> raise Not_found diff --git a/pretyping/indrec.ml b/pretyping/indrec.ml index bf9fd8a10..35a9cbdb2 100644 --- a/pretyping/indrec.ml +++ b/pretyping/indrec.ml @@ -33,7 +33,7 @@ type dep_flag = bool (* Errors related to recursors building *) type recursion_scheme_error = - | NotAllowedCaseAnalysis of (*isrec:*) bool * sorts * inductive + | NotAllowedCaseAnalysis of (*isrec:*) bool * sorts * pinductive | NotMutualInScheme of inductive * inductive exception RecursionSchemeError of recursion_scheme_error @@ -49,16 +49,16 @@ let mkLambda_string s t c = mkLambda (Name (Id.of_string s), t, c) (* Building case analysis schemes *) (* Christine Paulin, 1996 *) -let mis_make_case_com dep env sigma ind (mib,mip as specif) kind = - let lnamespar = List.map - (fun (n, c, t) -> (n, c, Termops.refresh_universes t)) +let mis_make_case_com dep env sigma (ind, u as pind) (mib,mip as specif) kind = + let usubst = Inductive.make_inductive_subst mib u in + let lnamespar = Vars.subst_univs_context usubst mib.mind_params_ctxt in if not (Sorts.List.mem kind (elim_sorts specif)) then raise (RecursionSchemeError - (NotAllowedCaseAnalysis (false, Termops.new_sort_in_family kind, ind))); + (NotAllowedCaseAnalysis (false, fst (Universes.fresh_sort_in_family env kind), pind))); let ndepar = mip.mind_nrealargs_ctxt + 1 in @@ -66,7 +66,7 @@ let mis_make_case_com dep env sigma ind (mib,mip as specif) kind = (* mais pas très joli ... (mais manque get_sort_of à ce niveau) *) let env' = push_rel_context lnamespar env in - let indf = make_ind_family(ind, Termops.extended_rel_list 0 lnamespar) in + let indf = make_ind_family(pind, Termops.extended_rel_list 0 lnamespar) in let constrs = get_constructors env indf in let rec add_branch env k = @@ -78,7 +78,7 @@ let mis_make_case_com dep env sigma ind (mib,mip as specif) kind = let depind = build_dependent_inductive env indf' in let deparsign = (Anonymous,None,depind)::arsign in - let ci = make_case_info env ind RegularStyle in + let ci = make_case_info env (fst pind) RegularStyle in let pbody = appvect (mkRel (ndepar + nbprod), @@ -101,10 +101,13 @@ let mis_make_case_com dep env sigma ind (mib,mip as specif) kind = mkLambda_string "f" t (add_branch (push_rel (Anonymous, None, t) env) (k+1)) in - let typP = make_arity env' dep indf (Termops.new_sort_in_family kind) in - it_mkLambda_or_LetIn_name env + let sigma, s = Evd.fresh_sort_in_family env sigma kind in + let typP = make_arity env' dep indf s in + let c = + it_mkLambda_or_LetIn_name env (mkLambda_string "P" typP - (add_branch (push_rel (Anonymous,None,typP) env') 0)) lnamespar + (add_branch (push_rel (Anonymous,None,typP) env') 0)) lnamespar + in sigma, c (* check if the type depends recursively on one of the inductive scheme *) @@ -188,7 +191,7 @@ let type_rec_branch is_rec dep env sigma (vargs,depPvect,decP) tyi cs recargs = if dep then let realargs = List.rev_map (fun k -> mkRel (i-k)) li in let params = List.map (lift i) vargs in - let co = applist (mkConstruct cs.cs_cstr,params@realargs) in + let co = applist (mkConstructU cs.cs_cstr,params@realargs) in Reduction.beta_appvect c [|co|] else c in @@ -264,13 +267,14 @@ let context_chop k ctx = | (_, []) -> failwith "context_chop" in chop_aux [] (k,ctx) - (* Main function *) -let mis_make_indrec env sigma listdepkind mib = +let mis_make_indrec env sigma listdepkind mib u = let nparams = mib.mind_nparams in - let nparrec = mib. mind_nparams_rec in + let nparrec = mib.mind_nparams_rec in + let evdref = ref sigma in + let usubst = Inductive.make_inductive_subst mib u in let lnonparrec,lnamesparrec = - context_chop (nparams-nparrec) mib.mind_params_ctxt in + context_chop (nparams-nparrec) (Vars.subst_univs_context usubst mib.mind_params_ctxt) in let nrec = List.length listdepkind in let depPvec = Array.make mib.mind_ntypes (None : (bool * constr) option) in @@ -278,7 +282,7 @@ let mis_make_indrec env sigma listdepkind mib = let rec assign k = function | [] -> () - | (indi,mibi,mipi,dep,_)::rest -> + | ((indi,u),mibi,mipi,dep,_)::rest -> (Array.set depPvec (snd indi) (Some(dep,mkRel k)); assign (k-1) rest) in @@ -292,7 +296,7 @@ let mis_make_indrec env sigma listdepkind mib = let make_one_rec p = let makefix nbconstruct = let rec mrec i ln ltyp ldef = function - | (indi,mibi,mipi,dep,_)::rest -> + | ((indi,u),mibi,mipi,dep,_)::rest -> let tyi = snd indi in let nctyi = Array.length mipi.mind_consnames in (* nb constructeurs du type*) @@ -300,7 +304,7 @@ let mis_make_indrec env sigma listdepkind mib = (* arity in the context of the fixpoint, i.e. P1..P_nrec f1..f_nbconstruct *) let args = Termops.extended_rel_list (nrec+nbconstruct) lnamesparrec in - let indf = make_ind_family(indi,args) in + let indf = make_ind_family((indi,u),args) in let arsign,_ = get_arity env indf in let depind = build_dependent_inductive env indf in @@ -315,7 +319,7 @@ let mis_make_indrec env sigma listdepkind mib = P1..P_nrec f1..f_nbconstruct F_1..F_nrec a_1..a_nar x:I *) let args' = Termops.extended_rel_list (dect+nrec) lnamesparrec in let args'' = Termops.extended_rel_list ndepar lnonparrec in - let indf' = make_ind_family(indi,args'@args'') in + let indf' = make_ind_family((indi,u),args'@args'') in let branches = let constrs = get_constructors env indf' in @@ -325,7 +329,7 @@ let mis_make_indrec env sigma listdepkind mib = fi in Array.map3 - (make_rec_branch_arg env sigma + (make_rec_branch_arg env !evdref (nparrec,depPvec,larsign)) vecfi constrs (dest_subterms recargsvec.(tyi)) in @@ -389,7 +393,7 @@ let mis_make_indrec env sigma listdepkind mib = mrec 0 [] [] [] in let rec make_branch env i = function - | (indi,mibi,mipi,dep,_)::rest -> + | ((indi,u),mibi,mipi,dep,_)::rest -> let tyi = snd indi in let nconstr = Array.length mipi.mind_consnames in let rec onerec env j = @@ -399,10 +403,10 @@ let mis_make_indrec env sigma listdepkind mib = let recarg = (dest_subterms recargsvec.(tyi)).(j) in let recarg = recargpar@recarg in let vargs = Termops.extended_rel_list (nrec+i+j) lnamesparrec in - let cs = get_constructor (indi,mibi,mipi,vargs) (j+1) in + let cs = get_constructor ((indi,u),mibi,mipi,vargs) (j+1) in let p_0 = type_rec_branch - true dep env sigma (vargs,depPvec,i+j) tyi cs recarg + true dep env !evdref (vargs,depPvec,i+j) tyi cs recarg in mkLambda_string "f" p_0 (onerec (push_rel (Anonymous,None,p_0) env) (j+1)) @@ -411,9 +415,10 @@ let mis_make_indrec env sigma listdepkind mib = makefix i listdepkind in let rec put_arity env i = function - | (indi,_,_,dep,kinds)::rest -> - let indf = make_ind_family (indi, Termops.extended_rel_list i lnamesparrec) in - let typP = make_arity env dep indf (Termops.new_sort_in_family kinds) in + | ((indi,u),_,_,dep,kinds)::rest -> + let indf = make_ind_family ((indi,u), Termops.extended_rel_list i lnamesparrec) in + let s = Evarutil.evd_comb1 (Evd.fresh_sort_in_family env) evdref kinds in + let typP = make_arity env dep indf s in mkLambda_string "P" typP (put_arity (push_rel (Anonymous,None,typP) env) (i+1) rest) | [] -> @@ -421,36 +426,38 @@ let mis_make_indrec env sigma listdepkind mib = in (* Body on make_one_rec *) - let (indi,mibi,mipi,dep,kind) = List.nth listdepkind p in + let ((indi,u),mibi,mipi,dep,kind) = List.nth listdepkind p in if (mis_is_recursive_subset - (List.map (fun (indi,_,_,_,_) -> snd indi) listdepkind) + (List.map (fun ((indi,u),_,_,_,_) -> snd indi) listdepkind) mipi.mind_recargs) then let env' = push_rel_context lnamesparrec env in it_mkLambda_or_LetIn_name env (put_arity env' 0 listdepkind) lnamesparrec else - mis_make_case_com dep env sigma indi (mibi,mipi) kind + let evd', c = mis_make_case_com dep env !evdref (indi,u) (mibi,mipi) kind in + evdref := evd'; c in (* Body of mis_make_indrec *) - List.init nrec make_one_rec + !evdref, List.init nrec make_one_rec (**********************************************************************) (* This builds elimination predicate for Case tactic *) -let build_case_analysis_scheme env sigma ity dep kind = - let (mib,mip) = lookup_mind_specif env ity in - mis_make_case_com dep env sigma ity (mib,mip) kind +let build_case_analysis_scheme env sigma pity dep kind = + let (mib,mip) = lookup_mind_specif env (fst pity) in + mis_make_case_com dep env sigma pity (mib,mip) kind -let build_case_analysis_scheme_default env sigma ity kind = - let (mib,mip) = lookup_mind_specif env ity in - let dep = match inductive_sort_family mip with - | InProp -> false - | _ -> true - in - mis_make_case_com dep env sigma ity (mib,mip) kind +let is_in_prop mip = + match inductive_sort_family mip with + | InProp -> true + | _ -> false +let build_case_analysis_scheme_default env sigma pity kind = + let (mib,mip) = lookup_mind_specif env (fst pity) in + let dep = not (is_in_prop mip) in + mis_make_case_com dep env sigma pity (mib,mip) kind (**********************************************************************) (* [modify_sort_scheme s rec] replaces the sort of the scheme @@ -459,37 +466,25 @@ let build_case_analysis_scheme_default env sigma ity kind = let change_sort_arity sort = let rec drec a = match kind_of_term a with | Cast (c,_,_) -> drec c - | Prod (n,t,c) -> mkProd (n, t, drec c) - | LetIn (n,b,t,c) -> mkLetIn (n,b, t, drec c) - | Sort _ -> mkSort sort + | Prod (n,t,c) -> let s, c' = drec c in s, mkProd (n, t, c') + | LetIn (n,b,t,c) -> let s, c' = drec c in s, mkLetIn (n,b,t,c') + | Sort s -> s, mkSort sort | _ -> assert false in drec -(* [npar] is the number of expected arguments (then excluding letin's) *) -let modify_sort_scheme sort = - let rec drec npar elim = - match kind_of_term elim with - | Lambda (n,t,c) -> - if Int.equal npar 0 then - mkLambda (n, change_sort_arity sort t, c) - else - mkLambda (n, t, drec (npar-1) c) - | LetIn (n,b,t,c) -> mkLetIn (n,b,t,drec npar c) - | _ -> anomaly ~label:"modify_sort_scheme" (Pp.str "wrong elimination type") - in - drec - (* Change the sort in the type of an inductive definition, builds the corresponding eta-expanded term *) -let weaken_sort_scheme sort npars term = +let weaken_sort_scheme env evd set sort npars term ty = + let evdref = ref evd in let rec drec np elim = match kind_of_term elim with | Prod (n,t,c) -> if Int.equal np 0 then - let t' = change_sort_arity sort t in - mkProd (n, t', c), - mkLambda (n, t', mkApp(term,Termops.rel_vect 0 (npars+1))) + let osort, t' = change_sort_arity sort t in + evdref := (if set then Evd.set_eq_sort else Evd.set_leq_sort) !evdref sort osort; + mkProd (n, t', c), + mkLambda (n, t', mkApp(term,Termops.rel_vect 0 (npars+1))) else let c',term' = drec (np-1) c in mkProd (n, t, c'), mkLambda (n, t, term') @@ -497,7 +492,8 @@ let weaken_sort_scheme sort npars term = mkLetIn (n,b,t,c'), mkLetIn (n,b,t,term') | _ -> anomaly ~label:"weaken_sort_scheme" (Pp.str "wrong elimination type") in - drec npars + let ty, term = drec npars ty in + !evdref, ty, term (**********************************************************************) (* Interface to build complex Scheme *) @@ -506,11 +502,12 @@ let weaken_sort_scheme sort npars term = let check_arities listdepkind = let _ = List.fold_left - (fun ln ((_,ni as mind),mibi,mipi,dep,kind) -> + (fun ln (((_,ni as mind),u),mibi,mipi,dep,kind) -> let kelim = elim_sorts (mibi,mipi) in if not (Sorts.List.mem kind kelim) then raise (RecursionSchemeError - (NotAllowedCaseAnalysis (true, Termops.new_sort_in_family kind,mind))) + (NotAllowedCaseAnalysis (true, fst (Universes.fresh_sort_in_family (Global.env ()) + kind),(mind,u)))) else if Int.List.mem ni ln then raise (RecursionSchemeError (NotMutualInScheme (mind,mind))) else ni::ln) @@ -518,28 +515,29 @@ let check_arities listdepkind = in true let build_mutual_induction_scheme env sigma = function - | (mind,dep,s)::lrecspec -> + | ((mind,u),dep,s)::lrecspec -> let (mib,mip) = Global.lookup_inductive mind in let (sp,tyi) = mind in let listdepkind = - (mind,mib,mip,dep,s):: + ((mind,u),mib,mip,dep,s):: (List.map - (function (mind',dep',s') -> + (function ((mind',u'),dep',s') -> let (sp',_) = mind' in if eq_mind sp sp' then let (mibi',mipi') = lookup_mind_specif env mind' in - (mind',mibi',mipi',dep',s') + ((mind',u'),mibi',mipi',dep',s') else raise (RecursionSchemeError (NotMutualInScheme (mind,mind')))) lrecspec) in let _ = check_arities listdepkind in - mis_make_indrec env sigma listdepkind mib + mis_make_indrec env sigma listdepkind mib u | _ -> anomaly (Pp.str "build_induction_scheme expects a non empty list of inductive types") -let build_induction_scheme env sigma ind dep kind = - let (mib,mip) = lookup_mind_specif env ind in - List.hd (mis_make_indrec env sigma [(ind,mib,mip,dep,kind)] mib) +let build_induction_scheme env sigma pind dep kind = + let (mib,mip) = lookup_mind_specif env (fst pind) in + let sigma, l = mis_make_indrec env sigma [(pind,mib,mip,dep,kind)] mib (snd pind) in + sigma, List.hd l (*s Eliminations. *) @@ -564,11 +562,11 @@ let lookup_eliminator ind_sp s = try let cst =Global.constant_of_delta_kn (make_kn mp dp (Label.of_id id)) in let _ = Global.lookup_constant cst in - mkConst cst + ConstRef cst with Not_found -> (* Then try to get a user-defined eliminator in some other places *) (* using short name (e.g. for "eq_rec") *) - try constr_of_global (Nametab.locate (qualid_of_ident id)) + try Nametab.locate (qualid_of_ident id) with Not_found -> errorlabstrm "default_elim" (strbrk "Cannot find the elimination combinator " ++ diff --git a/pretyping/indrec.mli b/pretyping/indrec.mli index 6bcfac20e..54827281a 100644 --- a/pretyping/indrec.mli +++ b/pretyping/indrec.mli @@ -14,7 +14,7 @@ open Evd (** Errors related to recursors building *) type recursion_scheme_error = - | NotAllowedCaseAnalysis of (*isrec:*) bool * sorts * inductive + | NotAllowedCaseAnalysis of (*isrec:*) bool * sorts * pinductive | NotMutualInScheme of inductive * inductive exception RecursionSchemeError of recursion_scheme_error @@ -25,41 +25,38 @@ type dep_flag = bool (** Build a case analysis elimination scheme in some sort family *) -val build_case_analysis_scheme : env -> evar_map -> inductive -> - dep_flag -> sorts_family -> constr +val build_case_analysis_scheme : env -> evar_map -> pinductive -> + dep_flag -> sorts_family -> evar_map * constr (** Build a dependent case elimination predicate unless type is in Prop *) -val build_case_analysis_scheme_default : env -> evar_map -> inductive -> - sorts_family -> constr +val build_case_analysis_scheme_default : env -> evar_map -> pinductive -> + sorts_family -> evar_map * constr (** Builds a recursive induction scheme (Peano-induction style) in the same sort family as the inductive family; it is dependent if not in Prop *) -val build_induction_scheme : env -> evar_map -> inductive -> - dep_flag -> sorts_family -> constr +val build_induction_scheme : env -> evar_map -> pinductive -> + dep_flag -> sorts_family -> evar_map * constr (** Builds mutual (recursive) induction schemes *) val build_mutual_induction_scheme : - env -> evar_map -> (inductive * dep_flag * sorts_family) list -> constr list + env -> evar_map -> (pinductive * dep_flag * sorts_family) list -> evar_map * constr list (** Scheme combinators *) -(** [modify_sort_scheme s n c] modifies the quantification sort of - scheme c whose predicate is abstracted at position [n] of [c] *) +(** [weaken_sort_scheme env sigma eq s n c t] derives by subtyping from [c:t] + whose conclusion is quantified on [Type i] at position [n] of [t] a + scheme quantified on sort [s]. [set] asks for [s] be declared equal to [i], + otherwise just less or equal to [i]. *) -val modify_sort_scheme : sorts -> int -> constr -> constr - -(** [weaken_sort_scheme s n c t] derives by subtyping from [c:t] - whose conclusion is quantified on [Type] at position [n] of [t] a - scheme quantified on sort [s] *) - -val weaken_sort_scheme : sorts -> int -> constr -> types -> constr * types +val weaken_sort_scheme : env -> evar_map -> bool -> sorts -> int -> constr -> types -> + evar_map * types * constr (** Recursor names utilities *) -val lookup_eliminator : inductive -> sorts_family -> constr +val lookup_eliminator : inductive -> sorts_family -> Globnames.global_reference val elimination_suffix : sorts_family -> string val make_elimination_ident : Id.t -> sorts_family -> Id.t diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index 775795ce0..7e4d37b2e 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -19,32 +19,38 @@ open Declarations open Declareops open Environ open Reductionops +open Inductive (* The following three functions are similar to the ones defined in Inductive, but they expect an env *) -let type_of_inductive env ind = +let type_of_inductive env (ind,u) = let specif = Inductive.lookup_mind_specif env ind in - Inductive.type_of_inductive env specif + Inductive.type_of_inductive env (specif,u) (* Return type as quoted by the user *) -let type_of_constructor env cstr = +let type_of_constructor env (cstr,u) = let specif = Inductive.lookup_mind_specif env (inductive_of_constructor cstr) in - Inductive.type_of_constructor cstr specif + Inductive.type_of_constructor (cstr,u) specif + +let type_of_constructor_in_ctx env cstr = + let specif = + Inductive.lookup_mind_specif env (inductive_of_constructor cstr) in + Inductive.type_of_constructor_in_ctx cstr specif (* Return constructor types in user form *) -let type_of_constructors env ind = +let type_of_constructors env (ind,u as indu) = let specif = Inductive.lookup_mind_specif env ind in - Inductive.type_of_constructors ind specif + Inductive.type_of_constructors indu specif (* Return constructor types in normal form *) -let arities_of_constructors env ind = +let arities_of_constructors env (ind,u as indu) = let specif = Inductive.lookup_mind_specif env ind in - Inductive.arities_of_constructors ind specif + Inductive.arities_of_constructors indu specif (* [inductive_family] = [inductive_instance] applied to global parameters *) -type inductive_family = inductive * constr list +type inductive_family = pinductive * constr list let make_ind_family (mis, params) = (mis,params) let dest_ind_family (mis,params) = (mis,params) @@ -71,7 +77,7 @@ let lift_inductive_type n = liftn_inductive_type n 1 let substnl_ind_type l n = map_inductive_type (substnl l n) let mkAppliedInd (IndType ((ind,params), realargs)) = - applist (mkInd ind,params@realargs) + applist (mkIndU ind,params@realargs) (* Does not consider imbricated or mutually recursive types *) let mis_is_recursive_subset listind rarg = @@ -88,13 +94,14 @@ let mis_is_recursive (ind,mib,mip) = mis_is_recursive_subset (List.interval 0 (mib.mind_ntypes - 1)) mip.mind_recargs -let mis_nf_constructor_type (ind,mib,mip) j = +let mis_nf_constructor_type ((ind,u),mib,mip) j = let specif = mip.mind_nf_lc and ntypes = mib.mind_ntypes and nconstr = Array.length mip.mind_consnames in - let make_Ik k = mkInd ((fst ind),ntypes-k-1) in + let make_Ik k = mkIndU (((fst ind),ntypes-k-1),u) in if j > nconstr then error "Not enough constructors in the type."; - substl (List.init ntypes make_Ik) specif.(j-1) + let univsubst = make_inductive_subst mib u in + substl (List.init ntypes make_Ik) (subst_univs_constr univsubst specif.(j-1)) (* Arity of constructors excluding parameters and local defs *) @@ -139,9 +146,10 @@ let constructor_nrealhyps (ind,j) = let (mib,mip) = Global.lookup_inductive ind in mip.mind_consnrealdecls.(j-1) -let get_full_arity_sign env ind = +let get_full_arity_sign env (ind,u) = let (mib,mip) = Inductive.lookup_mind_specif env ind in - mip.mind_arity_ctxt + let subst = Inductive.make_inductive_subst mib u in + Vars.subst_univs_context subst mip.mind_arity_ctxt let nconstructors ind = let (mib,mip) = Inductive.lookup_mind_specif (Global.env()) ind in @@ -164,6 +172,10 @@ let inductive_has_local_defs ind = let inductive_nparams ind = (fst (Global.lookup_inductive ind)).mind_nparams +let inductive_params_ctxt (ind,u) = + let (mib,mip) = Global.lookup_inductive ind in + Inductive.inductive_params_ctxt (mib,u) + let inductive_nargs ind = let (mib,mip) = Global.lookup_inductive ind in (rel_context_length (mib.mind_params_ctxt), mip.mind_nrealargs_ctxt) @@ -189,7 +201,7 @@ let make_case_info env ind style = (*s Useful functions *) type constructor_summary = { - cs_cstr : constructor; + cs_cstr : pconstructor; cs_params : constr list; cs_nargs : int; cs_args : rel_context; @@ -219,21 +231,21 @@ let instantiate_params t args sign = | _ -> anomaly ~label:"instantiate_params" (Pp.str "type, ctxt and args mismatch") in inst [] t (List.rev sign,args) -let get_constructor (ind,mib,mip,params) j = +let get_constructor ((ind,u as indu),mib,mip,params) j = assert (j <= Array.length mip.mind_consnames); - let typi = mis_nf_constructor_type (ind,mib,mip) j in + let typi = mis_nf_constructor_type (indu,mib,mip) j in let typi = instantiate_params typi params mib.mind_params_ctxt in let (args,ccl) = decompose_prod_assum typi in let (_,allargs) = decompose_app ccl in let vargs = List.skipn (List.length params) allargs in - { cs_cstr = ith_constructor_of_inductive ind j; + { cs_cstr = (ith_constructor_of_inductive ind j,u); cs_params = params; cs_nargs = rel_context_length args; cs_args = args; cs_concl_realargs = Array.of_list vargs } let get_constructors env (ind,params) = - let (mib,mip) = Inductive.lookup_mind_specif env ind in + let (mib,mip) = Inductive.lookup_mind_specif env (fst ind) in Array.init (Array.length mip.mind_consnames) (fun j -> get_constructor (ind,mib,mip,params) (j+1)) @@ -255,8 +267,9 @@ let instantiate_context sign args = | _ -> anomaly (Pp.str "Signature/instance mismatch in inductive family") in aux [] (List.rev sign,args) -let get_arity env (ind,params) = +let get_arity env ((ind,u),params) = let (mib,mip) = Inductive.lookup_mind_specif env ind in + let univsubst = make_inductive_subst mib u in let parsign = (* Dynamically detect if called with an instance of recursively uniform parameter only or also of non recursively uniform @@ -267,15 +280,17 @@ let get_arity env (ind,params) = snd (List.chop nnonrecparams mib.mind_params_ctxt) else parsign in + let parsign = Vars.subst_univs_context univsubst parsign in let arproperlength = List.length mip.mind_arity_ctxt - List.length parsign in let arsign,_ = List.chop arproperlength mip.mind_arity_ctxt in let subst = instantiate_context parsign params in + let arsign = Vars.subst_univs_context univsubst arsign in (substl_rel_context subst arsign, Inductive.inductive_sort_family mip) (* Functions to build standard types related to inductive *) let build_dependent_constructor cs = applist - (mkConstruct cs.cs_cstr, + (mkConstructU cs.cs_cstr, (List.map (lift cs.cs_nargs) cs.cs_params) @(extended_rel_list 0 cs.cs_args)) @@ -283,7 +298,7 @@ let build_dependent_inductive env ((ind, params) as indf) = let arsign,_ = get_arity env indf in let nrealargs = List.length arsign in applist - (mkInd ind, + (mkIndU ind, (List.map (lift nrealargs) params)@(extended_rel_list 0 arsign)) (* builds the arity of an elimination predicate in sort [s] *) @@ -328,18 +343,18 @@ let find_mrectype env sigma c = let find_rectype env sigma c = let (t, l) = decompose_app (whd_betadeltaiota env sigma c) in match kind_of_term t with - | Ind ind -> + | Ind (ind,u as indu) -> let (mib,mip) = Inductive.lookup_mind_specif env ind in if mib.mind_nparams > List.length l then raise Not_found; let (par,rargs) = List.chop mib.mind_nparams l in - IndType((ind, par),rargs) + IndType((indu, par),rargs) | _ -> raise Not_found let find_inductive env sigma c = let (t, l) = decompose_app (whd_betadeltaiota env sigma c) in match kind_of_term t with | Ind ind - when (fst (Inductive.lookup_mind_specif env ind)).mind_finite -> + when (fst (Inductive.lookup_mind_specif env (fst ind))).mind_finite -> (ind, l) | _ -> raise Not_found @@ -347,7 +362,7 @@ let find_coinductive env sigma c = let (t, l) = decompose_app (whd_betadeltaiota env sigma c) in match kind_of_term t with | Ind ind - when not (fst (Inductive.lookup_mind_specif env ind)).mind_finite -> + when not (fst (Inductive.lookup_mind_specif env (fst ind))).mind_finite -> (ind, l) | _ -> raise Not_found @@ -414,7 +429,7 @@ let set_pattern_names env ind brv = let type_case_branches_with_names env indspec p c = let (ind,args) = indspec in - let (mib,mip as specif) = Inductive.lookup_mind_specif env ind in + let (mib,mip as specif) = Inductive.lookup_mind_specif env (fst ind) in let nparams = mib.mind_nparams in let (params,realargs) = List.chop nparams args in let lbrty = Inductive.build_branches_type ind specif params p in @@ -422,7 +437,7 @@ let type_case_branches_with_names env indspec p c = let conclty = Reduction.beta_appvect p (Array.of_list (realargs@[c])) in (* Adjust names *) if is_elim_predicate_explicitly_dependent env p (ind,params) then - (set_pattern_names env ind lbrty, conclty) + (set_pattern_names env (fst ind) lbrty, conclty) else (lbrty, conclty) (* Type of Case predicates *) @@ -436,40 +451,9 @@ let arity_of_case_predicate env (ind,params) dep k = (* Inferring the sort of parameters of a polymorphic inductive type knowing the sort of the conclusion *) -(* Compute the inductive argument types: replace the sorts - that appear in the type of the inductive by the sort of the - conclusion, and the other ones by fresh universes. *) -let rec instantiate_universes env scl is = function - | (_,Some _,_ as d)::sign, exp -> - d :: instantiate_universes env scl is (sign, exp) - | d::sign, None::exp -> - d :: instantiate_universes env scl is (sign, exp) - | (na,None,ty)::sign, Some u::exp -> - let ctx,_ = Reduction.dest_arity env ty in - let s = - (* Does the sort of parameter [u] appear in (or equal) - the sort of inductive [is] ? *) - if univ_depends u is then - scl (* constrained sort: replace by scl *) - else - (* unconstriained sort: replace by fresh universe *) - new_Type_sort() in - (na,None,mkArity(ctx,s)):: instantiate_universes env scl is (sign, exp) - | sign, [] -> sign (* Uniform parameters are exhausted *) - | [], _ -> assert false - -(* Does not deal with universes, but only with Set/Type distinction *) -let type_of_inductive_knowing_conclusion env mip conclty = - match mip.mind_arity with - | Monomorphic s -> - s.mind_user_arity - | Polymorphic ar -> - let _,scl = Reduction.dest_arity env conclty in - let ctx = List.rev mip.mind_arity_ctxt in - let ctx = - instantiate_universes - env scl ar.poly_level (ctx,ar.poly_param_levels) in - mkArity (List.rev ctx,scl) +let type_of_inductive_knowing_conclusion env ((mib,mip),u) conclty = + let subst = Inductive.make_inductive_subst mib u in + subst_univs_constr subst mip.mind_arity.mind_user_arity (***********************************************) (* Guard condition *) @@ -490,7 +474,3 @@ let control_only_guard env c = iter_constr_with_full_binders push_rel iter env c in iter env c - -let subst_inductive subst (kn,i as ind) = - let kn' = Mod_subst.subst_ind subst kn in - if kn == kn' then ind else (kn',i) diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli index 204f506a6..39451ec05 100644 --- a/pretyping/inductiveops.mli +++ b/pretyping/inductiveops.mli @@ -16,19 +16,20 @@ open Evd (** The following three functions are similar to the ones defined in Inductive, but they expect an env *) -val type_of_inductive : env -> inductive -> types +val type_of_inductive : env -> pinductive -> types (** Return type as quoted by the user *) -val type_of_constructor : env -> constructor -> types -val type_of_constructors : env -> inductive -> types array +val type_of_constructor : env -> pconstructor -> types +val type_of_constructor_in_ctx : env -> constructor -> types Univ.in_universe_context +val type_of_constructors : env -> pinductive -> types array (** Return constructor types in normal form *) -val arities_of_constructors : env -> inductive -> types array +val arities_of_constructors : env -> pinductive -> types array (** An inductive type with its parameters *) type inductive_family -val make_ind_family : inductive * constr list -> inductive_family -val dest_ind_family : inductive_family -> inductive * constr list +val make_ind_family : inductive puniverses * constr list -> inductive_family +val dest_ind_family : inductive_family -> inductive puniverses * constr list val map_ind_family : (constr -> constr) -> inductive_family -> inductive_family val liftn_inductive_family : int -> int -> inductive_family -> inductive_family val lift_inductive_family : int -> inductive_family -> inductive_family @@ -49,7 +50,7 @@ val mis_is_recursive_subset : int list -> wf_paths -> bool val mis_is_recursive : inductive * mutual_inductive_body * one_inductive_body -> bool val mis_nf_constructor_type : - inductive * mutual_inductive_body * one_inductive_body -> int -> constr + pinductive * mutual_inductive_body * one_inductive_body -> int -> constr (** {6 Extract information from an inductive name} @@ -69,6 +70,7 @@ val inductive_nargs_env : env -> inductive -> int * int (** @return nb of params without letin *) val inductive_nparams : inductive -> int +val inductive_params_ctxt : pinductive -> rel_context (** @return param + args without letin *) val mis_constructor_nargs : constructor -> int @@ -88,14 +90,14 @@ val constructor_nrealhyps : constructor -> int val mis_constructor_has_local_defs : constructor -> bool val inductive_has_local_defs : inductive -> bool -val get_full_arity_sign : env -> inductive -> rel_context +val get_full_arity_sign : env -> pinductive -> rel_context val allowed_sorts : env -> inductive -> sorts_family list (** Extract information from an inductive family *) type constructor_summary = { - cs_cstr : constructor; (* internal name of the constructor *) + cs_cstr : pconstructor; (* internal name of the constructor plus universes *) cs_params : constr list; (* parameters of the constructor in current ctx *) cs_nargs : int; (* length of arguments signature (letin included) *) cs_args : rel_context; (* signature of the arguments (letin included) *) @@ -103,7 +105,7 @@ type constructor_summary = { } val lift_constructor : int -> constructor_summary -> constructor_summary val get_constructor : - inductive * mutual_inductive_body * one_inductive_body * constr list -> + pinductive * mutual_inductive_body * one_inductive_body * constr list -> int -> constructor_summary val get_arity : env -> inductive_family -> rel_context * sorts_family val get_constructors : env -> inductive_family -> constructor_summary array @@ -114,11 +116,11 @@ val make_arity : env -> bool -> inductive_family -> sorts -> types val build_branch_type : env -> bool -> constr -> constructor_summary -> types (** Raise [Not_found] if not given an valid inductive type *) -val extract_mrectype : constr -> inductive * constr list -val find_mrectype : env -> evar_map -> types -> inductive * constr list +val extract_mrectype : constr -> pinductive * constr list +val find_mrectype : env -> evar_map -> types -> pinductive * constr list val find_rectype : env -> evar_map -> types -> inductive_type -val find_inductive : env -> evar_map -> types -> inductive * constr list -val find_coinductive : env -> evar_map -> types -> inductive * constr list +val find_inductive : env -> evar_map -> types -> pinductive * constr list +val find_coinductive : env -> evar_map -> types -> pinductive * constr list (********************) @@ -127,7 +129,7 @@ val arity_of_case_predicate : env -> inductive_family -> bool -> sorts -> types val type_case_branches_with_names : - env -> inductive * constr list -> constr -> constr -> + env -> pinductive * constr list -> constr -> constr -> types array * types (** Annotation for cases *) @@ -140,9 +142,7 @@ i*) (********************) val type_of_inductive_knowing_conclusion : - env -> one_inductive_body -> types -> types + env -> Inductive.mind_specif puniverses -> types -> types (********************) val control_only_guard : env -> types -> unit - -val subst_inductive : Mod_subst.substitution -> inductive -> inductive diff --git a/pretyping/namegen.ml b/pretyping/namegen.ml index d4435489a..c6c21f025 100644 --- a/pretyping/namegen.ml +++ b/pretyping/namegen.ml @@ -76,9 +76,10 @@ let hdchar env c = | LetIn (_,_,_,c) -> hdrec (k+1) c | Cast (c,_,_) -> hdrec k c | App (f,l) -> hdrec k f - | Const kn -> lowercase_first_char (Label.to_id (con_label kn)) - | Ind x -> lowercase_first_char (basename_of_global (IndRef x)) - | Construct x -> lowercase_first_char (basename_of_global (ConstructRef x)) + | Proj (kn,_) + | Const (kn,_) -> lowercase_first_char (Label.to_id (con_label kn)) + | Ind (x,_) -> lowercase_first_char (basename_of_global (IndRef x)) + | Construct (x,_) -> lowercase_first_char (basename_of_global (ConstructRef x)) | Var id -> lowercase_first_char id | Sort s -> sort_hdchar s | Rel n -> diff --git a/pretyping/nativenorm.ml b/pretyping/nativenorm.ml index b635229cf..829fa106c 100644 --- a/pretyping/nativenorm.ml +++ b/pretyping/nativenorm.ml @@ -59,7 +59,7 @@ let find_rectype_a env c = (* Instantiate inductives and parameters in constructor type *) let type_constructor mind mib typ params = - let s = ind_subst mind mib in + let s = ind_subst mind mib Univ.Instance.empty (* FIXME *)in let ctyp = substl s typ in let nparams = Array.length params in if Int.equal nparams 0 then ctyp @@ -67,7 +67,7 @@ let type_constructor mind mib typ params = let _,ctyp = decompose_prod_n nparams ctyp in substl (List.rev (Array.to_list params)) ctyp -let construct_of_constr_notnative const env tag (mind, _ as ind) allargs = +let construct_of_constr_notnative const env tag (mind, _ as ind) u allargs = let mib,mip = lookup_mind_specif env ind in let nparams = mib.mind_nparams in let params = Array.sub allargs 0 nparams in @@ -80,14 +80,14 @@ let construct_of_constr_notnative const env tag (mind, _ as ind) allargs = with Not_found -> let i = invert_tag const tag mip.mind_reloc_tbl in let ctyp = type_constructor mind mib (mip.mind_nf_lc.(i-1)) params in - (mkApp(mkConstruct(ind,i), params), ctyp) + (mkApp(mkConstructU((ind,i),u), params), ctyp) let construct_of_constr const env tag typ = let t, l = app_type env typ in match kind_of_term t with - | Ind ind -> - construct_of_constr_notnative const env tag ind l + | Ind (ind,u) -> + construct_of_constr_notnative const env tag ind u l | _ -> assert false let construct_of_constr_const env tag typ = @@ -109,9 +109,9 @@ let build_branches_type env (mind,_ as _ind) mib mip params dep p = let codom = let papp = mkApp(lift (List.length decl) p,crealargs) in if dep then - let cstr = ith_constructor_of_inductive ind (i+1) in + let cstr = ith_constructor_of_inductive (fst ind) (i+1) in let relargs = Array.init carity (fun i -> mkRel (carity-i)) in - let dep_cstr = mkApp(mkApp(mkConstruct cstr,params),relargs) in + let dep_cstr = mkApp(mkApp(mkConstructU (cstr,snd ind),params),relargs) in mkApp(papp,[|dep_cstr|]) else papp in @@ -266,6 +266,9 @@ and nf_atom env atom = mkProd(n,dom,codom) | Ameta (mv,_) -> mkMeta mv | Aevar (ev,_) -> mkEvar ev + | Aproj(p,c) -> + let c = nf_accu env c in + mkProj(p,c) | _ -> fst (nf_atom_type env atom) and nf_atom_type env atom = @@ -274,17 +277,17 @@ and nf_atom_type env atom = let n = (nb_rel env - i) in mkRel n, type_of_rel env n | Aconstant cst -> - mkConst cst, Typeops.type_of_constant env cst + mkConst cst, fst (Typeops.type_of_constant env (cst,Univ.Instance.empty)) (* FIXME *) | Aind ind -> - mkInd ind, Inductiveops.type_of_inductive env ind + mkInd ind, Inductiveops.type_of_inductive env (ind,Univ.Instance.empty) | Asort s -> mkSort s, type_of_sort s | Avar id -> mkVar id, type_of_var env id | Acase(ans,accu,p,bs) -> let a,ta = nf_accu_type env accu in - let (mind,_ as ind),allargs = find_rectype_a env ta in - let (mib,mip) = Inductive.lookup_mind_specif env ind in + let ((mind,_),u as ind),allargs = find_rectype_a env ta in + let (mib,mip) = Inductive.lookup_mind_specif env (fst ind) in let nparams = mib.mind_nparams in let params,realargs = Array.chop nparams allargs in let pT = @@ -293,7 +296,7 @@ and nf_atom_type env atom = let pT = whd_betadeltaiota env pT in let dep, p = nf_predicate env ind mip params p pT in (* Calcul du type des branches *) - let btypes = build_branches_type env ind mib mip params dep p in + let btypes = build_branches_type env (fst ind) mib mip params dep p in (* calcul des branches *) let bsw = branch_of_switch (nb_rel env) ans bs in let mkbranch i v = @@ -336,6 +339,12 @@ and nf_atom_type env atom = | Ameta(mv,ty) -> let ty = nf_type env ty in mkMeta mv, ty + | Aproj(p,c) -> + let c,tc = nf_accu_type env c in + let cj = make_judge c tc in + let uj = Typeops.judge_of_projection env p cj in + uj.uj_val, uj.uj_type + and nf_predicate env ind mip params v pT = match kind_of_value v, kind_of_term pT with @@ -358,7 +367,7 @@ and nf_predicate env ind mip params v pT = let n = mip.mind_nrealargs in let rargs = Array.init n (fun i -> mkRel (n-i)) in let params = if Int.equal n 0 then params else Array.map (lift n) params in - let dom = mkApp(mkInd ind,Array.append params rargs) in + let dom = mkApp(mkIndU ind,Array.append params rargs) in let body = nf_type (push_rel (name,None,dom) env) vb in true, mkLambda(name,dom,body) | _, _ -> false, nf_type env v diff --git a/pretyping/patternops.ml b/pretyping/patternops.ml index cc13d342a..8557953cc 100644 --- a/pretyping/patternops.ml +++ b/pretyping/patternops.ml @@ -81,6 +81,7 @@ and rec_declaration_eq (n1, c1, r1) (n2, c2, r2) = let rec occur_meta_pattern = function | PApp (f,args) -> (occur_meta_pattern f) || (Array.exists occur_meta_pattern args) + | PProj (_,arg) -> occur_meta_pattern arg | PLambda (na,t,c) -> (occur_meta_pattern t) || (occur_meta_pattern c) | PProd (na,t,c) -> (occur_meta_pattern t) || (occur_meta_pattern c) | PLetIn (na,t,c) -> (occur_meta_pattern t) || (occur_meta_pattern c) @@ -105,6 +106,7 @@ let rec head_pattern_bound t = | PCase (_,p,c,br) -> head_pattern_bound c | PRef r -> r | PVar id -> VarRef id + | PProj (p,c) -> ConstRef p | PEvar _ | PRel _ | PMeta _ | PSoApp _ | PSort _ | PFix _ -> raise BoundPattern (* Perhaps they were arguments, but we don't beta-reduce *) @@ -112,9 +114,9 @@ let rec head_pattern_bound t = | PCoFix _ -> anomaly ~label:"head_pattern_bound" (Pp.str "not a type") let head_of_constr_reference c = match kind_of_term c with - | Const sp -> ConstRef sp - | Construct sp -> ConstructRef sp - | Ind sp -> IndRef sp + | Const (sp,_) -> ConstRef sp + | Construct (sp,_) -> ConstructRef sp + | Ind (sp,_) -> IndRef sp | Var id -> VarRef id | _ -> anomaly (Pp.str "Not a rigid reference") @@ -145,9 +147,11 @@ let pattern_of_constr sigma t = with | Some n -> PSoApp (n,Array.to_list (Array.map pattern_of_constr a)) | None -> PApp (pattern_of_constr f,Array.map (pattern_of_constr) a)) - | Const sp -> PRef (ConstRef (constant_of_kn(canonical_con sp))) - | Ind sp -> PRef (canonical_gr (IndRef sp)) - | Construct sp -> PRef (canonical_gr (ConstructRef sp)) + | Const (sp,u) -> PRef (ConstRef (constant_of_kn(canonical_con sp))) + | Ind (sp,u) -> PRef (canonical_gr (IndRef sp)) + | Construct (sp,u) -> PRef (canonical_gr (ConstructRef sp)) + | Proj (p, c) -> + PProj (constant_of_kn(canonical_con p), pattern_of_constr c) | Evar (evk,ctxt as ev) -> (match snd (Evd.evar_source evk sigma) with | Evar_kinds.MatchingVar (b,id) -> @@ -185,6 +189,7 @@ let map_pattern_with_binders g f l = function | PIf (c,b1,b2) -> PIf (f l c,f l b1,f l b2) | PCase (ci,po,p,pl) -> PCase (ci,f l po,f l p, List.map (fun (i,n,c) -> (i,n,f l c)) pl) + | PProj (p,pc) -> PProj (p, f l pc) (* Non recursive *) | (PVar _ | PEvar _ | PRel _ | PRef _ | PSort _ | PMeta _ (* Bound to terms *) @@ -240,6 +245,12 @@ let rec subst_pattern subst pat = | PVar _ | PEvar _ | PRel _ -> pat + | PProj (p,c) -> + let p',t = subst_global subst (ConstRef p) in + let p' = destConstRef p' in + let c' = subst_pattern subst c in + if p' == p && c' == c then pat else + PProj(p',c') | PApp (f,args) -> let f' = subst_pattern subst f in let args' = Array.smartmap (subst_pattern subst) args in @@ -274,7 +285,7 @@ let rec subst_pattern subst pat = PIf (c',c1',c2') | PCase (cip,typ,c,branches) -> let ind = cip.cip_ind in - let ind' = Option.smartmap (Inductiveops.subst_inductive subst) ind in + let ind' = Option.smartmap (subst_ind subst) ind in let cip' = if ind' == ind then cip else { cip with cip_ind = ind' } in let typ' = subst_pattern subst typ in let c' = subst_pattern subst c in @@ -308,11 +319,13 @@ let rec pat_of_raw metas vars = function with Not_found -> PVar id) | GPatVar (_,(false,n)) -> metas := n::!metas; PMeta (Some n) - | GRef (_,gr) -> + | GRef (_,gr,_) -> PRef (canonical_gr gr) (* Hack pour ne pas réécrire une interprétation complète des patterns*) | GApp (_, GPatVar (_,(true,n)), cl) -> metas := n::!metas; PSoApp (n, List.map (pat_of_raw metas vars) cl) + | GProj (_, p, c) -> + PProj (p, pat_of_raw metas vars c) | GApp (_,c,cl) -> PApp (pat_of_raw metas vars c, Array.of_list (List.map (pat_of_raw metas vars) cl)) diff --git a/pretyping/pretype_errors.ml b/pretyping/pretype_errors.ml index 8ffd53055..003665db5 100644 --- a/pretyping/pretype_errors.ml +++ b/pretyping/pretype_errors.ml @@ -21,7 +21,7 @@ type unification_error = | ConversionFailed of env * constr * constr | MetaOccurInBody of existential_key | InstanceNotSameType of existential_key * env * types * types - | UnifUnivInconsistency + | UnifUnivInconsistency of Univ.univ_inconsistency type pretype_error = (* Old Case *) diff --git a/pretyping/pretype_errors.mli b/pretyping/pretype_errors.mli index 8e98f6307..d9ee969e3 100644 --- a/pretyping/pretype_errors.mli +++ b/pretyping/pretype_errors.mli @@ -22,7 +22,7 @@ type unification_error = | ConversionFailed of env * constr * constr | MetaOccurInBody of existential_key | InstanceNotSameType of existential_key * env * types * types - | UnifUnivInconsistency + | UnifUnivInconsistency of Univ.univ_inconsistency type pretype_error = (** Old Case *) @@ -70,7 +70,7 @@ val error_case_not_inductive_loc : val error_ill_formed_branch_loc : Loc.t -> env -> Evd.evar_map -> - constr -> constructor -> constr -> constr -> 'b + constr -> pconstructor -> constr -> constr -> 'b val error_number_branches_loc : Loc.t -> env -> Evd.evar_map -> diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index c66221e5f..7777de514 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -93,10 +93,10 @@ let ((constr_in : constr -> Dyn.t), (** Miscellaneous interpretation functions *) -let interp_sort = function - | GProp -> Prop Null - | GSet -> Prop Pos - | GType _ -> new_Type_sort () +let interp_sort evd = function + | GProp -> evd, Prop Null + | GSet -> evd, Prop Pos + | GType _ -> new_sort_variable univ_rigid evd let interp_elimination_sort = function | GProp -> InProp @@ -157,7 +157,7 @@ let check_extra_evars_are_solved env initial_sigma sigma = let check_evars_are_solved env initial_sigma sigma = check_typeclasses_instances_are_solved env sigma; - check_problems_are_solved sigma; + check_problems_are_solved env sigma; check_extra_evars_are_solved env initial_sigma sigma (* Try typeclasses, hooks, unification heuristics ... *) @@ -179,21 +179,6 @@ let process_inference_flags flags env initial_sigma (sigma,c) = (* Allow references to syntaxically inexistent variables (i.e., if applied on an inductive) *) let allow_anonymous_refs = ref false -let evd_comb0 f evdref = - let (evd',x) = f !evdref in - evdref := evd'; - x - -let evd_comb1 f evdref x = - let (evd',y) = f !evdref x in - evdref := evd'; - y - -let evd_comb2 f evdref x y = - let (evd',z) = f !evdref x y in - evdref := evd'; - z - (* Utilisé pour inférer le prédicat des Cases *) (* Semble exagérement fort *) (* Faudra préférer une unification entre les types de toutes les clauses *) @@ -236,7 +221,8 @@ let protected_get_type_of env sigma c = (str "Cannot reinterpret " ++ quote (print_constr c) ++ str " in the current environment.") -let pretype_id loc env sigma (lvar,unbndltacvars) id = +let pretype_id loc env evdref (lvar,unbndltacvars) id = + let sigma = !evdref in (* Look for the binder of [id] *) try let (n,_,typ) = lookup_rel_id id (rel_context env) in @@ -257,6 +243,12 @@ let pretype_id loc env sigma (lvar,unbndltacvars) id = (* Check if [id] is a section or goal variable *) try let (_,_,typ) = lookup_named id env in + (* let _ = *) + (* try *) + (* let ctx = Decls.variable_context id in *) + (* evdref := Evd.merge_context_set univ_rigid !evdref ctx; *) + (* with Not_found -> () *) + (* in *) { uj_val = mkVar id; uj_type = typ } with Not_found -> (* [id] not found, standard error message *) @@ -268,18 +260,26 @@ let evar_kind_of_term sigma c = (*************************************************************************) (* Main pretyping function *) -let pretype_ref loc evdref env = function +(* Check with universe list? *) +let pretype_global rigid env evd gr us = Evd.fresh_global ~rigid env evd gr + +let pretype_ref loc evdref env ref us = + match ref with | VarRef id -> (* Section variable *) - (try let (_,_,ty) = lookup_named id env in make_judge (mkVar id) ty + (try let (_,_,ty) = lookup_named id env in + (* let ctx = Decls.variable_context id in *) + (* evdref := Evd.merge_context_set univ_rigid !evdref ctx; *) + make_judge (mkVar id) ty with Not_found -> (* This may happen if env is a goal env and section variables have been cleared - section variables should be different from goal variables *) Pretype_errors.error_var_not_found_loc loc id) | ref -> - let c = constr_of_global ref in - make_judge c (Retyping.get_type_of env Evd.empty c) + let evd, c = pretype_global univ_flexible env !evdref ref us in + evdref := evd; + make_judge c (Retyping.get_type_of env evd c) let pretype_sort evdref = function | GProp -> judge_of_prop @@ -287,27 +287,37 @@ let pretype_sort evdref = function | GType _ -> evd_comb0 judge_of_new_Type evdref let new_type_evar evdref env loc = - evd_comb0 (fun evd -> Evarutil.new_type_evar evd env ~src:(loc,Evar_kinds.InternalHole)) evdref + let e, s = + evd_comb0 (fun evd -> Evarutil.new_type_evar univ_flexible_alg evd env ~src:(loc,Evar_kinds.InternalHole)) evdref + in e + +let get_projection env cst = + let cb = lookup_constant cst env in + match cb.Declarations.const_proj with + | Some {Declarations.proj_ind = mind; proj_npars = n; proj_arg = m; proj_type = ty} -> + (cst,mind,n,m,ty) + | None -> raise Not_found let (f_genarg_interp, genarg_interp_hook) = Hook.make () (* [pretype tycon env evdref lvar lmeta cstr] attempts to type [cstr] *) (* in environment [env], with existential variables [evdref] and *) (* the type constraint tycon *) + let rec pretype resolve_tc (tycon : type_constraint) env evdref lvar t = let inh_conv_coerce_to_tycon = inh_conv_coerce_to_tycon resolve_tc in let pretype_type = pretype_type resolve_tc in let pretype = pretype resolve_tc in match t with - | GRef (loc,ref) -> + | GRef (loc,ref,u) -> inh_conv_coerce_to_tycon loc env evdref - (pretype_ref loc evdref env ref) + (pretype_ref loc evdref env ref u) tycon | GVar (loc, id) -> - inh_conv_coerce_to_tycon loc env evdref - (pretype_id loc env !evdref lvar id) - tycon + inh_conv_coerce_to_tycon loc env evdref + (pretype_id loc env evdref lvar id) + tycon | GEvar (loc, evk, instopt) -> (* Ne faudrait-il pas s'assurer que hyps est bien un @@ -321,12 +331,12 @@ let rec pretype resolve_tc (tycon : type_constraint) env evdref lvar t = inh_conv_coerce_to_tycon loc env evdref j tycon | GPatVar (loc,(someta,n)) -> - let ty = - match tycon with - | Some ty -> ty - | None -> new_type_evar evdref env loc in - let k = Evar_kinds.MatchingVar (someta,n) in - { uj_val = e_new_evar evdref env ~src:(loc,k) ty; uj_type = ty } + let ty = + match tycon with + | Some ty -> ty + | None -> new_type_evar evdref env loc in + let k = Evar_kinds.MatchingVar (someta,n) in + { uj_val = e_new_evar evdref env ~src:(loc,k) ty; uj_type = ty } | GHole (loc, k, None) -> let ty = @@ -348,178 +358,216 @@ let rec pretype resolve_tc (tycon : type_constraint) env evdref lvar t = { uj_val = c; uj_type = ty } | GRec (loc,fixkind,names,bl,lar,vdef) -> - let rec type_bl env ctxt = function - [] -> ctxt - | (na,bk,None,ty)::bl -> - let ty' = pretype_type empty_valcon env evdref lvar ty in - let dcl = (na,None,ty'.utj_val) in - type_bl (push_rel dcl env) (add_rel_decl dcl ctxt) bl - | (na,bk,Some bd,ty)::bl -> - let ty' = pretype_type empty_valcon env evdref lvar ty in - let bd' = pretype (mk_tycon ty'.utj_val) env evdref lvar ty in - let dcl = (na,Some bd'.uj_val,ty'.utj_val) in - type_bl (push_rel dcl env) (add_rel_decl dcl ctxt) bl in - let ctxtv = Array.map (type_bl env empty_rel_context) bl in - let larj = - Array.map2 - (fun e ar -> - pretype_type empty_valcon (push_rel_context e env) evdref lvar ar) - ctxtv lar in - let lara = Array.map (fun a -> a.utj_val) larj in - let ftys = Array.map2 (fun e a -> it_mkProd_or_LetIn a e) ctxtv lara in - let nbfix = Array.length lar in - let names = Array.map (fun id -> Name id) names in - let _ = - match tycon with - | Some t -> - let fixi = match fixkind with - | GFix (vn,i) -> i - | GCoFix i -> i - in e_conv env evdref ftys.(fixi) t - | None -> true - in - (* Note: bodies are not used by push_rec_types, so [||] is safe *) - let newenv = push_rec_types (names,ftys,[||]) env in - let vdefj = - Array.map2_i - (fun i ctxt def -> + let rec type_bl env ctxt = function + [] -> ctxt + | (na,bk,None,ty)::bl -> + let ty' = pretype_type empty_valcon env evdref lvar ty in + let dcl = (na,None,ty'.utj_val) in + type_bl (push_rel dcl env) (add_rel_decl dcl ctxt) bl + | (na,bk,Some bd,ty)::bl -> + let ty' = pretype_type empty_valcon env evdref lvar ty in + let bd' = pretype (mk_tycon ty'.utj_val) env evdref lvar ty in + let dcl = (na,Some bd'.uj_val,ty'.utj_val) in + type_bl (push_rel dcl env) (add_rel_decl dcl ctxt) bl in + let ctxtv = Array.map (type_bl env empty_rel_context) bl in + let larj = + Array.map2 + (fun e ar -> + pretype_type empty_valcon (push_rel_context e env) evdref lvar ar) + ctxtv lar in + let lara = Array.map (fun a -> a.utj_val) larj in + let ftys = Array.map2 (fun e a -> it_mkProd_or_LetIn a e) ctxtv lara in + let nbfix = Array.length lar in + let names = Array.map (fun id -> Name id) names in + let _ = + match tycon with + | Some t -> + let fixi = match fixkind with + | GFix (vn,i) -> i + | GCoFix i -> i + in e_conv env evdref ftys.(fixi) t + | None -> true + in + (* Note: bodies are not used by push_rec_types, so [||] is safe *) + let newenv = push_rec_types (names,ftys,[||]) env in + let vdefj = + Array.map2_i + (fun i ctxt def -> (* we lift nbfix times the type in tycon, because of * the nbfix variables pushed to newenv *) - let (ctxt,ty) = - decompose_prod_n_assum (rel_context_length ctxt) - (lift nbfix ftys.(i)) in - let nenv = push_rel_context ctxt newenv in - let j = pretype (mk_tycon ty) nenv evdref lvar def in - { uj_val = it_mkLambda_or_LetIn j.uj_val ctxt; - uj_type = it_mkProd_or_LetIn j.uj_type ctxt }) - ctxtv vdef in - evar_type_fixpoint loc env evdref names ftys vdefj; - let ftys = Array.map (nf_evar !evdref) ftys in - let fdefs = Array.map (fun x -> nf_evar !evdref (j_val x)) vdefj in - let fixj = match fixkind with - | GFix (vn,i) -> + let (ctxt,ty) = + decompose_prod_n_assum (rel_context_length ctxt) + (lift nbfix ftys.(i)) in + let nenv = push_rel_context ctxt newenv in + let j = pretype (mk_tycon ty) nenv evdref lvar def in + { uj_val = it_mkLambda_or_LetIn j.uj_val ctxt; + uj_type = it_mkProd_or_LetIn j.uj_type ctxt }) + ctxtv vdef in + evar_type_fixpoint loc env evdref names ftys vdefj; + let ftys = Array.map (nf_evar !evdref) ftys in + let fdefs = Array.map (fun x -> nf_evar !evdref (j_val x)) vdefj in + let fixj = match fixkind with + | GFix (vn,i) -> (* First, let's find the guard indexes. *) (* If recursive argument was not given by user, we try all args. An earlier approach was to look only for inductive arguments, but doing it properly involves delta-reduction, and it finally doesn't seem worth the effort (except for huge mutual fixpoints ?) *) - let possible_indexes = - Array.to_list (Array.mapi - (fun i (n,_) -> match n with - | Some n -> [n] - | None -> List.map_i (fun i _ -> i) 0 ctxtv.(i)) - vn) - in - let fixdecls = (names,ftys,fdefs) in - let indexes = search_guard loc env possible_indexes fixdecls in - make_judge (mkFix ((indexes,i),fixdecls)) ftys.(i) - | GCoFix i -> - let cofix = (i,(names,ftys,fdefs)) in - (try check_cofix env cofix - with reraise -> - let e = Errors.push reraise in Loc.raise loc e); - make_judge (mkCoFix cofix) ftys.(i) - in + let possible_indexes = + Array.to_list (Array.mapi + (fun i (n,_) -> match n with + | Some n -> [n] + | None -> List.map_i (fun i _ -> i) 0 ctxtv.(i)) + vn) + in + let fixdecls = (names,ftys,fdefs) in + let indexes = search_guard loc env possible_indexes fixdecls in + make_judge (mkFix ((indexes,i),fixdecls)) ftys.(i) + | GCoFix i -> + let cofix = (i,(names,ftys,fdefs)) in + (try check_cofix env cofix + with reraise -> + let e = Errors.push reraise in Loc.raise loc e); + make_judge (mkCoFix cofix) ftys.(i) + in inh_conv_coerce_to_tycon loc env evdref fixj tycon | GSort (loc,s) -> - let j = pretype_sort evdref s in - inh_conv_coerce_to_tycon loc env evdref j tycon + let j = pretype_sort evdref s in + inh_conv_coerce_to_tycon loc env evdref j tycon + + | GProj (loc, p, arg) -> + let (cst, mind, n, m, ty) = + try get_projection env p + with Not_found -> + user_err_loc (loc,"",str "Not a projection") + in + let mk_ty k = + let ind = + Evarutil.evd_comb1 (Evd.fresh_inductive_instance env) evdref (mind,0) + in + let args = + let ctx = smash_rel_context (Inductiveops.inductive_params_ctxt ind) in + List.fold_right (fun (n, b, ty) (* par *)args -> + let ty = substl args ty in + let ev = e_new_evar evdref env ~src:(loc,k) ty in + ev :: args) ctx [] + (* let j = pretype (mk_tycon ty) env evdref lvar par in *) + (* j.uj_val :: args) ctx pars [] *) + in (ind, List.rev args) + in + let argtycon = + match arg with + (** FIXME ? *) + | GHole (loc, k, _) -> (* Typeclass projection application: + create the necessary type constraint *) + let ind, args = mk_ty k in + mk_tycon (applist (mkIndU ind, args)) + | _ -> empty_tycon + in + let recty = pretype argtycon env evdref lvar arg in + let recty, ((ind,u), pars) = + try + let IndType (indf, _ (*[]*)) = + find_rectype env !evdref recty.uj_type + in recty, dest_ind_family indf + with Not_found -> + (match argtycon with + | Some ty -> assert false + (* let IndType (indf, _) = find_rectype env !evdref ty in *) + (* recty, dest_ind_family indf *) + | None -> + let ind, args = mk_ty Evar_kinds.InternalHole in + let j' = + inh_conv_coerce_to_tycon loc env evdref recty + (mk_tycon (applist (mkIndU ind, args))) in + j', (ind, args)) + in + let usubst = make_inductive_subst (fst (lookup_mind_specif env ind)) u in + let ty = Vars.subst_univs_constr usubst ty in + let ty = substl (recty.uj_val :: List.rev pars) ty in + let j = {uj_val = mkProj (cst,recty.uj_val); uj_type = ty} in + inh_conv_coerce_to_tycon loc env evdref j tycon | GApp (loc,f,args) -> - let fj = pretype empty_tycon env evdref lvar f in - let floc = loc_of_glob_constr f in - let length = List.length args in - let candargs = + let fj = pretype empty_tycon env evdref lvar f in + let floc = loc_of_glob_constr f in + let length = List.length args in + let candargs = (* Bidirectional typechecking hint: parameters of a constructor are completely determined by a typing constraint *) - if Flags.is_program_mode () && length > 0 && isConstruct fj.uj_val then - match tycon with - | None -> [] - | Some ty -> - let (ind, i) = destConstruct fj.uj_val in - let npars = inductive_nparams ind in - if Int.equal npars 0 then [] - else - try - (* Does not treat partially applied constructors. *) - let ty = evd_comb1 (Coercion.inh_coerce_to_prod loc env) evdref ty in - let IndType (indf, args) = find_rectype env !evdref ty in - let (ind',pars) = dest_ind_family indf in - if eq_ind ind ind' then pars - else (* Let the usual code throw an error *) [] - with Not_found -> [] - else [] - in - let rec apply_rec env n resj candargs = function - | [] -> resj - | c::rest -> - let argloc = loc_of_glob_constr c in - let resj = evd_comb1 (Coercion.inh_app_fun resolve_tc env) evdref resj in - let resty = whd_betadeltaiota env !evdref resj.uj_type in - match kind_of_term resty with - | Prod (na,c1,c2) -> - let hj = pretype (mk_tycon c1) env evdref lvar c in - let candargs, ujval = - match candargs with - | [] -> [], j_val hj - | arg :: args -> - if e_conv env evdref (j_val hj) arg then - args, nf_evar !evdref (j_val hj) - else [], j_val hj - in - let value, typ = applist (j_val resj, [ujval]), subst1 ujval c2 in - apply_rec env (n+1) - { uj_val = value; - uj_type = typ } - candargs rest - - | _ -> - let hj = pretype empty_tycon env evdref lvar c in - error_cant_apply_not_functional_loc - (Loc.merge floc argloc) env !evdref - resj [hj] - in - let resj = apply_rec env 1 fj candargs args in - let resj = - match evar_kind_of_term !evdref resj.uj_val with - | App (f,args) -> - let f = whd_evar !evdref f in - begin match kind_of_term f with - | Ind _ | Const _ - when isInd f || has_polymorphic_type (destConst f) - -> - let sigma = !evdref in - let c = mkApp (f,Array.map (whd_evar sigma) args) in - let t = Retyping.get_type_of env sigma c in - make_judge c (* use this for keeping evars: resj.uj_val *) t - | _ -> resj end - | _ -> resj in - inh_conv_coerce_to_tycon loc env evdref resj tycon + if Flags.is_program_mode () && length > 0 && isConstruct fj.uj_val then + match tycon with + | None -> [] + | Some ty -> + let ((ind, i), u) = destConstruct fj.uj_val in + let npars = inductive_nparams ind in + if Int.equal npars 0 then [] + else + try + let ty = evd_comb1 (Coercion.inh_coerce_to_prod loc env) evdref ty in + let IndType (indf, args) = find_rectype env !evdref ty in + let ((ind',u'),pars) = dest_ind_family indf in + if eq_ind ind ind' then pars + else (* Let the usual code throw an error *) [] + with Not_found -> [] + else [] + in + let rec apply_rec env n resj candargs = function + | [] -> resj + | c::rest -> + let argloc = loc_of_glob_constr c in + let resj = evd_comb1 (Coercion.inh_app_fun resolve_tc env) evdref resj in + let resty = whd_betadeltaiota env !evdref resj.uj_type in + match kind_of_term resty with + | Prod (na,c1,c2) -> + let hj = pretype (mk_tycon c1) env evdref lvar c in + let candargs, ujval = + match candargs with + | [] -> [], j_val hj + | arg :: args -> + if e_conv env evdref (j_val hj) arg then + args, nf_evar !evdref (j_val hj) + else [], j_val hj + in + let value, typ = applist (j_val resj, [ujval]), subst1 ujval c2 in + apply_rec env (n+1) + { uj_val = value; + uj_type = typ } + candargs rest + + | _ -> + let hj = pretype empty_tycon env evdref lvar c in + error_cant_apply_not_functional_loc + (Loc.merge floc argloc) env !evdref + resj [hj] + in + let resj = apply_rec env 1 fj candargs args in + inh_conv_coerce_to_tycon loc env evdref resj tycon | GLambda(loc,name,bk,c1,c2) -> - let tycon' = evd_comb1 - (fun evd tycon -> - match tycon with - | None -> evd, tycon - | Some ty -> - let evd, ty' = Coercion.inh_coerce_to_prod loc env evd ty in - evd, Some ty') - evdref tycon - in - let (name',dom,rng) = evd_comb1 (split_tycon loc env) evdref tycon' in - let dom_valcon = valcon_of_tycon dom in - let j = pretype_type dom_valcon env evdref lvar c1 in - let var = (name,None,j.utj_val) in - let j' = pretype rng (push_rel var env) evdref lvar c2 in - let resj = judge_of_abstraction env (orelse_name name name') j j' in - inh_conv_coerce_to_tycon loc env evdref resj tycon + let tycon' = evd_comb1 + (fun evd tycon -> + match tycon with + | None -> evd, tycon + | Some ty -> + let evd, ty' = Coercion.inh_coerce_to_prod loc env evd ty in + evd, Some ty') + evdref tycon + in + let (name',dom,rng) = evd_comb1 (split_tycon loc env) evdref tycon' in + let dom_valcon = valcon_of_tycon dom in + let j = pretype_type dom_valcon env evdref lvar c1 in + let var = (name,None,j.utj_val) in + let j' = pretype rng (push_rel var env) evdref lvar c2 in + let resj = judge_of_abstraction env (orelse_name name name') j j' in + inh_conv_coerce_to_tycon loc env evdref resj tycon | GProd(loc,name,bk,c1,c2) -> - let j = pretype_type empty_valcon env evdref lvar c1 in - let j' = match name with + let j = pretype_type empty_valcon env evdref lvar c1 in + let j' = match name with | Anonymous -> let j = pretype_type empty_valcon env evdref lvar c2 in { j with utj_val = lift 1 j.utj_val } @@ -527,212 +575,208 @@ let rec pretype resolve_tc (tycon : type_constraint) env evdref lvar t = let var = (name,j.utj_val) in let env' = push_rel_assum var env in pretype_type empty_valcon env' evdref lvar c2 - in - let resj = - try judge_of_product env name j j' - with TypeError _ as e -> let e = Errors.push e in Loc.raise loc e in - inh_conv_coerce_to_tycon loc env evdref resj tycon + in + let resj = + try judge_of_product env name j j' + with TypeError _ as e -> let e = Errors.push e in Loc.raise loc e in + inh_conv_coerce_to_tycon loc env evdref resj tycon | GLetIn(loc,name,c1,c2) -> - let j = - match c1 with - | GCast (loc, c, CastConv t) -> - let tj = pretype_type empty_valcon env evdref lvar t in - pretype (mk_tycon tj.utj_val) env evdref lvar c - | _ -> pretype empty_tycon env evdref lvar c1 - in - let t = refresh_universes j.uj_type in - let var = (name,Some j.uj_val,t) in - let tycon = lift_tycon 1 tycon in - let j' = pretype tycon (push_rel var env) evdref lvar c2 in - { uj_val = mkLetIn (name, j.uj_val, t, j'.uj_val) ; - uj_type = subst1 j.uj_val j'.uj_type } + let j = + match c1 with + | GCast (loc, c, CastConv t) -> + let tj = pretype_type empty_valcon env evdref lvar t in + pretype (mk_tycon tj.utj_val) env evdref lvar c + | _ -> pretype empty_tycon env evdref lvar c1 + in + let t = j.uj_type in + let var = (name,Some j.uj_val,t) in + let tycon = lift_tycon 1 tycon in + let j' = pretype tycon (push_rel var env) evdref lvar c2 in + { uj_val = mkLetIn (name, j.uj_val, t, j'.uj_val) ; + uj_type = subst1 j.uj_val j'.uj_type } | GLetTuple (loc,nal,(na,po),c,d) -> - let cj = pretype empty_tycon env evdref lvar c in - let (IndType (indf,realargs)) = - try find_rectype env !evdref cj.uj_type - with Not_found -> - let cloc = loc_of_glob_constr c in - error_case_not_inductive_loc cloc env !evdref cj - in - let cstrs = get_constructors env indf in - if not (Int.equal (Array.length cstrs) 1) then - user_err_loc (loc,"",str "Destructing let is only for inductive types" ++ - str " with one constructor."); - let cs = cstrs.(0) in - if not (Int.equal (List.length nal) cs.cs_nargs) then - user_err_loc (loc,"", str "Destructing let on this type expects " ++ - int cs.cs_nargs ++ str " variables."); - let fsign = List.map2 (fun na (_,c,t) -> (na,c,t)) - (List.rev nal) cs.cs_args in - let env_f = push_rel_context fsign env in - (* Make dependencies from arity signature impossible *) - let arsgn = - let arsgn,_ = get_arity env indf in - if not !allow_anonymous_refs then - List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn - else arsgn - in - let psign = (na,None,build_dependent_inductive env indf)::arsgn in - let nar = List.length arsgn in - (match po with - | Some p -> - let env_p = push_rel_context psign env in - let pj = pretype_type empty_valcon env_p evdref lvar p in - let ccl = nf_evar !evdref pj.utj_val in - let psign = make_arity_signature env true indf in (* with names *) - let p = it_mkLambda_or_LetIn ccl psign in - let inst = - (Array.to_list cs.cs_concl_realargs) - @[build_dependent_constructor cs] in - let lp = lift cs.cs_nargs p in - let fty = hnf_lam_applist env !evdref lp inst in - let fj = pretype (mk_tycon fty) env_f evdref lvar d in - let f = it_mkLambda_or_LetIn fj.uj_val fsign in - let v = - let ind,_ = dest_ind_family indf in - let ci = make_case_info env ind LetStyle in - Typing.check_allowed_sort env !evdref ind cj.uj_val p; - mkCase (ci, p, cj.uj_val,[|f|]) in - { uj_val = v; uj_type = substl (realargs@[cj.uj_val]) ccl } - - | None -> - let tycon = lift_tycon cs.cs_nargs tycon in - let fj = pretype tycon env_f evdref lvar d in - let f = it_mkLambda_or_LetIn fj.uj_val fsign in - let ccl = nf_evar !evdref fj.uj_type in - let ccl = - if noccur_between 1 cs.cs_nargs ccl then - lift (- cs.cs_nargs) ccl - else - error_cant_find_case_type_loc loc env !evdref - cj.uj_val in - let ccl = refresh_universes ccl in - let p = it_mkLambda_or_LetIn (lift (nar+1) ccl) psign in - let v = - let ind,_ = dest_ind_family indf in - let ci = make_case_info env ind LetStyle in - Typing.check_allowed_sort env !evdref ind cj.uj_val p; - mkCase (ci, p, cj.uj_val,[|f|]) - in { uj_val = v; uj_type = ccl }) - - | GIf (loc,c,(na,po),b1,b2) -> - let cj = pretype empty_tycon env evdref lvar c in - let (IndType (indf,realargs)) = - try find_rectype env !evdref cj.uj_type - with Not_found -> - let cloc = loc_of_glob_constr c in - error_case_not_inductive_loc cloc env !evdref cj in - let cstrs = get_constructors env indf in - if not (Int.equal (Array.length cstrs) 2) then - user_err_loc (loc,"", - str "If is only for inductive types with two constructors."); - + let cj = pretype empty_tycon env evdref lvar c in + let (IndType (indf,realargs)) = + try find_rectype env !evdref cj.uj_type + with Not_found -> + let cloc = loc_of_glob_constr c in + error_case_not_inductive_loc cloc env !evdref cj + in + let cstrs = get_constructors env indf in + if not (Int.equal (Array.length cstrs) 1) then + user_err_loc (loc,"",str "Destructing let is only for inductive types" ++ + str " with one constructor."); + let cs = cstrs.(0) in + if not (Int.equal (List.length nal) cs.cs_nargs) then + user_err_loc (loc,"", str "Destructing let on this type expects " ++ + int cs.cs_nargs ++ str " variables."); + let fsign = List.map2 (fun na (_,c,t) -> (na,c,t)) + (List.rev nal) cs.cs_args in + let env_f = push_rel_context fsign env in + (* Make dependencies from arity signature impossible *) let arsgn = let arsgn,_ = get_arity env indf in if not !allow_anonymous_refs then - (* Make dependencies from arity signature impossible *) List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn else arsgn in - let nar = List.length arsgn in let psign = (na,None,build_dependent_inductive env indf)::arsgn in - let pred,p = match po with + let nar = List.length arsgn in + (match po with | Some p -> - let env_p = push_rel_context psign env in - let pj = pretype_type empty_valcon env_p evdref lvar p in - let ccl = nf_evar !evdref pj.utj_val in - let pred = it_mkLambda_or_LetIn ccl psign in - let typ = lift (- nar) (beta_applist (pred,[cj.uj_val])) in - pred, typ + let env_p = push_rel_context psign env in + let pj = pretype_type empty_valcon env_p evdref lvar p in + let ccl = nf_evar !evdref pj.utj_val in + let psign = make_arity_signature env true indf in (* with names *) + let p = it_mkLambda_or_LetIn ccl psign in + let inst = + (Array.to_list cs.cs_concl_realargs) + @[build_dependent_constructor cs] in + let lp = lift cs.cs_nargs p in + let fty = hnf_lam_applist env !evdref lp inst in + let fj = pretype (mk_tycon fty) env_f evdref lvar d in + let f = it_mkLambda_or_LetIn fj.uj_val fsign in + let v = + let ind,_ = dest_ind_family indf in + let ci = make_case_info env (fst ind) LetStyle in + Typing.check_allowed_sort env !evdref ind cj.uj_val p; + mkCase (ci, p, cj.uj_val,[|f|]) in + { uj_val = v; uj_type = substl (realargs@[cj.uj_val]) ccl } + | None -> - let p = match tycon with - | Some ty -> ty - | None -> new_type_evar evdref env loc - in - it_mkLambda_or_LetIn (lift (nar+1) p) psign, p in - let pred = nf_evar !evdref pred in - let p = nf_evar !evdref p in - let f cs b = - let n = rel_context_length cs.cs_args in - let pi = lift n pred in (* liftn n 2 pred ? *) - let pi = beta_applist (pi, [build_dependent_constructor cs]) in - let csgn = - if not !allow_anonymous_refs then - List.map (fun (_,b,t) -> (Anonymous,b,t)) cs.cs_args - else - List.map - (fun (n, b, t) -> - match n with - Name _ -> (n, b, t) - | Anonymous -> (Name (Id.of_string "H"), b, t)) - cs.cs_args + let tycon = lift_tycon cs.cs_nargs tycon in + let fj = pretype tycon env_f evdref lvar d in + let f = it_mkLambda_or_LetIn fj.uj_val fsign in + let ccl = nf_evar !evdref fj.uj_type in + let ccl = + if noccur_between 1 cs.cs_nargs ccl then + lift (- cs.cs_nargs) ccl + else + error_cant_find_case_type_loc loc env !evdref + cj.uj_val in + (* let ccl = refresh_universes ccl in *) + let p = it_mkLambda_or_LetIn (lift (nar+1) ccl) psign in + let v = + let ind,_ = dest_ind_family indf in + let ci = make_case_info env (fst ind) LetStyle in + Typing.check_allowed_sort env !evdref ind cj.uj_val p; + mkCase (ci, p, cj.uj_val,[|f|]) + in { uj_val = v; uj_type = ccl }) + + | GIf (loc,c,(na,po),b1,b2) -> + let cj = pretype empty_tycon env evdref lvar c in + let (IndType (indf,realargs)) = + try find_rectype env !evdref cj.uj_type + with Not_found -> + let cloc = loc_of_glob_constr c in + error_case_not_inductive_loc cloc env !evdref cj in + let cstrs = get_constructors env indf in + if not (Int.equal (Array.length cstrs) 2) then + user_err_loc (loc,"", + str "If is only for inductive types with two constructors."); + + let arsgn = + let arsgn,_ = get_arity env indf in + if not !allow_anonymous_refs then + (* Make dependencies from arity signature impossible *) + List.map (fun (_,b,t) -> (Anonymous,b,t)) arsgn + else arsgn + in + let nar = List.length arsgn in + let psign = (na,None,build_dependent_inductive env indf)::arsgn in + let pred,p = match po with + | Some p -> + let env_p = push_rel_context psign env in + let pj = pretype_type empty_valcon env_p evdref lvar p in + let ccl = nf_evar !evdref pj.utj_val in + let pred = it_mkLambda_or_LetIn ccl psign in + let typ = lift (- nar) (beta_applist (pred,[cj.uj_val])) in + pred, typ + | None -> + let p = match tycon with + | Some ty -> ty + | None -> new_type_evar evdref env loc in - let env_c = push_rel_context csgn env in - let bj = pretype (mk_tycon pi) env_c evdref lvar b in - it_mkLambda_or_LetIn bj.uj_val cs.cs_args in - let b1 = f cstrs.(0) b1 in - let b2 = f cstrs.(1) b2 in - let v = - let ind,_ = dest_ind_family indf in - let ci = make_case_info env ind IfStyle in - let pred = nf_evar !evdref pred in - Typing.check_allowed_sort env !evdref ind cj.uj_val pred; - mkCase (ci, pred, cj.uj_val, [|b1;b2|]) + it_mkLambda_or_LetIn (lift (nar+1) p) psign, p in + let pred = nf_evar !evdref pred in + let p = nf_evar !evdref p in + let f cs b = + let n = rel_context_length cs.cs_args in + let pi = lift n pred in (* liftn n 2 pred ? *) + let pi = beta_applist (pi, [build_dependent_constructor cs]) in + let csgn = + if not !allow_anonymous_refs then + List.map (fun (_,b,t) -> (Anonymous,b,t)) cs.cs_args + else + List.map + (fun (n, b, t) -> + match n with + Name _ -> (n, b, t) + | Anonymous -> (Name (Id.of_string "H"), b, t)) + cs.cs_args in - { uj_val = v; uj_type = p } + let env_c = push_rel_context csgn env in + let bj = pretype (mk_tycon pi) env_c evdref lvar b in + it_mkLambda_or_LetIn bj.uj_val cs.cs_args in + let b1 = f cstrs.(0) b1 in + let b2 = f cstrs.(1) b2 in + let v = + let ind,_ = dest_ind_family indf in + let ci = make_case_info env (fst ind) IfStyle in + let pred = nf_evar !evdref pred in + Typing.check_allowed_sort env !evdref ind cj.uj_val pred; + mkCase (ci, pred, cj.uj_val, [|b1;b2|]) + in + { uj_val = v; uj_type = p } | GCases (loc,sty,po,tml,eqns) -> - Cases.compile_cases loc sty - ((fun vtyc env evdref -> pretype vtyc env evdref lvar),evdref) - tycon env (* loc *) (po,tml,eqns) + Cases.compile_cases loc sty + ((fun vtyc env evdref -> pretype vtyc env evdref lvar),evdref) + tycon env (* loc *) (po,tml,eqns) | GCast (loc,c,k) -> - let cj = - match k with - | CastCoerce -> - let cj = pretype empty_tycon env evdref lvar c in - evd_comb1 (Coercion.inh_coerce_to_base loc env) evdref cj - | CastConv t | CastVM t | CastNative t -> - let k = (match k with CastVM _ -> VMcast | CastNative _ -> NATIVEcast | _ -> DEFAULTcast) in - let tj = pretype_type empty_valcon env evdref lvar t in - let tval = nf_evar !evdref tj.utj_val in - let cj = match k with - | VMcast -> - let cj = pretype empty_tycon env evdref lvar c in - let cty = nf_evar !evdref cj.uj_type and tval = nf_evar !evdref tj.utj_val in - if not (occur_existential cty || occur_existential tval) then - begin - try - ignore (Reduction.vm_conv Reduction.CUMUL env cty tval); cj - with Reduction.NotConvertible -> - error_actual_type_loc loc env !evdref cj tval - (ConversionFailed (env,cty,tval)) - end - else user_err_loc (loc,"",str "Cannot check cast with vm: " ++ - str "unresolved arguments remain.") - | NATIVEcast -> - let cj = pretype empty_tycon env evdref lvar c in - let cty = nf_evar !evdref cj.uj_type and - tval = nf_evar !evdref tj.utj_val in - let evars = Nativenorm.evars_of_evar_map !evdref in - begin - try - ignore - (Nativeconv.native_conv Reduction.CUMUL evars env cty tval); - cj - with Reduction.NotConvertible -> - error_actual_type_loc loc env !evdref cj tval + let cj = + match k with + | CastCoerce -> + let cj = pretype empty_tycon env evdref lvar c in + evd_comb1 (Coercion.inh_coerce_to_base loc env) evdref cj + | CastConv t | CastVM t | CastNative t -> + let k = (match k with CastVM _ -> VMcast | CastNative _ -> NATIVEcast | _ -> DEFAULTcast) in + let tj = pretype_type empty_valcon env evdref lvar t in + let tval = nf_evar !evdref tj.utj_val in + let cj = match k with + | VMcast -> + let cj = pretype empty_tycon env evdref lvar c in + let cty = nf_evar !evdref cj.uj_type and tval = nf_evar !evdref tj.utj_val in + if not (occur_existential cty || occur_existential tval) then + begin + try + ignore (Reduction.vm_conv Reduction.CUMUL env cty tval); cj + with Reduction.NotConvertible -> + error_actual_type_loc loc env !evdref cj tval + (ConversionFailed (env,cty,tval)) + end + else user_err_loc (loc,"",str "Cannot check cast with vm: " ++ + str "unresolved arguments remain.") + | NATIVEcast -> + let cj = pretype empty_tycon env evdref lvar c in + let cty = nf_evar !evdref cj.uj_type and tval = nf_evar !evdref tj.utj_val in + let evars = Nativenorm.evars_of_evar_map !evdref in + begin + try + ignore (Nativeconv.native_conv Reduction.CUMUL evars env cty tval); cj + with Reduction.NotConvertible -> + error_actual_type_loc loc env !evdref cj tval (ConversionFailed (env,cty,tval)) - end - - | _ -> - pretype (mk_tycon tval) env evdref lvar c - in - let v = mkCast (cj.uj_val, k, tval) in - { uj_val = v; uj_type = tval } - in inh_conv_coerce_to_tycon loc env evdref cj tycon + end + | _ -> + pretype (mk_tycon tval) env evdref lvar c + in + let v = mkCast (cj.uj_val, k, tval) in + { uj_val = v; uj_type = tval } + in inh_conv_coerce_to_tycon loc env evdref cj tycon (* [pretype_type valcon env evdref lvar c] coerces [c] into a type *) and pretype_type resolve_tc valcon env evdref lvar = function @@ -751,7 +795,7 @@ and pretype_type resolve_tc valcon env evdref lvar = function { utj_val = v; utj_type = s } | None -> - let s = evd_comb0 new_sort_variable evdref in + let s = evd_comb0 (new_sort_variable univ_flexible_alg) evdref in { utj_val = e_new_evar evdref env ~src:(loc, knd) (mkSort s); utj_type = s}) | c -> @@ -778,11 +822,6 @@ let ise_pretype_gen flags sigma env lvar kind c = in process_inference_flags flags env sigma (!evdref,c') -(* TODO: comment faire remonter l'information si le typage a resolu des - variables du sigma original. il faudrait que la fonction de typage - retourne aussi le nouveau sigma... -*) - let default_inference_flags fail = { use_typeclasses = true; use_unif_heuristics = true; @@ -810,8 +849,10 @@ let on_judgment f j = let understand_judgment sigma env c = let evdref = ref sigma in let j = pretype true empty_tycon env evdref empty_lvar c in - on_judgment (fun c -> - snd (process_inference_flags all_and_fail_flags env sigma (!evdref,c))) j + let j = on_judgment (fun c -> + let evd, c = process_inference_flags all_and_fail_flags env sigma (!evdref,c) in + evdref := evd; c) j + in j, Evd.evar_universe_context !evdref let understand_judgment_tcc evdref env c = let j = pretype true empty_tycon env evdref empty_lvar c in @@ -819,13 +860,18 @@ let understand_judgment_tcc evdref env c = let (evd,c) = process_inference_flags all_no_fail_flags env Evd.empty (!evdref,c) in evdref := evd; c) j +let ise_pretype_gen_ctx flags sigma env lvar kind c = + let evd, c = ise_pretype_gen flags sigma env lvar kind c in + let evd, f = Evarutil.nf_evars_and_universes evd in + f c, Evd.get_universe_context_set evd + (** Entry points of the high-level type synthesis algorithm *) let understand ?(flags=all_and_fail_flags) ?(expected_type=WithoutTypeConstraint) sigma env c = - snd (ise_pretype_gen flags sigma env empty_lvar expected_type c) + ise_pretype_gen_ctx flags sigma env empty_lvar expected_type c let understand_tcc ?(flags=all_no_fail_flags) sigma env ?(expected_type=WithoutTypeConstraint) c = ise_pretype_gen flags sigma env empty_lvar expected_type c diff --git a/pretyping/pretyping.mli b/pretyping/pretyping.mli index ec8aae140..79b051845 100644 --- a/pretyping/pretyping.mli +++ b/pretyping/pretyping.mli @@ -81,14 +81,16 @@ val understand_ltac : inference_flags -> (** Standard call to get a constr from a glob_constr, resolving implicit args *) val understand : ?flags:inference_flags -> ?expected_type:typing_constraint -> - evar_map -> env -> glob_constr -> constr + evar_map -> env -> glob_constr -> constr Univ.in_universe_context_set (** Idem but returns the judgment of the understood term *) -val understand_judgment : evar_map -> env -> glob_constr -> unsafe_judgment +val understand_judgment : evar_map -> env -> + glob_constr -> unsafe_judgment Evd.in_evar_universe_context (** Idem but do not fail on unresolved evars *) -val understand_judgment_tcc : evar_map ref -> env -> glob_constr -> unsafe_judgment +val understand_judgment_tcc : evar_map ref -> env -> + glob_constr -> unsafe_judgment (** Trying to solve remaining evars and remaining conversion problems with type classes, heuristics, and possibly an external solver *) @@ -122,7 +124,7 @@ val ise_pretype_gen : val constr_in : constr -> Dyn.t val constr_out : Dyn.t -> constr -val interp_sort : glob_sort -> sorts +val interp_sort : evar_map -> glob_sort -> evar_map * sorts val interp_elimination_sort : glob_sort -> sorts_family val genarg_interp_hook : diff --git a/pretyping/program.ml b/pretyping/program.ml index 6d913060b..67bb3bd2a 100644 --- a/pretyping/program.ml +++ b/pretyping/program.ml @@ -21,7 +21,7 @@ let find_reference locstr dir s = anomaly ~label:locstr (Pp.str "cannot find" ++ spc () ++ Libnames.pr_path sp) let coq_reference locstr dir s = find_reference locstr ("Coq"::dir) s -let coq_constant locstr dir s = Globnames.constr_of_global (coq_reference locstr dir s) +let coq_constant locstr dir s = Universes.constr_of_global (coq_reference locstr dir s) let init_constant dir s () = coq_constant "Program" dir s let init_reference dir s () = coq_reference "Program" dir s diff --git a/pretyping/recordops.ml b/pretyping/recordops.ml index 9f8ba956a..967583a2b 100644 --- a/pretyping/recordops.ml +++ b/pretyping/recordops.ml @@ -63,12 +63,12 @@ let cache_structure o = load_structure 1 o let subst_structure (subst,((kn,i),id,kl,projs as obj)) = - let kn' = subst_ind subst kn in + let kn' = subst_mind subst kn in let projs' = (* invariant: struc.s_PROJ is an evaluable reference. Thus we can take *) (* the first component of subst_con. *) List.smartmap - (Option.smartmap (fun kn -> fst (subst_con subst kn))) + (Option.smartmap (fun kn -> fst (subst_con_kn subst kn))) projs in let id' = fst (subst_constructor subst id) in @@ -132,6 +132,7 @@ that maps the pair (Li,ci) to the following data type obj_typ = { o_DEF : constr; + o_CTX : Univ.ContextSet.t; o_INJ : int; (* position of trivial argument (negative= none) *) o_TABS : constr list; (* ordered *) o_TPARAMS : constr list; (* ordered *) @@ -189,9 +190,13 @@ let cs_pattern_of_constr t = (* Intended to always succeed *) let compute_canonical_projections (con,ind) = - let v = mkConst con in - let c = Environ.constant_value (Global.env()) con in - let lt,t = Reductionops.splay_lam (Global.env()) Evd.empty c in + let env = Global.env () in + let ctx = Environ.constant_context env con in + let u = Univ.UContext.instance ctx in + let v = (mkConstU (con,u)) in + let ctx = Univ.ContextSet.of_context ctx in + let c = Environ.constant_value_in env (con,u) in + let lt,t = Reductionops.splay_lam env Evd.empty c in let lt = List.rev_map snd lt in let args = snd (decompose_app t) in let { s_EXPECTEDPARAM = p; s_PROJ = lpj; s_PROJKIND = kl } = @@ -221,7 +226,7 @@ let compute_canonical_projections (con,ind) = [] lps in List.map (fun (refi,c,inj,argj) -> (refi,c), - {o_DEF=v; o_INJ=inj; o_TABS=lt; + {o_DEF=v; o_CTX=ctx; o_INJ=inj; o_TABS=lt; o_TPARAMS=params; o_NPARAMS=List.length params; o_TCOMPS=argj}) comp @@ -256,8 +261,8 @@ let cache_canonical_structure o = let subst_canonical_structure (subst,(cst,ind as obj)) = (* invariant: cst is an evaluable reference. Thus we can take *) (* the first component of subst_con. *) - let cst' = fst (subst_con subst cst) in - let ind' = Inductiveops.subst_inductive subst ind in + let cst' = subst_constant subst cst in + let ind' = subst_ind subst ind in if cst' == cst && ind' == ind then obj else (cst',ind') let discharge_canonical_structure (_,(cst,ind)) = @@ -282,7 +287,9 @@ let error_not_structure ref = let check_and_decompose_canonical_structure ref = let sp = match ref with ConstRef sp -> sp | _ -> error_not_structure ref in let env = Global.env () in - let vc = match Environ.constant_opt_value env sp with + let ctx = Environ.constant_context env sp in + let u = Univ.UContext.instance ctx in + let vc = match Environ.constant_opt_value_in env (sp, u) with | Some vc -> vc | None -> error_not_structure ref in let body = snd (splay_lam (Global.env()) Evd.empty vc) in @@ -290,7 +297,7 @@ let check_and_decompose_canonical_structure ref = | App (f,args) -> f,args | _ -> error_not_structure ref in let indsp = match kind_of_term f with - | Construct (indsp,1) -> indsp + | Construct ((indsp,1),u) -> indsp | _ -> error_not_structure ref in let s = try lookup_structure indsp with Not_found -> error_not_structure ref in let ntrue_projs = List.length (List.filter (fun (_, x) -> x) s.s_PROJKIND) in @@ -304,6 +311,9 @@ let declare_canonical_structure ref = let lookup_canonical_conversion (proj,pat) = List.assoc_f eq_cs_pattern pat (Refmap.find proj !object_table) + (* let cst, u' = destConst cs.o_DEF in *) + (* { cs with o_DEF = mkConstU (cst, u) } *) + let is_open_canonical_projection env sigma (c,args) = try let n = find_projection_nparams (global_of_constr c) in diff --git a/pretyping/recordops.mli b/pretyping/recordops.mli index 42663c014..b1763a359 100644 --- a/pretyping/recordops.mli +++ b/pretyping/recordops.mli @@ -56,6 +56,7 @@ type cs_pattern = type obj_typ = { o_DEF : constr; + o_CTX : Univ.ContextSet.t; o_INJ : int; (** position of trivial argument *) o_TABS : constr list; (** ordered *) o_TPARAMS : constr list; (** ordered *) diff --git a/pretyping/reductionops.ml b/pretyping/reductionops.ml index 0b6c3197d..676fc4f3a 100644 --- a/pretyping/reductionops.ml +++ b/pretyping/reductionops.ml @@ -61,7 +61,7 @@ module ReductionBehaviour = struct let discharge = function | _,(ReqGlobal (ConstRef c, req), (_, b)) -> let c' = pop_con c in - let vars = Lib.section_segment_of_constant c in + let vars, _ctx = Lib.section_segment_of_constant c in let extra = List.length vars in let nargs' = if b.b_nargs < 0 then b.b_nargs else b.b_nargs + extra in let recargs' = List.map ((+) extra) b.b_recargs in @@ -142,6 +142,7 @@ sig type 'a member = | App of 'a app_node | Case of case_info * 'a * 'a array * ('a * 'a list) option + | Proj of int * int * projection | Fix of fixpoint * 'a t * ('a * 'a list) option | Shift of int | Update of 'a @@ -186,6 +187,7 @@ struct type 'a member = | App of 'a app_node | Case of Term.case_info * 'a * 'a array * ('a * 'a list) option + | Proj of int * int * projection | Fix of fixpoint * 'a t * ('a * 'a list) option | Shift of int | Update of 'a @@ -200,6 +202,9 @@ struct str "ZCase(" ++ prvect_with_sep (pr_bar) pr_c br ++ str ")" + | Proj (n,m,p) -> + str "ZProj(" ++ int n ++ pr_comma () ++ int m ++ + pr_comma () ++ pr_con p ++ str ")" | Fix (f,args,cst) -> str "ZFix(" ++ Termops.pr_fix Termops.print_constr f ++ pr_comma () ++ pr pr_c args ++ str ")" @@ -261,6 +266,8 @@ struct | (_, App (i,_,j)::s2) -> compare_rec (bal - j - 1 + i) stk1 s2 | (Case(c1,_,_,_)::s1, Case(c2,_,_,_)::s2) -> Int.equal bal 0 (* && c1.ci_ind = c2.ci_ind *) && compare_rec 0 s1 s2 + | (Proj (n1,m1,p)::s1, Proj(n2,m2,p2)::s2) -> + Int.equal bal 0 && compare_rec 0 s1 s2 | (Fix(_,a1,_)::s1, Fix(_,a2,_)::s2) -> Int.equal bal 0 && compare_rec 0 a1 a2 && compare_rec 0 s1 s2 | (_,_) -> false in @@ -284,6 +291,9 @@ struct aux (fold_array (f o (Vars.lift lft1 t1) (Vars.lift lft2 t2)) a1 a2) lft1 q1 lft2 q2 + | Proj (n1,m1,p1) :: q1, Proj (n2,m2,p2) :: q2 -> + (* MS: FIXME: unsure *) + aux o lft1 q1 lft2 q2 | Fix ((_,(_,a1,b1)),s1,_) :: q1, Fix ((_,(_,a2,b2)),s2,_) :: q2 -> let (o',_,_) = aux (fold_array (fold_array o b1 b2) a1 a2) lft1 s1 lft2 s2 in @@ -323,7 +333,7 @@ struct in aux n [] s let not_purely_applicative args = - List.exists (function (Fix _ | Case _) -> true | _ -> false) args + List.exists (function (Fix _ | Case _ | Proj _) -> true | _ -> false) args let list_of_app_stack s = let rec aux = function | App (i,a,j) :: s -> @@ -379,6 +389,7 @@ struct | f, (Fix (fix,st,_)::s) -> zip ~refold (mkFix fix, st @ (append_app [|f|] s)) | f, (Shift n::s) -> zip ~refold (lift n f, s) + | f, (Proj (n,m,p)::s) -> zip ~refold (mkProj (p,f),s) | _ -> assert false end @@ -388,6 +399,7 @@ type state = constr * constr Stack.t type contextual_reduction_function = env -> evar_map -> constr -> constr type reduction_function = contextual_reduction_function type local_reduction_function = evar_map -> constr -> constr +type e_reduction_function = env -> evar_map -> constr -> evar_map * constr type contextual_stack_reduction_function = env -> evar_map -> constr -> constr * constr list @@ -527,9 +539,17 @@ let magicaly_constant_of_fixbody env bd = function try let cst = Nametab.locate_constant (Libnames.make_qualid DirPath.empty id) in - match constant_opt_value env cst with + let (cst, u), ctx = Universes.fresh_constant_instance env cst in + match constant_opt_value env (cst,u) with | None -> bd - | Some t -> if eq_constr t bd then mkConst cst else bd + | Some (t,cstrs) -> + let b, csts = eq_constr_universes t bd in + let subst = UniverseConstraints.fold (fun (l,d,r) acc -> + Univ.LMap.add (Option.get (Universe.level l)) (Option.get (Universe.level r)) acc) + csts Univ.LMap.empty + in + let inst = Instance.subst_fn (fun u -> Univ.LMap.find u subst) u in + if b then mkConstU (cst,inst) else bd with | Not_found -> bd @@ -550,7 +570,7 @@ let contract_cofix ?env (bodynum,(names,types,bodies as typedbodies)) cst = let reduce_mind_case mia = match kind_of_term mia.mconstr with - | Construct (ind_sp,i) -> + | Construct ((ind_sp,i),u) -> (* let ncargs = (fst mia.mci).(i-1) in*) let real_cargs = List.skipn mia.mci.ci_npar mia.mcargs in applist (mia.mlf.(i-1),real_cargs) @@ -585,6 +605,10 @@ let fix_recarg ((recindices,bodynum),_) stack = with Not_found -> None +type 'a reduced_state = + | NotReducible + | Reduced of constr + (** Generic reduction function with environment Here is where unfolded constant are stored in order to be @@ -625,15 +649,15 @@ let rec whd_state_gen ?csts tactic_mode flags env sigma = (match safe_meta_value sigma ev with | Some body -> whrec cst_l (body, stack) | None -> fold ()) - | Const const when Closure.RedFlags.red_set flags (Closure.RedFlags.fCONST const) -> - (match constant_opt_value env const with + | Const (c,u as const) when Closure.RedFlags.red_set flags (Closure.RedFlags.fCONST c) -> + (match constant_opt_value_in env const with | None -> fold () - | Some body -> + | Some body -> if not tactic_mode - then whrec (Cst_stack.add_cst (mkConst const) cst_l) (body, stack) + then whrec (Cst_stack.add_cst (mkConstU const) cst_l) (body, stack) else (* Looks for ReductionBehaviour *) - match ReductionBehaviour.get (Globnames.ConstRef const) with - | None -> whrec (Cst_stack.add_cst (mkConst const) cst_l) (body, stack) + match ReductionBehaviour.get (Globnames.ConstRef c) with + | None -> whrec (Cst_stack.add_cst (mkConstU const) cst_l) (body, stack) | Some (recargs, nargs, flags) -> if (List.mem `ReductionNeverUnfold flags || (nargs > 0 && Stack.args_size stack < nargs)) @@ -642,7 +666,7 @@ let rec whd_state_gen ?csts tactic_mode flags env sigma = if List.mem `ReductionDontExposeCase flags then let app_sk,sk = Stack.strip_app stack in let (tm',sk'),cst_l' = - whrec (Cst_stack.add_cst (mkConst const) cst_l) (body, app_sk) in + whrec (Cst_stack.add_cst (mkConstU const) cst_l) (body, app_sk) in let f_equal (x,lft1) (y,lft2) = Constr.equal (Vars.lift lft1 x) (Vars.lift lft2 y) in if (match Stack.equal f_equal @@ -660,6 +684,11 @@ let rec whd_state_gen ?csts tactic_mode flags env sigma = whrec cst_l (body, stack) |l -> failwith "TODO recargs in cbn" ) + | Proj (p, c) when Closure.RedFlags.red_set flags (Closure.RedFlags.fCONST p) -> + (match (lookup_constant p env).Declarations.const_proj with + | None -> assert false + | Some pb -> whrec cst_l (c, Stack.Proj (pb.Declarations.proj_npars, pb.Declarations.proj_arg, p) + :: stack)) | LetIn (_,b,_,c) when Closure.RedFlags.red_set flags Closure.RedFlags.fZETA -> apply_subst whrec [b] cst_l c stack | Cast (c,_,_) -> whrec cst_l (c, stack) @@ -698,11 +727,13 @@ let rec whd_state_gen ?csts tactic_mode flags env sigma = |Some (bef,arg,s') -> whrec noth (arg, Stack.Fix(f,bef,Cst_stack.best_cst cst_l)::s')) - | Construct (ind,c) -> + | Construct ((ind,c),u) -> if Closure.RedFlags.red_set flags Closure.RedFlags.fIOTA then match Stack.strip_app stack with |args, (Stack.Case(ci, _, lf,_)::s') -> whrec noth (lf.(c-1), (Stack.tail ci.ci_npar args) @ s') + |args, (Stack.Proj (n,m,p)::s') -> + whrec noth (Stack.nth args (n+m), s') |args, (Stack.Fix (f,s',cst)::s'') -> let x' = Stack.zip(x,args) in whrec noth ((if tactic_mode then contract_fix ~env f else contract_fix f) cst, @@ -720,7 +751,7 @@ let rec whd_state_gen ?csts tactic_mode flags env sigma = |_ -> fold () else fold () - | Rel _ | Var _ | Const _ | LetIn _ -> fold () + | Rel _ | Var _ | Const _ | LetIn _ | Proj _ -> fold () | Sort _ | Ind _ | Prod _ -> fold () in whrec (Option.default noth csts) @@ -752,6 +783,12 @@ let local_whd_state_gen flags sigma = else s | _ -> s) | _ -> s) + + | Proj (p,c) when Closure.RedFlags.red_set flags (Closure.RedFlags.fCONST p) -> + (match (lookup_constant p (Global.env ())).Declarations.const_proj with + | None -> assert false + | Some pb -> whrec (c, Stack.Proj (pb.Declarations.proj_npars, pb.Declarations.proj_arg, p) + :: stack)) | Case (ci,p,d,lf) -> whrec (d, Stack.Case (ci,p,lf,None) :: stack) @@ -771,14 +808,13 @@ let local_whd_state_gen flags sigma = Some c -> whrec (c,stack) | None -> s) - | Construct (ind,c) -> + | Construct ((ind,c),u) -> if Closure.RedFlags.red_set flags Closure.RedFlags.fIOTA then match Stack.strip_app stack with |args, (Stack.Case(ci, _, lf,_)::s') -> whrec (lf.(c-1), (Stack.tail ci.ci_npar args) @ s') - |args, (Stack.Fix (f,s',cst)::s'') -> - let x' = Stack.zip(x,args) in - whrec (contract_fix f cst, s' @ (Stack.append_app [|x'|] s'')) + |args, (Stack.Proj (n,m,p) :: s') -> + whrec (Stack.nth args (n+m), s') |_ -> s else s @@ -899,7 +935,18 @@ let rec whd_evar sigma c = (match safe_evar_value sigma ev with Some c -> whd_evar sigma c | None -> c) - | Sort s -> whd_sort_variable sigma c + | Sort (Type u) -> + let u' = Evd.normalize_universe sigma u in + if u' == u then c else mkSort (Type u') + | Const (c', u) when not (Univ.Instance.is_empty u) -> + let u' = Evd.normalize_universe_instance sigma u in + if u' == u then c else mkConstU (c', u') + | Ind (i, u) when not (Univ.Instance.is_empty u) -> + let u' = Evd.normalize_universe_instance sigma u in + if u' == u then c else mkIndU (i, u') + | Construct (co, u) when not (Univ.Instance.is_empty u) -> + let u' = Evd.normalize_universe_instance sigma u in + if u' == u then c else mkConstructU (co, u') | _ -> c let nf_evar = @@ -916,12 +963,13 @@ let clos_norm_flags flgs env sigma t = (Closure.inject t) with e when is_anomaly e -> error "Tried to normalize ill-typed term" -let nf_beta = clos_norm_flags Closure.beta empty_env -let nf_betaiota = clos_norm_flags Closure.betaiota empty_env -let nf_betaiotazeta = clos_norm_flags Closure.betaiotazeta empty_env +let nf_beta = clos_norm_flags Closure.beta (Global.env ()) +let nf_betaiota = clos_norm_flags Closure.betaiota (Global.env ()) +let nf_betaiotazeta = clos_norm_flags Closure.betaiotazeta (Global.env ()) let nf_betadeltaiota env sigma = clos_norm_flags Closure.betadeltaiota env sigma + (********************************************************************) (* Conversion *) (********************************************************************) @@ -948,32 +996,43 @@ let pb_equal = function | Reduction.CUMUL -> Reduction.CONV | Reduction.CONV -> Reduction.CONV -let sort_cmp = Reduction.sort_cmp +let sort_cmp cv_pb s1 s2 u = + ignore(Reduction.sort_cmp_universes cv_pb s1 s2 (u, None)) -let test_conversion (f: ?l2r:bool-> ?evars:'a->'b) env sigma x y = +let test_trans_conversion (f: ?l2r:bool-> ?evars:'a->'b) reds env sigma x y = try let evars ev = safe_evar_value sigma ev in - let _ = f ~evars env x y in + let _ = f ~evars reds env (Evd.universes sigma) x y in true with Reduction.NotConvertible -> false | e when is_anomaly e -> error "Conversion test raised an anomaly" -let is_conv env sigma = test_conversion Reduction.conv env sigma -let is_conv_leq env sigma = test_conversion Reduction.conv_leq env sigma +let is_trans_conv reds env sigma = test_trans_conversion Reduction.trans_conv_universes reds env sigma +let is_trans_conv_leq reds env sigma = test_trans_conversion Reduction.trans_conv_leq_universes reds env sigma +let is_trans_fconv = function Reduction.CONV -> is_trans_conv | Reduction.CUMUL -> is_trans_conv_leq + +let is_conv = is_trans_conv full_transparent_state +let is_conv_leq = is_trans_conv_leq full_transparent_state let is_fconv = function | Reduction.CONV -> is_conv | Reduction.CUMUL -> is_conv_leq -let test_trans_conversion (f: ?l2r:bool-> ?evars:'a->'b) reds env sigma x y = - try - let evars ev = safe_evar_value sigma ev in - let _ = f ~evars reds env x y in - true - with Reduction.NotConvertible -> false +let check_conv ?(pb=Reduction.CUMUL) ?(ts=full_transparent_state) env sigma x y = + let f = match pb with + | Reduction.CONV -> Reduction.trans_conv_universes + | Reduction.CUMUL -> Reduction.trans_conv_leq_universes in + try f ~evars:(safe_evar_value sigma) ts env (Evd.universes sigma) x y; true + with Reduction.NotConvertible -> false | e when is_anomaly e -> error "Conversion test raised an anomaly" -let is_trans_conv reds env sigma = test_trans_conversion Reduction.trans_conv reds env sigma -let is_trans_conv_leq reds env sigma = test_trans_conversion Reduction.trans_conv_leq reds env sigma -let is_trans_fconv = function | Reduction.CONV -> is_trans_conv | Reduction.CUMUL -> is_trans_conv_leq - +let infer_conv ?(pb=Reduction.CUMUL) ?(ts=full_transparent_state) env sigma x y = + let f = match pb with + | Reduction.CONV -> Reduction.infer_conv + | Reduction.CUMUL -> Reduction.infer_conv_leq in + try + let cstrs = f ~evars:(safe_evar_value sigma) ~ts env (Evd.universes sigma) x y in + Evd.add_constraints sigma cstrs, true + with Reduction.NotConvertible -> sigma, false + | e when is_anomaly e -> error "Conversion test raised an anomaly" + (********************************************************************) (* Special-Purpose Reduction *) (********************************************************************) @@ -1164,6 +1223,14 @@ let whd_betaiota_deltazeta_for_iota_state ts env sigma csts s = let (t_o,stack_o),csts_o = whd_state_gen ~csts:csts' false (Closure.RedFlags.red_add_transparent betadeltaiota ts) env sigma (t,args) in if isConstruct t_o then whrec csts_o (t_o, stack_o@stack') else s,csts' + |args, (Stack.Proj (n,m,p) :: stack'' as stack') -> + let (t_o,stack_o),csts_o = whd_state_gen ~csts:csts' false + (Closure.RedFlags.red_add_transparent betadeltaiota ts) env sigma (t,args) in + if isConstruct t_o then + if Closure.is_transparent_constant ts p then + whrec csts_o (Stack.nth stack_o (n+m), stack'') + else (* Won't unfold *) (whd_betaiota_state sigma (t_o, stack_o@stack'),csts') + else s,csts' |_ -> s,csts' in whrec csts s @@ -1245,6 +1312,17 @@ let meta_reducible_instance evd b = let is_coerce = match s with CoerceToType -> true | _ -> false in if not is_coerce then irec g else u with Not_found -> u) + | Proj (p,c) when isMeta c || isCast c && isMeta (pi1 (destCast c)) -> + let m = try destMeta c with _ -> destMeta (pi1 (destCast c)) in + (match + try + let g, s = Metamap.find m metas in + let is_coerce = match s with CoerceToType -> true | _ -> false in + if isConstruct g || not is_coerce then Some g else None + with Not_found -> None + with + | Some g -> irec (mkProj (p,g)) + | None -> mkProj (p,c)) | _ -> map_constr irec u in if Metaset.is_empty fm then (* nf_betaiota? *) b.rebus @@ -1252,12 +1330,12 @@ let meta_reducible_instance evd b = let head_unfold_under_prod ts env _ c = - let unfold cst = + let unfold (cst,u as cstu) = if Cpred.mem cst (snd ts) then - match constant_opt_value env cst with + match constant_opt_value_in env cstu with | Some c -> c - | None -> mkConst cst - else mkConst cst in + | None -> mkConstU cstu + else mkConstU cstu in let rec aux c = match kind_of_term c with | Prod (n,t,c) -> mkProd (n,aux t, aux c) diff --git a/pretyping/reductionops.mli b/pretyping/reductionops.mli index 5ba0d74ec..29d7a6b2f 100644 --- a/pretyping/reductionops.mli +++ b/pretyping/reductionops.mli @@ -17,7 +17,7 @@ open Environ exception Elimconst -(** Machinery to custom the behavior of the reduction *) +(** Machinery to customize the behavior of the reduction *) module ReductionBehaviour : sig type flag = [ `ReductionDontExposeCase | `ReductionNeverUnfold ] @@ -37,6 +37,7 @@ module Stack : sig type 'a member = | App of 'a app_node | Case of case_info * 'a * 'a array * ('a * 'a list) option + | Proj of int * int * projection | Fix of fixpoint * 'a t * ('a * 'a list) option | Shift of int | Update of 'a @@ -82,6 +83,8 @@ type contextual_reduction_function = env -> evar_map -> constr -> constr type reduction_function = contextual_reduction_function type local_reduction_function = evar_map -> constr -> constr +type e_reduction_function = env -> evar_map -> constr -> evar_map * constr + type contextual_stack_reduction_function = env -> evar_map -> constr -> constr * constr list type stack_reduction_function = contextual_stack_reduction_function @@ -203,6 +206,7 @@ val splay_prod_n : env -> evar_map -> int -> constr -> rel_context * constr val splay_lam_n : env -> evar_map -> int -> constr -> rel_context * constr val splay_prod_assum : env -> evar_map -> constr -> rel_context * constr +val is_sort : env -> evar_map -> types -> bool type 'a miota_args = { mP : constr; (** the result type *) @@ -223,7 +227,7 @@ val contract_fix : ?env:Environ.env -> fixpoint -> val fix_recarg : fixpoint -> constr Stack.t -> (int * constr) option (** {6 Querying the kernel conversion oracle: opaque/transparent constants } *) -val is_transparent : Environ.env -> 'a tableKey -> bool +val is_transparent : Environ.env -> constant tableKey -> bool (** {6 Conversion Functions (uses closures, lazy strategy) } *) @@ -232,7 +236,7 @@ type conversion_test = constraints -> constraints val pb_is_equal : conv_pb -> bool val pb_equal : conv_pb -> conv_pb -val sort_cmp : conv_pb -> sorts -> sorts -> conversion_test +val sort_cmp : conv_pb -> sorts -> sorts -> universes -> unit val is_conv : env -> evar_map -> constr -> constr -> bool val is_conv_leq : env -> evar_map -> constr -> constr -> bool @@ -242,6 +246,17 @@ val is_trans_conv : transparent_state -> env -> evar_map -> constr -> constr -> val is_trans_conv_leq : transparent_state -> env -> evar_map -> constr -> constr -> bool val is_trans_fconv : conv_pb -> transparent_state -> env -> evar_map -> constr -> constr -> bool +(** [check_conv} Checks universe constraints only. + pb defaults to CUMUL and ts to a full transparent state. + *) +val check_conv : ?pb:conv_pb -> ?ts:transparent_state -> env -> evar_map -> constr -> constr -> bool + +(** [infer_fconv] Adds necessary universe constraints to the evar map. + pb defaults to CUMUL and ts to a full transparent state. + *) +val infer_conv : ?pb:conv_pb -> ?ts:transparent_state -> env -> evar_map -> constr -> constr -> + evar_map * bool + (** {6 Special-Purpose Reduction Functions } *) val whd_meta : evar_map -> constr -> constr diff --git a/pretyping/retyping.ml b/pretyping/retyping.ml index c66ca7ac1..31487125a 100644 --- a/pretyping/retyping.ml +++ b/pretyping/retyping.ml @@ -85,9 +85,10 @@ let type_of_var env id = try let (_,_,ty) = lookup_named id env in ty with Not_found -> retype_error (BadVariable id) -let is_impredicative_set env = match Environ.engagement env with -| Some ImpredicativeSet -> true -| _ -> false +let decomp_sort env sigma t = + match kind_of_term (whd_betadeltaiota env sigma t) with + | Sort s -> s + | _ -> retype_error NotASort let retype ?(polyprop=true) sigma = let rec type_of env cstr= @@ -99,7 +100,7 @@ let retype ?(polyprop=true) sigma = let (_,_,ty) = lookup_rel n env in lift n ty | Var id -> type_of_var env id - | Const cst -> Typeops.type_of_constant env cst + | Const cst -> Typeops.type_of_constant_in env cst | Evar ev -> Evd.existential_type sigma ev | Ind ind -> type_of_inductive env ind | Construct cstr -> type_of_constructor env cstr @@ -129,6 +130,13 @@ let retype ?(polyprop=true) sigma = | App(f,args) -> strip_outer_cast (subst_type env sigma (type_of env f) (Array.to_list args)) + | Proj (p,c) -> + let Inductiveops.IndType(pars,realargs) = + try Inductiveops.find_rectype env sigma (type_of env c) + with Not_found -> anomaly ~label:"type_of" (str "Bad recursive type") + in + let (_,u), pars = dest_ind_family pars in + substl (c :: List.rev pars) (Typeops.type_of_projection env (p,u)) | Cast (c,_, t) -> t | Sort _ | Prod _ -> mkSort (sort_of env cstr) @@ -142,15 +150,13 @@ let retype ?(polyprop=true) sigma = | _, (Prop Null as s) -> s | Prop _, (Prop Pos as s) -> s | Type _, (Prop Pos as s) when is_impredicative_set env -> s - | (Type _, _) | (_, Type _) -> new_Type_sort () -(* | Type u1, Prop Pos -> Type (Univ.sup u1 Univ.type0_univ) | Prop Pos, (Type u2) -> Type (Univ.sup Univ.type0_univ u2) | Prop Null, (Type _ as s) -> s - | Type u1, Type u2 -> Type (Univ.sup u1 u2)*)) - | App(f,args) when isGlobalRef f -> - let t = type_of_global_reference_knowing_parameters env f args in - sort_of_atomic_type env sigma t args + | Type u1, Type u2 -> Type (Univ.sup u1 u2)) + (* | App(f,args) when isGlobalRef f -> *) + (* let t = type_of_global_reference_knowing_parameters env f args in *) + (* sort_of_atomic_type env sigma t args *) | App(f,args) -> sort_of_atomic_type env sigma (type_of env f) args | Lambda _ | Fix _ | Construct _ -> retype_error NotAType | _ -> decomp_sort env sigma (type_of env t) @@ -178,12 +184,12 @@ let retype ?(polyprop=true) sigma = Array.map (fun c -> lazy (nf_evar sigma (type_of env c))) args in match kind_of_term c with | Ind ind -> - let (_,mip) = lookup_mind_specif env ind in + let mip = lookup_mind_specif env (fst ind) in (try Inductive.type_of_inductive_knowing_parameters - ~polyprop env mip argtyps + ~polyprop env (mip,snd ind) argtyps with Reduction.NotArity -> retype_error NotAnArity) | Const cst -> - let t = constant_type env cst in + let t = constant_type_in env cst in (try Typeops.type_of_constant_knowing_parameters env t argtyps with Reduction.NotArity -> retype_error NotAnArity) | Var id -> type_of_var env id @@ -203,24 +209,31 @@ let type_of_global_reference_knowing_parameters env sigma c args = let type_of_global_reference_knowing_conclusion env sigma c conclty = let conclty = nf_evar sigma conclty in match kind_of_term c with - | Ind ind -> - let (_,mip) = Inductive.lookup_mind_specif env ind in - type_of_inductive_knowing_conclusion env mip conclty + | Ind (ind,u) -> + let spec = Inductive.lookup_mind_specif env ind in + type_of_inductive_knowing_conclusion env (spec,u) conclty | Const cst -> - let t = constant_type env cst in + let t = constant_type_in env cst in (* TODO *) Typeops.type_of_constant_knowing_parameters env t [||] | Var id -> type_of_var env id | Construct cstr -> type_of_constructor env cstr | _ -> assert false -(* We are outside the kernel: we take fresh universes *) -(* to avoid tactics and co to refresh universes themselves *) -let get_type_of ?(polyprop=true) ?(refresh=true) ?(lax=false) env sigma c = +(* Profiling *) +(* let get_type_of polyprop lax env sigma c = *) +(* let f,_,_,_ = retype ~polyprop sigma in *) +(* if lax then f env c else anomaly_on_error (f env) c *) + +(* let get_type_of_key = Profile.declare_profile "get_type_of" *) +(* let get_type_of = Profile.profile5 get_type_of_key get_type_of *) + +(* let get_type_of ?(polyprop=true) ?(lax=false) env sigma c = *) +(* get_type_of polyprop lax env sigma c *) + +let get_type_of ?(polyprop=true) ?(lax=false) env sigma c = let f,_,_,_ = retype ~polyprop sigma in - let t = if lax then f env c else anomaly_on_error (f env) c in - if refresh then refresh_universes t else t + if lax then f env c else anomaly_on_error (f env) c (* Makes an unsafe judgment from a constr *) let get_judgment_of env evc c = { uj_val = c; uj_type = get_type_of env evc c } - diff --git a/pretyping/retyping.mli b/pretyping/retyping.mli index c2a08f4b9..fc1dd3564 100644 --- a/pretyping/retyping.mli +++ b/pretyping/retyping.mli @@ -26,8 +26,7 @@ type retype_error exception RetypeError of retype_error val get_type_of : - ?polyprop:bool -> ?refresh:bool -> ?lax:bool -> - env -> evar_map -> constr -> types + ?polyprop:bool -> ?lax:bool -> env -> evar_map -> constr -> types val get_sort_of : ?polyprop:bool -> env -> evar_map -> types -> sorts diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index dd7542fc7..da4595254 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -41,7 +41,8 @@ let error_not_evaluable r = spc () ++ str "to an evaluable reference.") let is_evaluable_const env cst = - is_transparent env (ConstKey cst) && evaluable_constant cst env + is_transparent env (ConstKey cst) && + (evaluable_constant cst env || is_projection cst env) let is_evaluable_var env id = is_transparent env (VarKey id) && evaluable_named id env @@ -50,12 +51,17 @@ let is_evaluable env = function | EvalConstRef cst -> is_evaluable_const env cst | EvalVarRef id -> is_evaluable_var env id -let value_of_evaluable_ref env = function - | EvalConstRef con -> constant_value env con +let value_of_evaluable_ref env evref u = + match evref with + | EvalConstRef con -> + (try constant_value_in env (con,u) + with NotEvaluableConst IsProj -> + raise (Invalid_argument "value_of_evaluable_ref")) | EvalVarRef id -> Option.get (pi2 (lookup_named id env)) -let constr_of_evaluable_ref = function - | EvalConstRef con -> mkConst con +let constr_of_evaluable_ref evref u = + match evref with + | EvalConstRef con -> mkConstU (con,u) | EvalVarRef id -> mkVar id let evaluable_of_global_reference env = function @@ -81,27 +87,43 @@ let evaluable_reference_eq r1 r2 = match r1, r2 with Evar.equal e1 e2 && Array.equal eq_constr ctx1 ctx2 | _ -> false -let mkEvalRef = function - | EvalConst cst -> mkConst cst +let mkEvalRef ref u = + match ref with + | EvalConst cst -> mkConstU (cst,u) | EvalVar id -> mkVar id | EvalRel n -> mkRel n | EvalEvar ev -> mkEvar ev let isEvalRef env c = match kind_of_term c with - | Const sp -> is_evaluable env (EvalConstRef sp) + | Const (sp,_) -> is_evaluable env (EvalConstRef sp) | Var id -> is_evaluable env (EvalVarRef id) | Rel _ | Evar _ -> true | _ -> false -let destEvalRef c = match kind_of_term c with - | Const cst -> EvalConst cst - | Var id -> EvalVar id - | Rel n -> EvalRel n - | Evar ev -> EvalEvar ev +let destEvalRefU c = match kind_of_term c with + | Const (cst,u) -> EvalConst cst, u + | Var id -> (EvalVar id, Univ.Instance.empty) + | Rel n -> (EvalRel n, Univ.Instance.empty) + | Evar ev -> (EvalEvar ev, Univ.Instance.empty) | _ -> anomaly (Pp.str "Not an unfoldable reference") -let reference_opt_value sigma env = function - | EvalConst cst -> constant_opt_value env cst +let unsafe_reference_opt_value sigma env eval = + match eval with + | EvalConst cst -> + (match (lookup_constant cst env).Declarations.const_body with + | Declarations.Def c -> Some (Mod_subst.force_constr c) + | _ -> None) + | EvalVar id -> + let (_,v,_) = lookup_named id env in + v + | EvalRel n -> + let (_,v,_) = lookup_rel n env in + Option.map (lift n) v + | EvalEvar ev -> Evd.existential_opt_value sigma ev + +let reference_opt_value sigma env eval u = + match eval with + | EvalConst cst -> constant_opt_value_in env (cst,u) | EvalVar id -> let (_,v,_) = lookup_named id env in v @@ -111,8 +133,8 @@ let reference_opt_value sigma env = function | EvalEvar ev -> Evd.existential_opt_value sigma ev exception NotEvaluable -let reference_value sigma env c = - match reference_opt_value sigma env c with +let reference_value sigma env c u = + match reference_opt_value sigma env c u with | None -> raise NotEvaluable | Some d -> d @@ -127,6 +149,7 @@ type constant_evaluation = ((int*evaluable_reference) option array * (int * (int * constr) list * int)) | EliminationCases of int + | EliminationProj of int | NotAnElimination (* We use a cache registered as a global table *) @@ -215,7 +238,7 @@ let invert_name labs l na0 env sigma ref = function match refi with | None -> None | Some ref -> - try match reference_opt_value sigma env ref with + try match unsafe_reference_opt_value sigma env ref with | None -> None | Some c -> let labs',ccl = decompose_lam c in @@ -243,9 +266,10 @@ let compute_consteval_direct sigma env ref = (try check_fix_reversibility labs l fix with Elimconst -> NotAnElimination) | Case (_,_,d,_) when isRel d -> EliminationCases n + | Proj (p, d) when isRel d -> EliminationProj n | _ -> NotAnElimination in - match reference_opt_value sigma env ref with + match unsafe_reference_opt_value sigma env ref with | None -> NotAnElimination | Some c -> srec env 0 [] c @@ -270,13 +294,13 @@ let compute_consteval_mutual_fix sigma env ref = | _ -> assert false) | _ when isEvalRef env c' -> (* Forget all \'s and args and do as if we had started with c' *) - let ref = destEvalRef c' in - (match reference_opt_value sigma env ref with + let ref,_ = destEvalRefU c' in + (match unsafe_reference_opt_value sigma env ref with | None -> anomaly (Pp.str "Should have been trapped by compute_direct") | Some c -> srec env (minarg-nargs) [] ref c) | _ -> (* Should not occur *) NotAnElimination in - match reference_opt_value sigma env ref with + match unsafe_reference_opt_value sigma env ref with | None -> (* Should not occur *) NotAnElimination | Some c -> srec env 0 [] ref c @@ -320,7 +344,7 @@ let reference_eval sigma env = function let x = Name (Id.of_string "x") -let make_elim_fun (names,(nbfix,lv,n)) largs = +let make_elim_fun (names,(nbfix,lv,n)) u largs = let lu = List.firstn n largs in let p = List.length lv in let lyi = List.map fst lv in @@ -335,7 +359,7 @@ let make_elim_fun (names,(nbfix,lv,n)) largs = match names.(i) with | None -> None | Some (minargs,ref) -> - let body = applistc (mkEvalRef ref) la in + let body = applistc (mkEvalRef ref u) la in let g = List.fold_left_i (fun q (* j = n+1-q *) c (ij,tij) -> let subst = List.map (lift (-q)) (List.firstn (n-ij) la) in @@ -392,8 +416,9 @@ let solve_arity_problem env sigma fxminargs c = else raise Partial; List.iter (check strict) rcargs | (Var _|Const _) when isEvalRef env h -> - (match reference_opt_value sigma env (destEvalRef h) with - Some h' -> + (let ev, u = destEvalRefU h in + match reference_opt_value sigma env ev u with + | Some h' -> let bak = !evm in (try List.iter (check false) rcargs with Partial -> @@ -465,7 +490,7 @@ let contract_cofix_use_function env sigma f let reduce_mind_case_use_function func env sigma mia = match kind_of_term mia.mconstr with - | Construct(ind_sp,i) -> + | Construct ((ind_sp,i),u) -> let real_cargs = List.skipn mia.mci.ci_npar mia.mcargs in applist (mia.mlf.(i-1), real_cargs) | CoFix (bodynum,(names,_,_) as cofix) -> @@ -481,12 +506,13 @@ let reduce_mind_case_use_function func env sigma mia = mutual inductive, try to reuse the global name if the block was indeed initially built as a global definition *) - let kn = con_with_label (destConst func) (Label.of_id id) + let kn = map_puniverses (fun x -> con_with_label x (Label.of_id id)) + (destConst func) in - try match constant_opt_value env kn with + try match constant_opt_value_in env kn with | None -> None (* TODO: check kn is correct *) - | Some _ -> Some (minargs,mkConst kn) + | Some _ -> Some (minargs,mkConstU kn) with Not_found -> None else fun _ -> None in @@ -495,21 +521,42 @@ let reduce_mind_case_use_function func env sigma mia = mkCase (mia.mci, mia.mP, applist(cofix_def,mia.mcargs), mia.mlf) | _ -> assert false + +let match_eval_ref env constr = + match kind_of_term constr with + | Const (sp, u) when is_evaluable env (EvalConstRef sp) -> + Some (EvalConst sp, u) + | Var id when is_evaluable env (EvalVarRef id) -> Some (EvalVar id, Univ.Instance.empty) + | Rel i -> Some (EvalRel i, Univ.Instance.empty) + | Evar ev -> Some (EvalEvar ev, Univ.Instance.empty) + | _ -> None + +let match_eval_ref_value sigma env constr = + match kind_of_term constr with + | Const (sp, u) when is_evaluable env (EvalConstRef sp) -> + Some (constant_value_in env (sp, u)) + | Var id when is_evaluable env (EvalVarRef id) -> + let (_,v,_) = lookup_named id env in v + | Rel n -> let (_,v,_) = lookup_rel n env in + Option.map (lift n) v + | Evar ev -> Evd.existential_opt_value sigma ev + | _ -> None + let special_red_case env sigma whfun (ci, p, c, lf) = let rec redrec s = let (constr, cargs) = whfun s in - if isEvalRef env constr then - let ref = destEvalRef constr in - match reference_opt_value sigma env ref with - | None -> raise Redelimination - | Some gvalue -> - if reducible_mind_case gvalue then - reduce_mind_case_use_function constr env sigma - {mP=p; mconstr=gvalue; mcargs=cargs; - mci=ci; mlf=lf} - else - redrec (applist(gvalue, cargs)) - else + match match_eval_ref env constr with + | Some (ref, u) -> + (match reference_opt_value sigma env ref u with + | None -> raise Redelimination + | Some gvalue -> + if reducible_mind_case gvalue then + reduce_mind_case_use_function constr env sigma + {mP=p; mconstr=gvalue; mcargs=cargs; + mci=ci; mlf=lf} + else + redrec (applist(gvalue, cargs))) + | None -> if reducible_mind_case constr then reduce_mind_case {mP=p; mconstr=constr; mcargs=cargs; @@ -524,6 +571,34 @@ let recargs = function | EvalConst c -> Option.map (fun (x,y,_) -> (x,y)) (ReductionBehaviour.get (ConstRef c)) +let reduce_projection env sigma proj (recarg'hd,stack') stack = + (match kind_of_term recarg'hd with + | Construct _ -> + let proj_narg = + let pb = Option.get ((lookup_constant proj env).Declarations.const_proj) in + pb.Declarations.proj_npars + pb.Declarations.proj_arg + in Reduced (List.nth stack' proj_narg, stack) + | _ -> NotReducible) + +let reduce_proj env sigma whfun c = + (* Pp.msgnl (str" reduce_proj: " ++ print_constr c); *) + let rec redrec s = + match kind_of_term s with + | Proj (proj, c) -> + let c' = try redrec c with Redelimination -> c in + let constr, cargs = whfun c' in + (* Pp.msgnl (str" reduce_proj: constructor: " ++ print_constr constr); *) + (match kind_of_term constr with + | Construct _ -> + let proj_narg = + let pb = Option.get ((lookup_constant proj env).Declarations.const_proj) in + pb.Declarations.proj_npars + pb.Declarations.proj_arg + in List.nth cargs proj_narg + | _ -> raise Redelimination) + | _ -> raise Redelimination + in redrec c + + let dont_expose_case = function | EvalVar _ | EvalRel _ | EvalEvar _ -> false | EvalConst c -> @@ -547,8 +622,8 @@ let whd_nothing_for_iota env sigma s = | Meta ev -> (try whrec (Evd.meta_value sigma ev, stack) with Not_found -> s) - | Const const when is_transparent_constant full_transparent_state const -> - (match constant_opt_value env const with + | Const const when is_transparent_constant full_transparent_state (fst const) -> + (match constant_opt_value_in env const with | Some body -> whrec (body, stack) | None -> s) | LetIn (_,b,_,c) -> stacklam whrec [b] c stack @@ -567,7 +642,7 @@ let whd_nothing_for_iota env sigma s = constants by keeping the name of the constants in the recursive calls; it fails if no redex is around *) -let rec red_elim_const env sigma ref largs = +let rec red_elim_const env sigma ref u largs = let nargs = List.length largs in let largs, unfold_anyway, unfold_nonelim = match recargs ref with @@ -586,39 +661,44 @@ let rec red_elim_const env sigma ref largs = n >= 0 && not is_empty && nargs >= n in try match reference_eval sigma env ref with | EliminationCases n when nargs >= n -> - let c = reference_value sigma env ref in + let c = reference_value sigma env ref u in let c', lrest = whd_nothing_for_iota env sigma (applist(c,largs)) in let whfun = whd_simpl_stack env sigma in (special_red_case env sigma whfun (destCase c'), lrest) + | EliminationProj n when nargs >= n -> + let c = reference_value sigma env ref u in + let c', lrest = whd_nothing_for_iota env sigma (applist(c,largs)) in + let whfun = whd_construct_stack env sigma in + (reduce_proj env sigma whfun c', lrest) | EliminationFix (min,minfxargs,infos) when nargs >= min -> - let c = reference_value sigma env ref in + let c = reference_value sigma env ref u in let d, lrest = whd_nothing_for_iota env sigma (applist(c,largs)) in - let f = make_elim_fun ([|Some (minfxargs,ref)|],infos) largs in + let f = make_elim_fun ([|Some (minfxargs,ref)|],infos) u largs in let whfun = whd_construct_stack env sigma in (match reduce_fix_use_function env sigma f whfun (destFix d) lrest with | NotReducible -> raise Redelimination | Reduced (c,rest) -> (nf_beta sigma c, rest)) | EliminationMutualFix (min,refgoal,refinfos) when nargs >= min -> - let rec descend ref args = - let c = reference_value sigma env ref in + let rec descend (ref,u) args = + let c = reference_value sigma env ref u in if evaluable_reference_eq ref refgoal then (c,args) else let c', lrest = whd_betalet_stack sigma (applist(c,args)) in - descend (destEvalRef c') lrest in - let (_, midargs as s) = descend ref largs in + descend (destEvalRefU c') lrest in + let (_, midargs as s) = descend (ref,u) largs in let d, lrest = whd_nothing_for_iota env sigma (applist s) in - let f = make_elim_fun refinfos midargs in + let f = make_elim_fun refinfos u midargs in let whfun = whd_construct_stack env sigma in (match reduce_fix_use_function env sigma f whfun (destFix d) lrest with | NotReducible -> raise Redelimination | Reduced (c,rest) -> (nf_beta sigma c, rest)) | NotAnElimination when unfold_nonelim -> - let c = reference_value sigma env ref in + let c = reference_value sigma env ref u in whd_betaiotazeta sigma (applist (c, largs)), [] | _ -> raise Redelimination with Redelimination when unfold_anyway -> - let c = reference_value sigma env ref in + let c = reference_value sigma env ref u in whd_betaiotazeta sigma (applist (c, largs)), [] (* reduce to whd normal form or to an applied constant that does not hide @@ -645,20 +725,31 @@ and whd_simpl_stack env sigma = | Reduced s' -> redrec (applist s') | NotReducible -> s' with Redelimination -> s') - | _ when isEvalRef env x -> - let ref = destEvalRef x in + + | Proj (p, c) -> + (try + (match recargs (EvalConst p) with + | Some (_, n) when n > 1 -> (* simpl never *) s' + | _ -> + match reduce_projection env sigma p (whd_construct_stack env sigma c) stack with + | Reduced s' -> redrec (applist s') + | NotReducible -> s') + with Redelimination -> s') + + | _ -> + match match_eval_ref env x with + | Some (ref, u) -> (try - let hd, _ as s'' = redrec (applist(red_elim_const env sigma ref stack)) in - let rec is_case x = match kind_of_term x with - | Lambda (_,_, x) | LetIn (_,_,_, x) | Cast (x, _,_) -> is_case x - | App (hd, _) -> is_case hd - | Case _ -> true - | _ -> false in - if dont_expose_case ref && is_case hd then raise Redelimination - else s'' - with Redelimination -> - s') - | _ -> s' + let hd, _ as s'' = redrec (applist(red_elim_const env sigma ref u stack)) in + let rec is_case x = match kind_of_term x with + | Lambda (_,_, x) | LetIn (_,_,_, x) | Cast (x, _,_) -> is_case x + | App (hd, _) -> is_case hd + | Case _ -> true + | _ -> false in + if dont_expose_case ref && is_case hd then raise Redelimination + else s'' + with Redelimination -> s') + | None -> s' in redrec @@ -667,13 +758,12 @@ and whd_simpl_stack env sigma = and whd_construct_stack env sigma s = let (constr, cargs as s') = whd_simpl_stack env sigma s in if reducible_mind_case constr then s' - else if isEvalRef env constr then - let ref = destEvalRef constr in - match reference_opt_value sigma env ref with - | None -> raise Redelimination - | Some gvalue -> whd_construct_stack env sigma (applist(gvalue, cargs)) - else - raise Redelimination + else match match_eval_ref env constr with + | Some (ref, u) -> + (match reference_opt_value sigma env ref u with + | None -> raise Redelimination + | Some gvalue -> whd_construct_stack env sigma (applist(gvalue, cargs))) + | _ -> raise Redelimination (************************************************************************) (* Special Purpose Reduction Strategies *) @@ -703,14 +793,24 @@ let try_red_product env sigma c = | Prod (x,a,b) -> mkProd (x, a, redrec (push_rel (x,None,a) env) b) | LetIn (x,a,b,t) -> redrec env (subst1 a t) | Case (ci,p,d,lf) -> simpfun (mkCase (ci,p,redrec env d,lf)) - | _ when isEvalRef env x -> + | Proj (p, c) -> + let c' = + match kind_of_term c with + | Construct _ -> c + | _ -> redrec env c + in + (match reduce_projection env sigma p (whd_betaiotazeta_stack sigma c') [] with + | Reduced s -> simpfun (applist s) + | NotReducible -> raise Redelimination) + | _ -> + (match match_eval_ref env x with + | Some (ref, u) -> (* TO DO: re-fold fixpoints after expansion *) (* to get true one-step reductions *) - let ref = destEvalRef x in - (match reference_opt_value sigma env ref with + (match reference_opt_value sigma env ref u with | None -> raise Redelimination | Some c -> c) - | _ -> raise Redelimination + | _ -> raise Redelimination) in redrec env c let red_product env sigma c = @@ -778,14 +878,13 @@ let whd_simpl_orelse_delta_but_fix_old env sigma c = let whd_simpl_orelse_delta_but_fix env sigma c = let rec redrec s = let (constr, stack as s') = whd_simpl_stack env sigma s in - if isEvalRef env constr then - match reference_opt_value sigma env (destEvalRef constr) with - | Some c -> - (match kind_of_term (strip_lam c) with - | CoFix _ | Fix _ -> s' - | _ -> redrec (applist(c, stack))) - | None -> s' - else s' in + match match_eval_ref_value sigma env constr with + | Some c -> + (match kind_of_term (strip_lam c) with + | CoFix _ | Fix _ -> s' + | _ -> redrec (applist(c, stack))) + | None -> s' + in let simpfun = clos_norm_flags betaiota env sigma in simpfun (applist (redrec c)) @@ -803,12 +902,14 @@ let simpl env sigma c = strong whd_simpl env sigma c let matches_head c t = match kind_of_term t with | App (f,_) -> ConstrMatching.matches c f + | Proj (p, _) -> ConstrMatching.matches c (mkConst p) | _ -> raise ConstrMatching.PatternMatchingFailure -let contextually byhead (occs,c) f env sigma t = +let e_contextually byhead (occs,c) f env sigma t = let (nowhere_except_in,locs) = Locusops.convert_occs occs in let maxocc = List.fold_right max locs 0 in let pos = ref 1 in + let evd = ref sigma in let rec traverse (env,c as envc) t = if nowhere_except_in && (!pos > maxocc) then t else @@ -821,11 +922,15 @@ let contextually byhead (occs,c) f env sigma t = incr pos; if ok then let subst' = Id.Map.map (traverse envc) subst in - f subst' env sigma t + let evm, t = f subst' env !evd t in + (evd := evm; t) else if byhead then (* find other occurrences of c in t; TODO: ensure left-to-right *) - let (f,l) = destApp t in - mkApp (f, Array.map_left (traverse envc) l) + (match kind_of_term t with + | App (f,l) -> + mkApp (f, Array.map_left (traverse envc) l) + | Proj (p,c) -> mkProj (p,traverse envc c) + | _ -> assert false) else t with ConstrMatching.PatternMatchingFailure -> @@ -835,30 +940,45 @@ let contextually byhead (occs,c) f env sigma t = in let t' = traverse (env,c) t in if List.exists (fun o -> o >= !pos) locs then error_invalid_occurrence locs; - t' + !evd, t' + +let contextually byhead occs f env sigma t = + let f' subst env sigma t = sigma, f subst env sigma t in + snd (e_contextually byhead occs f' env sigma t) (* linear bindings (following pretty-printer) of the value of name in c. * n is the number of the next occurence of name. * ol is the occurence list to find. *) -let substlin env evalref n (nowhere_except_in,locs) c = +let match_constr_evaluable_ref sigma c evref = + match kind_of_term c, evref with + | Const (c,u), EvalConstRef c' when eq_constant c c' -> Some u + | Proj (p,c), EvalConstRef p' when eq_constant p p' -> Some Univ.Instance.empty + | Var id, EvalVarRef id' when id_eq id id' -> Some Univ.Instance.empty + | _, _ -> None + +let substlin env sigma evalref n (nowhere_except_in,locs) c = let maxocc = List.fold_right max locs 0 in let pos = ref n in assert (List.for_all (fun x -> x >= 0) locs); - let value = value_of_evaluable_ref env evalref in - let term = constr_of_evaluable_ref evalref in + let value u = + value_of_evaluable_ref env evalref u + (* Some (whd_betaiotazeta sigma c) *) + in let rec substrec () c = if nowhere_except_in && !pos > maxocc then c - else if eq_constr c term then - let ok = - if nowhere_except_in then Int.List.mem !pos locs - else not (Int.List.mem !pos locs) in - incr pos; - if ok then value else c - else - map_constr_with_binders_left_to_right - (fun _ () -> ()) - substrec () c + else + match match_constr_evaluable_ref sigma c evalref with + | Some u -> + let ok = + if nowhere_except_in then Int.List.mem !pos locs + else not (Int.List.mem !pos locs) in + incr pos; + if ok then value u else c + | None -> + map_constr_with_binders_left_to_right + (fun _ () -> ()) + substrec () c in let t' = substrec () c in (!pos, t') @@ -881,7 +1001,7 @@ let unfold env sigma name = * Performs a betaiota reduction after unfolding. *) let unfoldoccs env sigma (occs,name) c = let unfo nowhere_except_in locs = - let (nbocc,uc) = substlin env name 1 (nowhere_except_in,locs) c in + let (nbocc,uc) = substlin env sigma name 1 (nowhere_except_in,locs) c in if Int.equal nbocc 1 then error ((string_of_evaluable_ref env name)^" does not occur."); let rest = List.filter (fun o -> o >= nbocc) locs in @@ -934,6 +1054,22 @@ let compute = cbv_betadeltaiota (* Pattern *) +let make_eq_univs_test evd c = + { match_fun = (fun evd c' -> + let b, cst = eq_constr_universes c c' in + if b then + try Evd.add_universe_constraints evd cst + with Evd.UniversesDiffer -> raise NotUnifiable + else raise NotUnifiable); + merge_fun = (fun evd _ -> evd); + testing_state = evd; + last_found = None +} +let subst_closed_term_univs_occ evd occs c t = + let test = make_eq_univs_test evd c in + let t' = subst_closed_term_occ_modulo occs test None t in + t', test.testing_state + (* gives [na:ta]c' such that c converts to ([na:ta]c' a), abstracting only * the specified occurrences. *) @@ -944,7 +1080,8 @@ let abstract_scheme env sigma (locc,a) c = if occur_meta a then mkLambda (na,ta,c) else - mkLambda (na,ta,subst_closed_term_occ locc a c) + let c', sigma' = subst_closed_term_univs_occ sigma locc a c in + mkLambda (na,ta,c') let pattern_occs loccs_trm env sigma c = let abstr_trm = List.fold_right (abstract_scheme env sigma) loccs_trm c in @@ -1011,11 +1148,11 @@ let one_step_reduce env sigma c = | Reduced s' -> s' | NotReducible -> raise NotStepReducible) | _ when isEvalRef env x -> - let ref = destEvalRef x in + let ref,u = destEvalRefU x in (try - red_elim_const env sigma ref stack + red_elim_const env sigma ref u stack with Redelimination -> - match reference_opt_value sigma env ref with + match reference_opt_value sigma env ref u with | Some d -> (d, stack) | None -> raise NotStepReducible) @@ -1027,7 +1164,7 @@ let isIndRef = function IndRef _ -> true | _ -> false let reduce_to_ref_gen allow_product env sigma ref t = if isIndRef ref then - let (mind,t) = reduce_to_ind_gen allow_product env sigma t in + let ((mind,u),t) = reduce_to_ind_gen allow_product env sigma t in begin match ref with | IndRef mind' when eq_ind mind mind' -> t | _ -> diff --git a/pretyping/tacred.mli b/pretyping/tacred.mli index 34aca3e33..5146cd345 100644 --- a/pretyping/tacred.mli +++ b/pretyping/tacred.mli @@ -59,8 +59,17 @@ val unfoldn : (** Fold *) val fold_commands : constr list -> reduction_function +val make_eq_univs_test : evar_map -> constr -> evar_map Termops.testing_function + +(** [subst_closed_term_occ occl c d] replaces occurrences of closed [c] at + positions [occl] by [Rel 1] in [d] (see also Note OCC), unifying universes + which results in a set of constraints. *) +val subst_closed_term_univs_occ : evar_map -> occurrences -> constr -> constr -> + constr * evar_map + (** Pattern *) -val pattern_occs : (occurrences * constr) list -> reduction_function +val pattern_occs : (occurrences * constr) list -> env -> evar_map -> constr -> + constr (** Rem: Lazy strategies are defined in Reduction *) @@ -74,12 +83,12 @@ val cbv_norm_flags : Closure.RedFlags.reds -> reduction_function (** [reduce_to_atomic_ind env sigma t] puts [t] in the form [t'=(I args)] with [I] an inductive definition; returns [I] and [t'] or fails with a user error *) -val reduce_to_atomic_ind : env -> evar_map -> types -> inductive * types +val reduce_to_atomic_ind : env -> evar_map -> types -> pinductive * types (** [reduce_to_quantified_ind env sigma t] puts [t] in the form [t'=(x1:A1)..(xn:An)(I args)] with [I] an inductive definition; returns [I] and [t'] or fails with a user error *) -val reduce_to_quantified_ind : env -> evar_map -> types -> inductive * types +val reduce_to_quantified_ind : env -> evar_map -> types -> pinductive * types (** [reduce_to_quantified_ref env sigma ref t] try to put [t] in the form [t'=(x1:A1)..(xn:An)(ref args)] and fails with user error if not possible *) @@ -90,7 +99,10 @@ val reduce_to_atomic_ref : env -> evar_map -> global_reference -> types -> types val find_hnf_rectype : - env -> evar_map -> types -> inductive * constr list + env -> evar_map -> types -> pinductive * constr list val contextually : bool -> occurrences * constr_pattern -> (patvar_map -> reduction_function) -> reduction_function + +val e_contextually : bool -> occurrences * constr_pattern -> + (patvar_map -> e_reduction_function) -> e_reduction_function diff --git a/pretyping/term_dnet.ml b/pretyping/term_dnet.ml index 10ec651fa..e05f4bcfe 100644 --- a/pretyping/term_dnet.ml +++ b/pretyping/term_dnet.ml @@ -261,9 +261,9 @@ struct | Rel _ -> Term DRel | Sort _ -> Term DSort | Var i -> Term (DRef (VarRef i)) - | Const c -> Term (DRef (ConstRef c)) - | Ind i -> Term (DRef (IndRef i)) - | Construct c -> Term (DRef (ConstructRef c)) + | Const (c,u) -> Term (DRef (ConstRef c)) + | Ind (i,u) -> Term (DRef (IndRef i)) + | Construct (c,u)-> Term (DRef (ConstructRef c)) | Term.Meta _ -> assert false | Evar (i,_) -> let meta = @@ -287,6 +287,8 @@ struct | App (f,ca) -> Array.fold_left (fun c a -> Term (DApp (c,a))) (pat_of_constr f) (Array.map pat_of_constr ca) + | Proj (p,c) -> + Term (DApp (Term (DRef (ConstRef p)), pat_of_constr c)) and ctx_of_constr ctx c = match kind_of_term c with | Prod (_,t,c) -> ctx_of_constr (Term(DCons((pat_of_constr t,None),ctx))) c diff --git a/pretyping/termops.ml b/pretyping/termops.ml index 741601167..b3fa53eee 100644 --- a/pretyping/termops.ml +++ b/pretyping/termops.ml @@ -22,7 +22,7 @@ open Locus let print_sort = function | Prop Pos -> (str "Set") | Prop Null -> (str "Prop") - | Type u -> (str "Type(" ++ Univ.pr_uni u ++ str ")") + | Type u -> (str "Type(" ++ Univ.Universe.pr u ++ str ")") let pr_sort_family = function | InSet -> (str "Set") @@ -44,6 +44,10 @@ let pr_fix pr_constr ((t,i),(lna,tl,bl)) = cut() ++ str":=" ++ pr_constr bd) (Array.to_list fixl)) ++ str"}") +let pr_puniverses p u = + if Univ.Instance.is_empty u then p + else p ++ str"(*" ++ Univ.Instance.pr u ++ str"*)" + let rec pr_constr c = match kind_of_term c with | Rel n -> str "#"++int n | Meta n -> str "Meta(" ++ int n ++ str ")" @@ -71,10 +75,11 @@ let rec pr_constr c = match kind_of_term c with | Evar (e,l) -> hov 1 (str"Evar#" ++ int (Evar.repr e) ++ str"{" ++ prlist_with_sep spc pr_constr (Array.to_list l) ++str"}") - | Const c -> str"Cst(" ++ pr_con c ++ str")" - | Ind (sp,i) -> str"Ind(" ++ pr_mind sp ++ str"," ++ int i ++ str")" - | Construct ((sp,i),j) -> - str"Constr(" ++ pr_mind sp ++ str"," ++ int i ++ str"," ++ int j ++ str")" + | Const (c,u) -> str"Cst(" ++ pr_puniverses (pr_con c) u ++ str")" + | Ind ((sp,i),u) -> str"Ind(" ++ pr_puniverses (pr_mind sp ++ str"," ++ int i) u ++ str")" + | Construct (((sp,i),j),u) -> + str"Constr(" ++ pr_puniverses (pr_mind sp ++ str"," ++ int i ++ str"," ++ int j) u ++ str")" + | Proj (p,c) -> str"Proj(" ++ pr_con p ++ str"," ++ pr_constr c ++ str")" | Case (ci,p,c,bl) -> v 0 (hv 0 (str"<"++pr_constr p++str">"++ cut() ++ str"Case " ++ pr_constr c ++ str"of") ++ cut() ++ @@ -145,41 +150,6 @@ let print_env env = in (sign_env ++ db_env) -(*let current_module = ref DirPath.empty - -let set_module m = current_module := m*) - -let new_univ_level, set_remote_new_univ_level = - RemoteCounter.new_counter ~name:"univ_level" 0 ~incr:((+) 1) - ~build:(fun n -> Univ.UniverseLevel.make (Lib.library_dp()) n) - -let new_univ () = Univ.Universe.make (new_univ_level ()) -let new_Type () = mkType (new_univ ()) -let new_Type_sort () = Type (new_univ ()) - -(* This refreshes universes in types; works only for inferred types (i.e. for - types of the form (x1:A1)...(xn:An)B with B a sort or an atom in - head normal form) *) -let refresh_universes_gen strict t = - let modified = ref false in - let rec refresh t = match kind_of_term t with - | Sort (Type u) when strict || not (Univ.is_type0m_univ u) -> - modified := true; new_Type () - | Prod (na,u,v) -> mkProd (na,u,refresh v) - | _ -> t in - let t' = refresh t in - if !modified then t' else t - -let refresh_universes = refresh_universes_gen false -let refresh_universes_strict = refresh_universes_gen true - -let new_sort_in_family = function - | InProp -> prop_sort - | InSet -> set_sort - | InType -> Type (new_univ ()) - - - (* [Rel (n+m);...;Rel(n+1)] *) let rel_vect n m = Array.init m (fun i -> mkRel(n+m-i)) @@ -319,6 +289,7 @@ let map_constr_with_named_binders g f l c = match kind_of_term c with | Lambda (na,t,c) -> mkLambda (na, f l t, f (g na l) c) | LetIn (na,b,t,c) -> mkLetIn (na, f l b, f l t, f (g na l) c) | App (c,al) -> mkApp (f l c, Array.map (f l) al) + | Proj (p,c) -> mkProj (p, f l c) | Evar (e,al) -> mkEvar (e, Array.map (f l) al) | Case (ci,p,c,bl) -> mkCase (ci, f l p, f l c, Array.map (f l) bl) | Fix (ln,(lna,tl,bl)) -> @@ -375,6 +346,8 @@ let map_constr_with_binders_left_to_right g f l c = match kind_of_term c with let a = al.(Array.length al - 1) in let hd = f l (mkApp (c, Array.sub al 0 (Array.length al - 1))) in mkApp (hd, [| f l a |]) + | Proj (p,c) -> + mkProj (p, f l c) | Evar (e,al) -> mkEvar (e, Array.map_left (f l) al) | Case (ci,p,c,bl) -> (* In v8 concrete syntax, predicate is after the term to match! *) @@ -415,6 +388,9 @@ let map_constr_with_full_binders g f l cstr = match kind_of_term cstr with let c' = f l c in let al' = Array.map (f l) al in if c==c' && Array.for_all2 (==) al al' then cstr else mkApp (c', al') + | Proj (p,c) -> + let c' = f l c in + if c' == c then cstr else mkProj (p, c') | Evar (e,al) -> let al' = Array.map (f l) al in if Array.for_all2 (==) al al' then cstr else mkEvar (e, al') @@ -456,6 +432,7 @@ let fold_constr_with_binders g f n acc c = match kind_of_term c with | Lambda (_,t,c) -> f (g n) (f n acc t) c | LetIn (_,b,t,c) -> f (g n) (f n (f n acc b) t) c | App (c,l) -> Array.fold_left (f n) (f n acc c) l + | Proj (p,c) -> f n acc c | Evar (_,l) -> Array.fold_left (f n) acc l | Case (_,p,c,bl) -> Array.fold_left (f n) (f n (f n acc p) c) bl | Fix (_,(lna,tl,bl)) -> @@ -480,6 +457,7 @@ let iter_constr_with_full_binders g f l c = match kind_of_term c with | Lambda (na,t,c) -> f l t; f (g (na,None,t) l) c | LetIn (na,b,t,c) -> f l b; f l t; f (g (na,Some b,t) l) c | App (c,args) -> f l c; Array.iter (f l) args + | Proj (p,c) -> f l c | Evar (_,args) -> Array.iter (f l) args | Case (_,p,c,bl) -> f l p; f l c; Array.iter (f l) bl | Fix (_,(lna,tl,bl)) -> @@ -516,6 +494,13 @@ let occur_meta_or_existential c = | _ -> iter_constr occrec c in try occrec c; false with Occur -> true +let occur_const s c = + let rec occur_rec c = match kind_of_term c with + | Const (sp,_) when sp=s -> raise Occur + | _ -> iter_constr occur_rec c + in + try occur_rec c; false with Occur -> true + let occur_evar n c = let rec occur_rec c = match kind_of_term c with | Evar (sp,_) when Evar.equal sp n -> raise Occur @@ -573,9 +558,10 @@ let collect_vars c = (* Tests whether [m] is a subterm of [t]: [m] is appropriately lifted through abstractions of [t] *) -let dependent_main noevar m t = +let dependent_main noevar univs m t = + let eqc x y = if univs then fst (eq_constr_universes x y) else eq_constr_nounivs x y in let rec deprec m t = - if eq_constr m t then + if eqc m t then raise Occur else match kind_of_term m, kind_of_term t with @@ -590,8 +576,11 @@ let dependent_main noevar m t = in try deprec m t; false with Occur -> true -let dependent = dependent_main false -let dependent_no_evar = dependent_main true +let dependent = dependent_main false false +let dependent_no_evar = dependent_main true false + +let dependent_univs = dependent_main false true +let dependent_univs_no_evar = dependent_main true true let count_occurrences m t = let n = ref 0 in @@ -725,7 +714,7 @@ let error_cannot_unify_occurrences nested (cl2,pos2,t2) (cl1,pos1,t1) = exception NotUnifiable type 'a testing_function = { - match_fun : constr -> 'a; + match_fun : 'a -> constr -> 'a; merge_fun : 'a -> 'a -> 'a; mutable testing_state : 'a; mutable last_found : ((Id.t * hyp_location_flag) option * int * constr) option @@ -746,7 +735,7 @@ let subst_closed_term_occ_gen_modulo occs test cl occ t = let rec substrec k t = if nowhere_except_in && !pos > maxocc then t else try - let subst = test.match_fun t in + let subst = test.match_fun test.testing_state t in if Locusops.is_selected !pos occs then (add_subst t subst; incr pos; (* Check nested matching subterms *) @@ -781,7 +770,7 @@ let proceed_with_occurrences f occs x = x let make_eq_test c = { - match_fun = (fun c' -> if eq_constr c c' then () else raise NotUnifiable); + match_fun = (fun () c' -> if eq_constr c c' then () else raise NotUnifiable); merge_fun = (fun () () -> ()); testing_state = (); last_found = None @@ -879,10 +868,7 @@ let isGlobalRef c = | Const _ | Ind _ | Construct _ | Var _ -> true | _ -> false -let has_polymorphic_type c = - match (Global.lookup_constant c).Declarations.const_type with - | Declarations.PolymorphicArity _ -> true - | _ -> false +let has_polymorphic_type c = (Global.lookup_constant c).Declarations.const_polymorphic let base_sort_cmp pb s0 s1 = match (s0,s1) with @@ -1117,9 +1103,11 @@ let coq_unit_judge = let na2 = Name (Id.of_string "H") in fun () -> match !impossible_default_case with - | Some (id,type_of_id) -> - make_judge id type_of_id + | Some fn -> + let (id,type_of_id), ctx = fn () in + make_judge id type_of_id, ctx | None -> (* In case the constants id/ID are not defined *) make_judge (mkLambda (na1,mkProp,mkLambda(na2,mkRel 1,mkRel 1))) - (mkProd (na1,mkProp,mkArrow (mkRel 1) (mkRel 2))) + (mkProd (na1,mkProp,mkArrow (mkRel 1) (mkRel 2))), + Univ.ContextSet.empty diff --git a/pretyping/termops.mli b/pretyping/termops.mli index d0d3fd767..eec4a9b9d 100644 --- a/pretyping/termops.mli +++ b/pretyping/termops.mli @@ -13,18 +13,6 @@ open Context open Environ open Locus -(** TODO: merge this with Term *) - -(** Universes *) -val new_univ_level : unit -> Univ.universe_level -val set_remote_new_univ_level : Univ.universe_level RemoteCounter.installer -val new_univ : unit -> Univ.universe -val new_sort_in_family : sorts_family -> sorts -val new_Type : unit -> types -val new_Type_sort : unit -> sorts -val refresh_universes : types -> types -val refresh_universes_strict : types -> types - (** printers *) val print_sort : sorts -> std_ppcmds val pr_sort_family : sorts_family -> std_ppcmds @@ -120,6 +108,8 @@ val free_rels : constr -> Int.Set.t (** [dependent m t] tests whether [m] is a subterm of [t] *) val dependent : constr -> constr -> bool val dependent_no_evar : constr -> constr -> bool +val dependent_univs : constr -> constr -> bool +val dependent_univs_no_evar : constr -> constr -> bool val count_occurrences : constr -> constr -> int val collect_metas : constr -> int list val collect_vars : constr -> Id.Set.t (** for visible vars only *) @@ -168,7 +158,7 @@ val subst_closed_term_occ_gen : required too *) type 'a testing_function = { - match_fun : constr -> 'a; + match_fun : 'a -> constr -> 'a; merge_fun : 'a -> 'a -> 'a; mutable testing_state : 'a; mutable last_found : ((Id.t * hyp_location_flag) option * int * constr) option @@ -290,5 +280,5 @@ val on_judgment_value : (types -> types) -> unsafe_judgment -> unsafe_judgment val on_judgment_type : (types -> types) -> unsafe_judgment -> unsafe_judgment (** {6 Functions to deal with impossible cases } *) -val set_impossible_default_clause : constr * types -> unit -val coq_unit_judge : unit -> unsafe_judgment +val set_impossible_default_clause : (unit -> (constr * types) Univ.in_universe_context_set) -> unit +val coq_unit_judge : unit -> unsafe_judgment Univ.in_universe_context_set diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml index b5735bc64..fac73670b 100644 --- a/pretyping/typeclasses.ml +++ b/pretyping/typeclasses.ml @@ -20,7 +20,6 @@ open Typeclasses_errors open Libobject (*i*) - let (add_instance_hint, add_instance_hint_hook) = Hook.make () let add_instance_hint id = Hook.get add_instance_hint id @@ -64,6 +63,7 @@ type instance = { -1 for discard, 0 for none, mutable to avoid redeclarations when multiple rebuild_object happen. *) is_global: int; + is_poly: bool; is_impl: global_reference; } @@ -73,7 +73,7 @@ let instance_impl is = is.is_impl let instance_priority is = is.is_pri -let new_instance cl pri glob impl = +let new_instance cl pri glob poly impl = let global = if glob then Lib.sections_depth () else -1 @@ -81,6 +81,7 @@ let new_instance cl pri glob impl = { is_class = cl.cl_impl; is_pri = pri ; is_global = global ; + is_poly = poly; is_impl = impl } (* @@ -90,12 +91,35 @@ let new_instance cl pri glob impl = let classes : typeclasses ref = Summary.ref Refmap.empty ~name:"classes" let instances : instances ref = Summary.ref Refmap.empty ~name:"instances" +open Declarations + +let typeclass_univ_instance (cl,u') = + let subst = + let u = + match cl.cl_impl with + | ConstRef c -> + let cb = Global.lookup_constant c in + if cb.const_polymorphic then Univ.UContext.instance (Future.force cb.const_universes) + else Univ.Instance.empty + | IndRef c -> + let mib,oib = Global.lookup_inductive c in + if mib.mind_polymorphic then Univ.UContext.instance mib.mind_universes + else Univ.Instance.empty + | _ -> Univ.Instance.empty + in Array.fold_left2 (fun subst u u' -> Univ.LMap.add u u' subst) + Univ.LMap.empty (Univ.Instance.to_array u) (Univ.Instance.to_array u') + in + let subst_ctx = Context.map_rel_context (subst_univs_level_constr subst) in + { cl with cl_context = fst cl.cl_context, subst_ctx (snd cl.cl_context); + cl_props = subst_ctx cl.cl_props}, u' + let class_info c = try Refmap.find c !classes - with Not_found -> not_a_class (Global.env()) (constr_of_global c) + with Not_found -> not_a_class (Global.env()) (printable_constr_of_global c) let global_class_of_constr env c = - try class_info (global_of_constr c) + try let gr, u = Universes.global_of_constr c in + class_info gr, u with Not_found -> not_a_class env c let dest_class_app env c = @@ -110,16 +134,19 @@ let class_of_constr c = try Some (dest_class_arity (Global.env ()) c) with e when Errors.noncritical e -> None -let rec is_class_type evd c = - match kind_of_term c with - | Prod (_, _, t) -> is_class_type evd t - | Evar (e, _) when is_defined evd e -> is_class_type evd (Evarutil.nf_evar evd c) - | _ -> - begin match class_of_constr c with - | Some _ -> true - | None -> false - end +let is_class_constr c = + try let gr, u = Universes.global_of_constr c in + Refmap.mem gr !classes + with Not_found -> false +let rec is_class_type evd c = + let c, args = decompose_app c in + match kind_of_term c with + | Prod (_, _, t) -> is_class_type evd t + | Evar (e, _) when Evd.is_defined evd e -> + is_class_type evd (Evarutil.whd_head_evar evd c) + | _ -> is_class_constr c + let is_class_evar evd evi = is_class_type evd evi.Evd.evar_concl @@ -133,7 +160,7 @@ let load_class (_, cl) = let cache_class = load_class let subst_class (subst,cl) = - let do_subst_con c = fst (Mod_subst.subst_con subst c) + let do_subst_con c = Mod_subst.subst_constant subst c and do_subst c = Mod_subst.subst_mps subst c and do_subst_gr gr = fst (subst_global subst gr) in let do_subst_ctx ctx = List.smartmap @@ -142,7 +169,8 @@ let subst_class (subst,cl) = let do_subst_context (grs,ctx) = List.smartmap (Option.smartmap (fun (gr,b) -> do_subst_gr gr, b)) grs, do_subst_ctx ctx in - let do_subst_projs projs = List.smartmap (fun (x, y, z) -> (x, y, Option.smartmap do_subst_con z)) projs in + let do_subst_projs projs = List.smartmap (fun (x, y, z) -> + (x, y, Option.smartmap do_subst_con z)) projs in { cl_impl = do_subst_gr cl.cl_impl; cl_context = do_subst_context cl.cl_context; cl_props = do_subst_ctx cl.cl_props; @@ -174,7 +202,7 @@ let discharge_class (_,cl) = let newgrs = List.map (fun (_, _, t) -> match class_of_constr t with | None -> None - | Some (_, (tc, _)) -> Some (tc.cl_impl, true)) + | Some (_, ((tc,_), _)) -> Some (tc.cl_impl, true)) ctx' in List.smartmap (Option.smartmap (fun (gr, b) -> Lib.discharge_global gr, b)) grs @@ -182,7 +210,7 @@ let discharge_class (_,cl) = in grs', discharge_rel_context subst 1 ctx @ ctx' in let cl_impl' = Lib.discharge_global cl.cl_impl in if cl_impl' == cl.cl_impl then cl else - let ctx = abs_context cl in + let ctx, uctx = abs_context cl in let ctx, subst = rel_of_variable_context ctx in let context = discharge_context ctx subst cl.cl_context in let props = discharge_rel_context subst (succ (List.length (fst cl.cl_context))) cl.cl_props in @@ -217,7 +245,7 @@ let check_instance env sigma c = try let (evd, c) = resolve_one_typeclass env sigma (Retyping.get_type_of env sigma c) in - Evd.has_undefined evd + not (Evd.has_undefined evd) with e when Errors.noncritical e -> false let build_subclasses ~check env sigma glob pri = @@ -231,7 +259,7 @@ let build_subclasses ~check env sigma glob pri = let ty = Evarutil.nf_evar sigma (Retyping.get_type_of env sigma c) in match class_of_constr ty with | None -> [] - | Some (rels, (tc, args)) -> + | Some (rels, ((tc,u), args)) -> let instapp = Reductionops.whd_beta sigma (appvectc c (Termops.extended_rel_vect 0 rels)) in @@ -243,7 +271,7 @@ let build_subclasses ~check env sigma glob pri = | Some (Backward, _) -> None | Some (Forward, pri') -> let proj = Option.get proj in - let body = it_mkLambda_or_LetIn (mkApp (mkConst proj, projargs)) rels in + let body = it_mkLambda_or_LetIn (mkApp (mkConstU (proj,u), projargs)) rels in if check && check_instance env sigma body then None else let pri = @@ -259,7 +287,7 @@ let build_subclasses ~check env sigma glob pri = let rest = aux pri body path' in hints @ (path', pri, body) :: rest in List.fold_left declare_proj [] projs - in aux pri (constr_of_global glob) [glob] + in aux pri (Universes.constr_of_global glob) [glob] (* * instances persistent object @@ -305,9 +333,11 @@ let discharge_instance (_, (action, inst)) = let is_local i = Int.equal i.is_global (-1) let add_instance check inst = - add_instance_hint (IsGlobal inst.is_impl) [inst.is_impl] (is_local inst) inst.is_pri; + let poly = Global.is_polymorphic inst.is_impl in + add_instance_hint (IsGlobal inst.is_impl) [inst.is_impl] (is_local inst) + inst.is_pri poly; List.iter (fun (path, pri, c) -> add_instance_hint (IsConstr c) path - (is_local inst) pri) + (is_local inst) pri poly) (build_subclasses ~check:(check && not (isVarRef inst.is_impl)) (Global.env ()) Evd.empty inst.is_impl inst.is_pri) @@ -342,11 +372,10 @@ let remove_instance i = remove_instance_hint i.is_impl let declare_instance pri local glob = - let c = constr_of_global glob in - let ty = Retyping.get_type_of (Global.env ()) Evd.empty c in + let ty = Global.type_of_global_unsafe (*FIXME*) glob in match class_of_constr ty with - | Some (rels, (tc, args) as _cl) -> - add_instance (new_instance tc pri (not local) glob) + | Some (rels, ((tc,_), args) as _cl) -> + add_instance (new_instance tc pri (not local) (Flags.use_polymorphic_flag ()) glob) (* let path, hints = build_subclasses (not local) (Global.env ()) Evd.empty glob in *) (* let entries = List.map (fun (path, pri, c) -> (pri, local, path, c)) hints in *) (* Auto.add_hints local [typeclasses_db] (Auto.HintsResolveEntry entries); *) @@ -367,9 +396,9 @@ let add_class cl = open Declarations - +(* FIXME: deal with universe instances *) let add_constant_class cst = - let ty = Typeops.type_of_constant (Global.env ()) cst in + let ty = Typeops.type_of_constant_in (Global.env ()) (cst,Univ.Instance.empty) in let ctx, arity = decompose_prod_assum ty in let tc = { cl_impl = ConstRef cst; @@ -386,7 +415,8 @@ let add_inductive_class ind = let ctx = oneind.mind_arity_ctxt in let ty = Inductive.type_of_inductive_knowing_parameters (push_rel_context ctx (Global.env ())) - oneind (Array.map (fun x -> lazy x) (Termops.extended_rel_vect 0 ctx)) + ((mind,oneind),Univ.Instance.empty) + (Array.map (fun x -> lazy x) (Termops.extended_rel_vect 0 ctx)) in { cl_impl = IndRef ind; cl_context = List.map (const None) ctx, ctx; @@ -398,7 +428,7 @@ let add_inductive_class ind = * interface functions *) -let instance_constructor cl args = +let instance_constructor (cl,u) args = let filter (_, b, _) = match b with | None -> true | Some _ -> false @@ -406,14 +436,17 @@ let instance_constructor cl args = let lenpars = List.length (List.filter filter (snd cl.cl_context)) in let pars = fst (List.chop lenpars args) in match cl.cl_impl with - | IndRef ind -> Some (applistc (mkConstruct (ind, 1)) args), - applistc (mkInd ind) pars + | IndRef ind -> + let ind = ind, u in + (Some (applistc (mkConstructUi (ind, 1)) args), + applistc (mkIndU ind) pars) | ConstRef cst -> + let cst = cst, u in let term = match args with - | [] -> None - | _ -> Some (List.last args) + | [] -> None + | _ -> Some (List.last args) in - term, applistc (mkConst cst) pars + (term, applistc (mkConstU cst) pars) | _ -> assert false let typeclasses () = Refmap.fold (fun _ l c -> l :: c) !classes [] @@ -504,12 +537,19 @@ let mark_resolvables sigma = mark_resolvability all_evars true sigma let has_typeclasses filter evd = let check ev evi = - filter ev (snd evi.evar_source) && is_class_evar evd evi && is_resolvable evi + filter ev (snd evi.evar_source) && is_resolvable evi && is_class_evar evd evi in Evar.Map.exists check (Evd.undefined_map evd) let solve_instanciations_problem = ref (fun _ _ _ _ _ -> assert false) +let solve_problem env evd filter split fail = + !solve_instanciations_problem env evd filter split fail + +(** Profiling resolution of typeclasses *) +(* let solve_classeskey = Profile.declare_profile "solve_typeclasses" *) +(* let solve_problem = Profile.profile5 solve_classeskey solve_problem *) + let resolve_typeclasses ?(filter=no_goals) ?(split=true) ?(fail=true) env evd = if not (has_typeclasses filter evd) then evd - else !solve_instanciations_problem env evd filter split fail + else solve_problem env evd filter split fail diff --git a/pretyping/typeclasses.mli b/pretyping/typeclasses.mli index c36293525..a8ce9ca7c 100644 --- a/pretyping/typeclasses.mli +++ b/pretyping/typeclasses.mli @@ -48,18 +48,24 @@ val add_constant_class : constant -> unit val add_inductive_class : inductive -> unit -val new_instance : typeclass -> int option -> bool -> global_reference -> instance +val new_instance : typeclass -> int option -> bool -> Decl_kinds.polymorphic -> + global_reference -> instance val add_instance : instance -> unit val remove_instance : instance -> unit val class_info : global_reference -> typeclass (** raises a UserError if not a class *) -(** These raise a UserError if not a class. *) -val dest_class_app : env -> constr -> typeclass * constr list +(** These raise a UserError if not a class. + Caution: the typeclass structures is not instantiated w.r.t. the universe instance. + This is done separately by typeclass_univ_instance. *) +val dest_class_app : env -> constr -> typeclass puniverses * constr list + +(** Get the instantiated typeclass structure for a given universe instance. *) +val typeclass_univ_instance : typeclass puniverses -> typeclass puniverses (** Just return None if not a class *) -val class_of_constr : constr -> (rel_context * (typeclass * constr list)) option +val class_of_constr : constr -> (rel_context * (typeclass puniverses * constr list)) option val instance_impl : instance -> global_reference @@ -73,7 +79,8 @@ val is_implicit_arg : Evar_kinds.t -> bool (** Returns the term and type for the given instance of the parameters and fields of the type class. *) -val instance_constructor : typeclass -> constr list -> constr option * types +val instance_constructor : typeclass puniverses -> constr list -> + constr option * types (** Filter which evars to consider for resolution. *) type evar_filter = existential_key -> Evar_kinds.t -> bool @@ -104,10 +111,10 @@ val classes_transparent_state : unit -> transparent_state val add_instance_hint_hook : (global_reference_or_constr -> global_reference list -> - bool (* local? *) -> int option -> unit) Hook.t + bool (* local? *) -> int option -> Decl_kinds.polymorphic -> unit) Hook.t val remove_instance_hint_hook : (global_reference -> unit) Hook.t val add_instance_hint : global_reference_or_constr -> global_reference list -> - bool -> int option -> unit + bool -> int option -> Decl_kinds.polymorphic -> unit val remove_instance_hint : global_reference -> unit val solve_instanciations_problem : (env -> evar_map -> evar_filter -> bool -> bool -> evar_map) ref diff --git a/pretyping/typing.ml b/pretyping/typing.ml index 0cd9099e3..bd559ddd5 100644 --- a/pretyping/typing.ml +++ b/pretyping/typing.ml @@ -27,12 +27,12 @@ let meta_type evd mv = let constant_type_knowing_parameters env cst jl = let paramstyp = Array.map (fun j -> lazy j.uj_type) jl in - type_of_constant_knowing_parameters env (constant_type env cst) paramstyp + type_of_constant_knowing_parameters env (constant_type_in env cst) paramstyp -let inductive_type_knowing_parameters env ind jl = - let (mib,mip) = lookup_mind_specif env ind in +let inductive_type_knowing_parameters env (ind,u) jl = + let mspec = lookup_mind_specif env ind in let paramstyp = Array.map (fun j -> lazy j.uj_type) jl in - Inductive.type_of_inductive_knowing_parameters env mip paramstyp + Inductive.type_of_inductive_knowing_parameters env (mspec,u) paramstyp let e_type_judgment env evdref j = match kind_of_term (whd_betadeltaiota env !evdref j.uj_type) with @@ -69,12 +69,12 @@ let e_judge_of_apply env evdref funj argjv = in apply_rec 1 funj.uj_type (Array.to_list argjv) -let e_check_branch_types env evdref ind cj (lfj,explft) = +let e_check_branch_types env evdref (ind,u) cj (lfj,explft) = if not (Int.equal (Array.length lfj) (Array.length explft)) then error_number_branches env cj (Array.length explft); for i = 0 to Array.length explft - 1 do if not (Evarconv.e_cumul env evdref lfj.(i).uj_type explft.(i)) then - error_ill_formed_branch env cj.uj_val (ind,i+1) lfj.(i).uj_type explft.(i) + error_ill_formed_branch env cj.uj_val ((ind,i+1),u) lfj.(i).uj_type explft.(i) done let max_sort l = @@ -95,8 +95,8 @@ let e_is_correct_arity env evdref c pj ind specif params = if not (Sorts.List.mem (Sorts.family s) allowed_sorts) then error () | Evar (ev,_), [] -> - let s = Termops.new_sort_in_family (max_sort allowed_sorts) in - evdref := Evd.define ev (mkSort s) !evdref + let evd, s = Evd.fresh_sort_in_family env !evdref (max_sort allowed_sorts) in + evdref := Evd.define ev (mkSort s) evd | _, (_,Some _,_ as d)::ar' -> srec (push_rel d env) (lift 1 pt') ar' | _ -> @@ -105,7 +105,7 @@ let e_is_correct_arity env evdref c pj ind specif params = srec env pj.uj_type (List.rev arsign) let e_type_case_branches env evdref (ind,largs) pj c = - let specif = lookup_mind_specif env ind in + let specif = lookup_mind_specif env (fst ind) in let nparams = inductive_params specif in let (params,realargs) = List.chop nparams largs in let p = pj.uj_val in @@ -126,10 +126,11 @@ let e_judge_of_case env evdref ci pj cj lfj = { uj_val = mkCase (ci, pj.uj_val, cj.uj_val, Array.map j_val lfj); uj_type = rslty } +(* FIXME: might depend on the level of actual parameters!*) let check_allowed_sort env sigma ind c p = let pj = Retyping.get_judgment_of env sigma p in let ksort = family_of_sort (sort_of_arity env sigma pj.uj_type) in - let specif = Global.lookup_inductive ind in + let specif = Global.lookup_inductive (fst ind) in let sorts = elim_sorts specif in if not (List.exists ((==) ksort) sorts) then let s = inductive_sort_family (snd specif) in @@ -196,7 +197,11 @@ let rec execute env evdref cstr = judge_of_prop_contents c | Sort (Type u) -> - judge_of_type u + judge_of_type u + + | Proj (p, c) -> + let cj = execute env evdref c in + judge_of_projection env p (Evarutil.j_nf_evar !evdref cj) | App (f,args) -> let jl = execute_array env evdref args in @@ -236,7 +241,7 @@ let rec execute env evdref cstr = let j1 = execute env evdref c1 in let j2 = execute env evdref c2 in let j2 = e_type_judgment env evdref j2 in - let _ = judge_of_cast env j1 DEFAULTcast j2 in + let _ = e_judge_of_cast env evdref j1 DEFAULTcast j2 in let env1 = push_rel (name,Some j1.uj_val,j2.utj_val) env in let j3 = execute env1 evdref c3 in judge_of_letin env name j1 j2 j3 @@ -268,9 +273,7 @@ let check env evd c t = let type_of env evd c = let j = execute env (ref evd) c in - (* We are outside the kernel: we take fresh universes *) - (* to avoid tactics and co to refresh universes themselves *) - Termops.refresh_universes j.uj_type + j.uj_type (* Sort of a type *) @@ -286,7 +289,7 @@ let e_type_of env evd c = let evdref = ref evd in let j = execute env evdref c in (* side-effect on evdref *) - !evdref, Termops.refresh_universes j.uj_type + !evdref, j.uj_type let solve_evars env evdref c = let c = (execute env evdref c).uj_val in diff --git a/pretyping/typing.mli b/pretyping/typing.mli index 084bdbc4f..8b194a9c9 100644 --- a/pretyping/typing.mli +++ b/pretyping/typing.mli @@ -34,5 +34,5 @@ val solve_evars : env -> evar_map ref -> constr -> constr (** Raise an error message if incorrect elimination for this inductive *) (** (first constr is term to match, second is return predicate) *) -val check_allowed_sort : env -> evar_map -> inductive -> constr -> constr -> +val check_allowed_sort : env -> evar_map -> pinductive -> constr -> constr -> unit diff --git a/pretyping/unification.ml b/pretyping/unification.ml index bfcc469c5..f7379b4a0 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -33,7 +33,9 @@ let occur_meta_or_undefined_evar evd c = | Evar_defined c -> occrec c; Array.iter occrec args | Evar_empty -> raise Occur) - | Sort s when is_sort_variable evd s -> raise Occur + (* | Sort (Type _) (\* FIXME could be finer *\) -> raise Occur *) + | Const (_, i) (* | Ind (_, i) | Construct (_, i) *) + when not (Univ.Instance.is_empty i) -> raise Occur | _ -> iter_constr occrec c in try occrec c; false with Occur | Not_found -> true @@ -49,16 +51,19 @@ let occur_meta_evd sigma mv c = (* if lname_typ is [xn,An;..;x1,A1] and l is a list of terms, gives [x1:A1]..[xn:An]c' such that c converts to ([x1:A1]..[xn:An]c' l) *) -let abstract_scheme env c l lname_typ = +let abstract_scheme env evd c l lname_typ = List.fold_left2 - (fun t (locc,a) (na,_,ta) -> + (fun (t,evd) (locc,a) (na,_,ta) -> let na = match kind_of_term a with Var id -> Name id | _ -> na in (* [occur_meta ta] test removed for support of eelim/ecase but consequences are unclear... if occur_meta ta then error "cannot find a type for the generalisation" - else *) if occur_meta a then mkLambda_name env (na,ta,t) - else mkLambda_name env (na,ta,subst_closed_term_occ locc a t)) - c + else *) + if occur_meta a then mkLambda_name env (na,ta,t), evd + else + let t', evd' = Tacred.subst_closed_term_univs_occ evd locc a t in + mkLambda_name env (na,ta,t'), evd') + (c,evd) (List.rev l) lname_typ @@ -67,15 +72,15 @@ let abstract_scheme env c l lname_typ = let abstract_list_all env evd typ c l = let ctxt,_ = splay_prod_n env evd (List.length l) typ in let l_with_all_occs = List.map (function a -> (AllOccurrences,a)) l in - let p = abstract_scheme env c l_with_all_occs ctxt in - let typp = - try Typing.type_of env evd p + let p,evd = abstract_scheme env evd c l_with_all_occs ctxt in + let evd,typp = + try Typing.e_type_of env evd p with | UserError _ -> error_cannot_find_well_typed_abstraction env evd p l None | Type_errors.TypeError (env',x) -> error_cannot_find_well_typed_abstraction env evd p l (Some (env',x)) in - (p,typp) + evd,(p,typp) let set_occurrences_of_last_arg args = Some AllOccurrences :: List.tl (Array.map_to_list (fun _ -> None) args) @@ -88,7 +93,7 @@ let abstract_list_all_with_dependencies env evd typ c l = Evarconv.second_order_matching empty_transparent_state env evd ev' argoccs c in let p = nf_evar evd (existential_value evd (destEvar ev)) in - if b then p else error_cannot_find_well_typed_abstraction env evd p l None + if b then evd, p else error_cannot_find_well_typed_abstraction env evd p l None (**) @@ -251,11 +256,12 @@ type unify_flags = { (* Default flag for unifying a type against a type (e.g. apply) *) (* We set all conversion flags (no flag should be modified anymore) *) -let default_unify_flags = { - modulo_conv_on_closed_terms = Some full_transparent_state; +let default_unify_flags () = + let ts = Names.full_transparent_state in + { modulo_conv_on_closed_terms = Some ts; use_metas_eagerly_in_conv_on_closed_terms = true; - modulo_delta = full_transparent_state; - modulo_delta_types = full_transparent_state; + modulo_delta = ts; + modulo_delta_types = ts; modulo_delta_in_merge = None; check_applied_meta_types = true; resolve_evars = false; @@ -279,7 +285,7 @@ let set_merge_flags flags = (* type against a type (e.g. apply) *) (* We set only the flags available at the time the new "apply" extends *) (* out of "simple apply" *) -let default_no_delta_unify_flags = { default_unify_flags with +let default_no_delta_unify_flags () = { (default_unify_flags ()) with modulo_delta = empty_transparent_state; check_applied_meta_types = false; use_pattern_unification = false; @@ -292,13 +298,13 @@ let default_no_delta_unify_flags = { default_unify_flags with (* allow_K) because only closed terms are involved in *) (* induction/destruct/case/elim and w_unify_to_subterm_list does not *) (* call w_unify for induction/destruct/case/elim (13/6/2011) *) -let elim_flags = { default_unify_flags with +let elim_flags () = { (default_unify_flags ()) with restrict_conv_on_strict_subterms = false; (* ? *) modulo_betaiota = false; allow_K_in_toplevel_higher_order_unification = true } -let elim_no_delta_flags = { elim_flags with +let elim_no_delta_flags () = { (elim_flags ()) with modulo_delta = empty_transparent_state; check_applied_meta_types = false; use_pattern_unification = false; @@ -314,10 +320,28 @@ let use_metas_pattern_unification flags nb l = flags.use_meta_bound_pattern_unification) && Array.for_all (fun c -> isRel c && destRel c <= nb) l -let expand_key env = function - | Some (ConstKey cst) -> constant_opt_value env cst - | Some (VarKey id) -> (try named_body id env with Not_found -> None) - | Some (RelKey _) -> None +type key = + | IsKey of Closure.table_key + | IsProj of constant * constr + +let expand_table_key env = function + | ConstKey cst -> constant_opt_value_in env cst + | VarKey id -> (try named_body id env with Not_found -> None) + | RelKey _ -> None + +let unfold_projection env p stk = + (match try Some (lookup_projection p env) with Not_found -> None with + | Some pb -> + let s = Stack.Proj (pb.Declarations.proj_npars, pb.Declarations.proj_arg, p) in + s :: stk + | None -> assert false) + +let expand_key ts env sigma = function + | Some (IsKey k) -> expand_table_key env k + | Some (IsProj (p, c)) -> + let red = Stack.zip (fst (whd_betaiota_deltazeta_for_iota_state ts env sigma + Cst_stack.empty (c, unfold_projection env p []))) + in if eq_constr (mkProj (p, c)) red then None else Some red | None -> None let subterm_restriction is_subterm flags = @@ -326,14 +350,24 @@ let subterm_restriction is_subterm flags = let key_of env b flags f = if subterm_restriction b flags then None else match kind_of_term f with - | Const cst when is_transparent env (ConstKey cst) && - Cpred.mem cst (snd flags.modulo_delta) -> - Some (ConstKey cst) - | Var id when is_transparent env (VarKey id) && - Id.Pred.mem id (fst flags.modulo_delta) -> - Some (VarKey id) + | Const (cst, u) when Cpred.mem cst (snd flags.modulo_delta) -> + Some (IsKey (ConstKey (cst, u))) + | Var id when Id.Pred.mem id (fst flags.modulo_delta) -> + Some (IsKey (VarKey id)) + | Proj (p, c) when Cpred.mem p (snd flags.modulo_delta) -> + Some (IsProj (p, c)) | _ -> None + +let translate_key = function + | ConstKey (cst,u) -> ConstKey cst + | VarKey id -> VarKey id + | RelKey n -> RelKey n + +let translate_key = function + | IsKey k -> translate_key k + | IsProj (c, _) -> ConstKey c + let oracle_order env cf1 cf2 = match cf1 with | None -> @@ -344,8 +378,36 @@ let oracle_order env cf1 cf2 = match cf2 with | None -> Some true | Some k2 -> - Some (Conv_oracle.oracle_order (Environ.oracle env) false k1 k2) + Some (Conv_oracle.oracle_order (Environ.oracle env) false (translate_key k1) (translate_key k2)) + +let is_rigid_head flags t = + match kind_of_term t with + | Const (cst,u) -> not (Cpred.mem cst (snd flags.modulo_delta)) + | Ind (i,u) -> true + | _ -> false +let force_eqs c = + Univ.UniverseConstraints.fold + (fun ((l,d,r) as c) acc -> + let c' = if d == Univ.ULub then (l,Univ.UEq,r) else c in + Univ.UniverseConstraints.add c' acc) + c Univ.UniverseConstraints.empty + +let constr_cmp pb sigma flags t u = + let b, cstrs = + if pb == Reduction.CONV then eq_constr_universes t u + else leq_constr_universes t u + in + if b then + try Evd.add_universe_constraints sigma cstrs, b + with Univ.UniverseInconsistency _ -> sigma, false + | Evd.UniversesDiffer -> + if is_rigid_head flags t then + try Evd.add_universe_constraints sigma (force_eqs cstrs), b + with Univ.UniverseInconsistency _ -> sigma, false + else sigma, false + else sigma, b + let do_reduce ts (env, nb) sigma c = Stack.zip (fst (whd_betaiota_deltazeta_for_iota_state ts env sigma Cst_stack.empty (c, Stack.empty))) @@ -356,14 +418,14 @@ let isAllowedEvar flags c = match kind_of_term c with | Evar (evk,_) -> not (Evar.Set.mem evk flags.frozen_evars) | _ -> false -let check_compatibility env (sigma,metasubst,evarsubst) tyM tyN = +let check_compatibility env flags (sigma,metasubst,evarsubst) tyM tyN = match subst_defined_metas metasubst tyM with | None -> () | Some m -> match subst_defined_metas metasubst tyN with | None -> () | Some n -> - if not (is_trans_fconv CONV full_transparent_state env sigma m n) + if not (is_trans_fconv CONV flags.modulo_delta env sigma m n) && is_ground_term sigma m && is_ground_term sigma n then error_cannot_unify env sigma (m,n) @@ -379,7 +441,7 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag if wt && flags.check_applied_meta_types then (let tyM = Typing.meta_type sigma k1 in let tyN = Typing.meta_type sigma k2 in - check_compatibility curenv substn tyM tyN); + check_compatibility curenv flags substn tyM tyN); if k2 < k1 then sigma,(k1,cN,stN)::metasubst,evarsubst else sigma,(k2,cM,stM)::metasubst,evarsubst | Meta k, _ @@ -388,7 +450,7 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag (try let tyM = Typing.meta_type sigma k in let tyN = get_type_of curenv ~lax:true sigma cN in - check_compatibility curenv substn tyM tyN + check_compatibility curenv flags substn tyM tyN with RetypeError _ -> (* Renounce, maybe metas/evars prevents typing *) ()); (* Here we check that [cN] does not contain any local variables *) @@ -405,7 +467,7 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag (try let tyM = get_type_of curenv ~lax:true sigma cM in let tyN = Typing.meta_type sigma k in - check_compatibility curenv substn tyM tyN + check_compatibility curenv flags substn tyM tyN with RetypeError _ -> (* Renounce, maybe metas/evars prevents typing *) ()); (* Here we check that [cM] does not contain any local variables *) @@ -431,7 +493,7 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag | Sort s1, Sort s2 -> (try let sigma' = - if cv_pb == CUMUL + if pb == CUMUL then Evd.set_leq_sort sigma s1 s2 else Evd.set_eq_sort sigma s1 s2 in (sigma', metasubst, evarsubst) @@ -455,6 +517,8 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag unirec_rec (push (na,t2) curenvnb) CONV true wt substn (mkApp (lift 1 cM,[|mkRel 1|])) c2 + (* TODO: eta for records *) + | Case (_,p1,c1,cl1), Case (_,p2,c2,cl2) -> (try Array.fold_left2 (unirec_rec curenvnb CONV true wt) @@ -493,6 +557,22 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag | App (f1,l1), App (f2,l2) -> unify_app curenvnb pb b substn cM f1 l1 cN f2 l2 + | Proj (p1,c1), Proj (p2,c2) -> + if eq_constant p1 p2 then + try + let c1, c2, substn = + if isCast c1 && isCast c2 then + let (c1,_,tc1) = destCast c1 in + let (c2,_,tc2) = destCast c2 in + c1, c2, unirec_rec curenvnb CONV true false substn tc1 tc2 + else c1, c2, substn + in + unirec_rec curenvnb CONV true wt substn c1 c2 + with ex when precatchable_exception ex -> + unify_not_same_head curenvnb pb b wt substn cM cN + else + unify_not_same_head curenvnb pb b wt substn cM cN + | _ -> unify_not_same_head curenvnb pb b wt substn cM cN @@ -508,20 +588,22 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag with ex when precatchable_exception ex -> expand curenvnb pb b false substn cM f1 l1 cN f2 l2 - and unify_not_same_head curenvnb pb b wt substn cM cN = + and unify_not_same_head curenvnb pb b wt (sigma, metas, evars as substn) cM cN = try canonical_projections curenvnb pb b cM cN substn with ex when precatchable_exception ex -> - if constr_cmp cv_pb cM cN then substn else - try reduce curenvnb pb b wt substn cM cN - with ex when precatchable_exception ex -> - let (f1,l1) = - match kind_of_term cM with App (f,l) -> (f,l) | _ -> (cM,[||]) in - let (f2,l2) = - match kind_of_term cN with App (f,l) -> (f,l) | _ -> (cN,[||]) in - expand curenvnb pb b wt substn cM f1 l1 cN f2 l2 + let sigma', b = constr_cmp cv_pb sigma flags cM cN in + if b then (sigma', metas, evars) + else + try reduce curenvnb pb b wt substn cM cN + with ex when precatchable_exception ex -> + let (f1,l1) = + match kind_of_term cM with App (f,l) -> (f,l) | _ -> (cM,[||]) in + let (f2,l2) = + match kind_of_term cN with App (f,l) -> (f,l) | _ -> (cN,[||]) in + expand curenvnb pb b wt substn cM f1 l1 cN f2 l2 and reduce curenvnb pb b wt (sigma, metas, evars as substn) cM cN = - if use_full_betaiota flags && not (subterm_restriction b flags) then + if not (subterm_restriction b flags) && use_full_betaiota flags then let cM' = do_reduce flags.modulo_delta curenvnb sigma cM in if not (eq_constr cM cM') then unirec_rec curenvnb pb b wt substn cM' cN @@ -530,12 +612,10 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag if not (eq_constr cN cN') then unirec_rec curenvnb pb b wt substn cM cN' else error_cannot_unify (fst curenvnb) sigma (cM,cN) - else - error_cannot_unify (fst curenvnb) sigma (cM,cN) + else error_cannot_unify (fst curenvnb) sigma (cM,cN) - and expand (curenv,_ as curenvnb) pb b wt (sigma,metasubst,_ as substn) cM f1 l1 cN f2 l2 = - - if + and expand (curenv,_ as curenvnb) pb b wt (sigma,metasubst,evarsubst as substn) cM f1 l1 cN f2 l2 = + let res = (* Try full conversion on meta-free terms. *) (* Back to 1995 (later on called trivial_unify in 2002), the heuristic was to apply conversion on meta-free (but not @@ -548,48 +628,50 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag (it is used by apply and rewrite); it might now be redundant with the support for delta-expansion (which is used essentially for apply)... *) - not (subterm_restriction b flags) && + if subterm_restriction b flags then None else match flags.modulo_conv_on_closed_terms with - | None -> false + | None -> None | Some convflags -> let subst = if flags.use_metas_eagerly_in_conv_on_closed_terms then metasubst else ms in match subst_defined_metas subst cM with - | None -> (* some undefined Metas in cM *) false + | None -> (* some undefined Metas in cM *) None | Some m1 -> match subst_defined_metas subst cN with - | None -> (* some undefined Metas in cN *) false + | None -> (* some undefined Metas in cN *) None | Some n1 -> (* No subterm restriction there, too much incompatibilities *) - if is_trans_fconv pb convflags env sigma m1 n1 - then true else - if is_ground_term sigma m1 && is_ground_term sigma n1 then - error_cannot_unify curenv sigma (cM,cN) - else false - then - substn - else + let b = check_conv ~pb ~ts:convflags env sigma m1 n1 in + if b then Some (sigma, metasubst, evarsubst) + else + if is_ground_term sigma m1 && is_ground_term sigma n1 then + error_cannot_unify curenv sigma (cM,cN) + else None + in + match res with + | Some substn -> substn + | None -> let cf1 = key_of env b flags f1 and cf2 = key_of env b flags f2 in match oracle_order curenv cf1 cf2 with | None -> error_cannot_unify curenv sigma (cM,cN) | Some true -> - (match expand_key curenv cf1 with + (match expand_key flags.modulo_delta curenv sigma cf1 with | Some c -> unirec_rec curenvnb pb b wt substn (whd_betaiotazeta sigma (mkApp(c,l1))) cN | None -> - (match expand_key curenv cf2 with + (match expand_key flags.modulo_delta curenv sigma cf2 with | Some c -> unirec_rec curenvnb pb b wt substn cM (whd_betaiotazeta sigma (mkApp(c,l2))) | None -> error_cannot_unify curenv sigma (cM,cN))) | Some false -> - (match expand_key curenv cf2 with + (match expand_key flags.modulo_delta curenv sigma cf2 with | Some c -> unirec_rec curenvnb pb b wt substn cM (whd_betaiotazeta sigma (mkApp(c,l2))) | None -> - (match expand_key curenv cf1 with + (match expand_key flags.modulo_delta curenv sigma cf1 with | Some c -> unirec_rec curenvnb pb b wt substn (whd_betaiotazeta sigma (mkApp(c,l1))) cN @@ -623,11 +705,12 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag else error_cannot_unify (fst curenvnb) sigma (cM,cN) and solve_canonical_projection curenvnb pb b cM f1l1 cN f2l2 (sigma,ms,es) = - let (c,bs,(params,params1),(us,us2),(ts,ts1),c1,(n,t2)) = + let (ctx,c,bs,(params,params1),(us,us2),(ts,ts1),c1,(n,t2)) = try Evarconv.check_conv_record f1l1 f2l2 with Not_found -> error_cannot_unify (fst curenvnb) sigma (cM,cN) in if Reductionops.Stack.compare_shape ts ts1 then + let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx in let (evd,ks,_) = List.fold_left (fun (evd,ks,m) b -> @@ -652,19 +735,24 @@ let unify_0_with_initial_metas (sigma,ms,es as subst) conv_at_top env cv_pb flag else error_cannot_unify (fst curenvnb) sigma (cM,cN) in let evd = sigma in - if (if occur_meta_or_undefined_evar evd m || occur_meta_or_undefined_evar evd n - || subterm_restriction conv_at_top flags then false - else if (match flags.modulo_conv_on_closed_terms with - | Some convflags -> is_trans_fconv cv_pb convflags env sigma m n - | _ -> constr_cmp cv_pb m n) then true - else if (match flags.modulo_conv_on_closed_terms, flags.modulo_delta with + let res = + if occur_meta_or_undefined_evar evd m || occur_meta_or_undefined_evar evd n + || subterm_restriction conv_at_top flags then None + else + let sigma, b = match flags.modulo_conv_on_closed_terms with + | Some convflags -> infer_conv ~pb:cv_pb ~ts:convflags env sigma m n + | _ -> constr_cmp cv_pb sigma flags m n in + if b then Some sigma + else if (match flags.modulo_conv_on_closed_terms, flags.modulo_delta with | Some (cv_id, cv_k), (dl_id, dl_k) -> Id.Pred.subset dl_id cv_id && Cpred.subset dl_k cv_k | None,(dl_id, dl_k) -> Id.Pred.is_empty dl_id && Cpred.is_empty dl_k) - then error_cannot_unify env sigma (m, n) else false) - then subst - else unirec_rec (env,0) cv_pb conv_at_top false subst m n + then error_cannot_unify env sigma (m, n) else None + in + match res with + | Some sigma -> sigma, ms, es + | None -> unirec_rec (env,0) cv_pb conv_at_top false subst m n let unify_0 env sigma = unify_0_with_initial_metas (sigma,[],[]) true env @@ -792,7 +880,7 @@ let applyHead env evd n c = let is_mimick_head ts f = match kind_of_term f with - | Const c -> not (Closure.is_transparent_constant ts c) + | Const (c,u) -> not (Closure.is_transparent_constant ts c) | Var id -> not (Closure.is_transparent_variable ts id) | (Rel _|Construct _|Ind _) -> true | _ -> false @@ -820,7 +908,7 @@ let w_coerce env evd mv c = w_coerce_to_type env evd c cty mvty let unify_to_type env sigma flags c status u = - let c = refresh_universes c in + let sigma, c = refresh_universes false sigma c in let t = get_type_of env sigma (nf_meta sigma c) in let t = nf_betaiota sigma (nf_meta sigma t) in unify_0 env sigma CUMUL flags t u @@ -957,7 +1045,7 @@ let w_merge env with_types flags (evd,metas,evars) = (* merge constraints *) w_merge_rec evd (order_metas metas) (List.rev evars) [] -let w_unify_meta_types env ?(flags=default_unify_flags) evd = +let w_unify_meta_types env ?(flags=default_unify_flags ()) evd = let metas,evd = retract_coercible_metas evd in w_merge env true flags (evd,metas,[]) @@ -1032,7 +1120,7 @@ let iter_fail f a = (* Tries to find an instance of term [cl] in term [op]. Unifies [cl] to every subterm of [op] until it finds a match. Fails if no match is found *) -let w_unify_to_subterm env evd ?(flags=default_unify_flags) (op,cl) = +let w_unify_to_subterm env evd ?(flags=default_unify_flags ()) (op,cl) = let rec matchrec cl = let cl = strip_outer_cast cl in (try @@ -1061,6 +1149,8 @@ let w_unify_to_subterm env evd ?(flags=default_unify_flags) (op,cl) = with ex when precatchable_exception ex -> matchrec c2) + | Proj (p,c) -> matchrec c + | Fix(_,(_,types,terms)) -> (try iter_fail matchrec types @@ -1092,7 +1182,7 @@ let w_unify_to_subterm env evd ?(flags=default_unify_flags) (op,cl) = (* Tries to find all instances of term [cl] in term [op]. Unifies [cl] to every subterm of [op] and return all the matches. Fails if no match is found *) -let w_unify_to_subterm_all env evd ?(flags=default_unify_flags) (op,cl) = +let w_unify_to_subterm_all env evd ?(flags=default_unify_flags ()) (op,cl) = let return a b = let (evd,c as a) = a () in if List.exists (fun (evd',c') -> eq_constr c c') b then b else a :: b @@ -1130,6 +1220,8 @@ let w_unify_to_subterm_all env evd ?(flags=default_unify_flags) (op,cl) = | Case(_,_,c,lf) -> (* does not search in the predicate *) bind (matchrec c) (bind_iter matchrec lf) + | Proj (p,c) -> matchrec c + | LetIn(_,c1,_,c2) -> bind (matchrec c1) (matchrec c2) @@ -1173,7 +1265,8 @@ let w_unify_to_subterm_list env evd flags hdmeta oplist t = List.exists (fun op -> eq_constr op cl) l then error_non_linear_unification env evd hdmeta cl else (evd',cl::l) - else if flags.allow_K_in_toplevel_higher_order_unification || dependent op t + else if flags.allow_K_in_toplevel_higher_order_unification + || dependent_univs op t then (evd,op::l) else @@ -1187,15 +1280,24 @@ let secondOrderAbstraction env evd flags typ (p, oplist) = let flags = { flags with modulo_delta = (fst flags.modulo_delta, Cpred.empty) } in let (evd',cllist) = w_unify_to_subterm_list env evd flags p oplist typ in let typp = Typing.meta_type evd' p in - let pred,predtyp = abstract_list_all env evd' typp typ cllist in - if not (is_conv_leq env evd predtyp typp) then - error_wrong_abstraction_type env evd - (Evd.meta_name evd p) pred typp predtyp; - w_merge env false flags (evd',[p,pred,(Conv,TypeProcessed)],[]) + let evd',(pred,predtyp) = abstract_list_all env evd' typp typ cllist in + let evd', b = infer_conv ~pb:CUMUL env evd' predtyp typp in + if not b then + error_wrong_abstraction_type env evd' + (Evd.meta_name evd p) pred typp predtyp; + w_merge env false flags (evd',[p,pred,(Conv,TypeProcessed)],[]) + + (* let evd',metas,evars = *) + (* try unify_0 env evd' CUMUL flags predtyp typp *) + (* with NotConvertible -> *) + (* error_wrong_abstraction_type env evd *) + (* (Evd.meta_name evd p) pred typp predtyp *) + (* in *) + (* w_merge env false flags (evd',(p,pred,(Conv,TypeProcessed))::metas,evars) *) let secondOrderDependentAbstraction env evd flags typ (p, oplist) = let typp = Typing.meta_type evd p in - let pred = abstract_list_all_with_dependencies env evd typp typ oplist in + let evd, pred = abstract_list_all_with_dependencies env evd typp typ oplist in w_merge env false flags (evd,[p,pred,(Conv,TypeProcessed)],[]) let secondOrderAbstractionAlgo dep = @@ -1233,7 +1335,7 @@ let w_unify2 env evd flags dep cv_pb ty1 ty2 = Before, second-order was used if the type of Meta(1) and [x:A]t was convertible and first-order otherwise. But if failed if e.g. the type of Meta(1) had meta-variables in it. *) -let w_unify env evd cv_pb ?(flags=default_unify_flags) ty1 ty2 = +let w_unify env evd cv_pb ?(flags=default_unify_flags ()) ty1 ty2 = let hd1,l1 = decompose_appvect (whd_nored evd ty1) in let hd2,l2 = decompose_appvect (whd_nored evd ty2) in let is_empty1 = Array.is_empty l1 in @@ -1267,3 +1369,14 @@ let w_unify env evd cv_pb ?(flags=default_unify_flags) ty1 ty2 = (* General case: try first order *) | _ -> w_typed_unify env evd cv_pb flags ty1 ty2 + +(* Profiling *) +(* let wunifkey = Profile.declare_profile "w_unify";; *) + +(* let w_unify env evd cv_pb flags ty1 ty2 = *) +(* w_unify env evd cv_pb ~flags:flags ty1 ty2 *) + +(* let w_unify = Profile.profile6 wunifkey w_unify *) + +(* let w_unify env evd cv_pb ?(flags=default_unify_flags ()) ty1 ty2 = *) +(* w_unify env evd cv_pb flags ty1 ty2 *) diff --git a/pretyping/unification.mli b/pretyping/unification.mli index 04e65b862..3f93d817d 100644 --- a/pretyping/unification.mli +++ b/pretyping/unification.mli @@ -27,11 +27,11 @@ type unify_flags = { allow_K_in_toplevel_higher_order_unification : bool } -val default_unify_flags : unify_flags -val default_no_delta_unify_flags : unify_flags +val default_unify_flags : unit -> unify_flags +val default_no_delta_unify_flags : unit -> unify_flags -val elim_flags : unify_flags -val elim_no_delta_flags : unify_flags +val elim_flags : unit -> unify_flags +val elim_no_delta_flags : unit -> unify_flags (** The "unique" unification fonction *) val w_unify : @@ -59,8 +59,7 @@ val w_coerce_to_type : env -> evar_map -> constr -> types -> types -> abstracts the terms in l over c to get a term of type t (exported for inv.ml) *) val abstract_list_all : - env -> evar_map -> constr -> constr -> constr list -> constr * types - + env -> evar_map -> constr -> constr -> constr list -> evar_map * (constr * types) (* For tracing *) @@ -77,3 +76,15 @@ val unify_0 : Environ.env -> Evd.evar_map * Evd.metabinding list * (Environ.env * Term.types Term.pexistential * Term.constr) list +val unify_0_with_initial_metas : + Evd.evar_map * Evd.metabinding list * + (Environ.env * Term.types Term.pexistential * Term.constr) list -> + bool -> + Environ.env -> + Evd.conv_pb -> + unify_flags -> + Term.types -> + Term.types -> + Evd.evar_map * Evd.metabinding list * + (Environ.env * Term.types Term.pexistential * Term.constr) list + diff --git a/pretyping/vnorm.ml b/pretyping/vnorm.ml index b2fa631cd..16eeaa293 100644 --- a/pretyping/vnorm.ml +++ b/pretyping/vnorm.ml @@ -55,9 +55,11 @@ let find_rectype_a env c = (* Instantiate inductives and parameters in constructor type *) -let type_constructor mind mib typ params = - let s = ind_subst mind mib in +let type_constructor mind mib u typ params = + let s = ind_subst mind mib u in let ctyp = substl s typ in + let usubst = make_inductive_subst mib u in + let ctyp = subst_univs_constr usubst ctyp in let nparams = Array.length params in if Int.equal nparams 0 then ctyp else @@ -67,11 +69,11 @@ let type_constructor mind mib typ params = let construct_of_constr const env tag typ = - let (mind,_ as ind), allargs = find_rectype_a env typ in + let ((mind,_ as ind), u) as indu, allargs = find_rectype_a env typ in (* spiwack : here be a branch for specific decompilation handled by retroknowledge *) try if const then - ((retroknowledge Retroknowledge.get_vm_decompile_constant_info env (mkInd ind) tag), + ((retroknowledge Retroknowledge.get_vm_decompile_constant_info env (mkIndU indu) tag), typ) (*spiwack: this may need to be changed in case there are parameters in the type which may cause a constant value to have an arity. (type_constructor seems to be all about parameters actually) @@ -84,18 +86,19 @@ let construct_of_constr const env tag typ = let nparams = mib.mind_nparams in let i = invert_tag const tag mip.mind_reloc_tbl in let params = Array.sub allargs 0 nparams in - let ctyp = type_constructor mind mib (mip.mind_nf_lc.(i-1)) params in - (mkApp(mkConstruct(ind,i), params), ctyp) + let ctyp = type_constructor mind mib u (mip.mind_nf_lc.(i-1)) params in + (mkApp(mkConstructUi(indu,i), params), ctyp) let construct_of_constr_const env tag typ = fst (construct_of_constr true env tag typ) let construct_of_constr_block = construct_of_constr false +(* FIXME: treatment of universes *) let constr_type_of_idkey env idkey = match idkey with | ConstKey cst -> - mkConst cst, Typeops.type_of_constant env cst + mkConst cst, (Environ.lookup_constant cst env).const_type | VarKey id -> let (_,_,ty) = lookup_named id env in mkVar id, ty @@ -104,17 +107,17 @@ let constr_type_of_idkey env idkey = let (_,_,ty) = lookup_rel n env in mkRel n, lift n ty -let type_of_ind env ind = - type_of_inductive env (Inductive.lookup_mind_specif env ind) +let type_of_ind env ind u = + type_of_inductive env (Inductive.lookup_mind_specif env ind, u) -let build_branches_type env (mind,_ as _ind) mib mip params dep p = +let build_branches_type env (mind,_ as _ind) mib mip u params dep p = let rtbl = mip.mind_reloc_tbl in (* [build_one_branch i cty] construit le type de la ieme branche (commence a 0) et les lambda correspondant aux realargs *) let build_one_branch i cty = - let typi = type_constructor mind mib cty params in + let typi = type_constructor mind mib u cty params in let decl,indapp = decompose_prod_assum typi in - let ind,cargs = find_rectype_a env indapp in + let ((ind,u),cargs) = find_rectype_a env indapp in let nparams = Array.length params in let carity = snd (rtbl.(i)) in let crealargs = Array.sub cargs nparams (Array.length cargs - nparams) in @@ -123,7 +126,7 @@ let build_branches_type env (mind,_ as _ind) mib mip params dep p = if dep then let cstr = ith_constructor_of_inductive ind (i+1) in let relargs = Array.init carity (fun i -> mkRel (carity-i)) in - let dep_cstr = mkApp(mkApp(mkConstruct cstr,params),relargs) in + let dep_cstr = mkApp(mkApp(mkConstructU (cstr,u),params),relargs) in mkApp(papp,[|dep_cstr|]) else papp in @@ -170,7 +173,7 @@ and nf_whd env whd typ = | Vatom_stk(Aiddef(idkey,v), stk) -> nf_whd env (whd_stack v stk) typ | Vatom_stk(Aind ind, stk) -> - nf_stk env (mkInd ind) (type_of_ind env ind) stk + nf_stk env (mkInd ind) (type_of_ind env ind Univ.Instance.empty (*FIXME*)) stk and nf_stk env c t stk = match stk with @@ -183,16 +186,16 @@ and nf_stk env c t stk = let _,_,codom = try decompose_prod env typ with DestKO -> exit 120 in nf_stk env (mkApp(fa,[|c|])) (subst1 c codom) stk | Zswitch sw :: stk -> - let (mind,_ as ind),allargs = find_rectype_a env t in + let ((mind,_ as ind), u), allargs = find_rectype_a env t in let (mib,mip) = Inductive.lookup_mind_specif env ind in let nparams = mib.mind_nparams in let params,realargs = Util.Array.chop nparams allargs in let pT = - hnf_prod_applist env (type_of_ind env ind) (Array.to_list params) in + hnf_prod_applist env (type_of_ind env ind u) (Array.to_list params) in let pT = whd_betadeltaiota env pT in let dep, p = nf_predicate env ind mip params (type_of_switch sw) pT in (* Calcul du type des branches *) - let btypes = build_branches_type env ind mib mip params dep p in + let btypes = build_branches_type env ind mib mip u params dep p in (* calcul des branches *) let bsw = branch_of_switch (nb_rel env) sw in let mkbranch i (n,v) = |