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 /kernel | |
| 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 'kernel')
59 files changed, 4673 insertions, 1571 deletions
diff --git a/kernel/cbytegen.ml b/kernel/cbytegen.ml index d0da84623..894f88710 100644 --- a/kernel/cbytegen.ml +++ b/kernel/cbytegen.ml @@ -353,7 +353,7 @@ let rec str_const c = | App(f,args) -> begin match kind_of_term f with - | Construct((kn,j),i) -> + | Construct(((kn,j),i),u) -> begin let oib = lookup_mind kn !global_env in let oip = oib.mind_packets.(j) in @@ -422,8 +422,8 @@ let rec str_const c = end | _ -> Bconstr c end - | Ind ind -> Bstrconst (Const_ind ind) - | Construct ((kn,j),i) -> + | Ind (ind,u) -> Bstrconst (Const_ind ind) + | Construct (((kn,j),i),u) -> begin (* spiwack: tries first to apply the run-time compilation behavior of the constructor, as in 2/ above *) @@ -487,11 +487,11 @@ let rec compile_fv reloc l sz cont = (* Compiling constants *) let rec get_allias env kn = - let tps = (lookup_constant kn env).const_body_code in - match Cemitcodes.force tps with - | BCallias kn' -> get_allias env kn' - | _ -> kn - + let cb = lookup_constant kn env in + let tps = cb.const_body_code in + (match Cemitcodes.force tps with + | BCallias kn' -> get_allias env kn' + | _ -> kn) (* Compiling expressions *) @@ -499,12 +499,19 @@ let rec compile_constr reloc c sz cont = match kind_of_term c with | Meta _ -> invalid_arg "Cbytegen.compile_constr : Meta" | Evar _ -> invalid_arg "Cbytegen.compile_constr : Evar" + | Proj (p,c) -> + (* compile_const reloc p [|c|] sz cont *) + let cb = lookup_constant p !global_env in + (* TODO: better representation of projections *) + let pb = Option.get cb.const_proj in + let args = Array.make pb.proj_npars mkProp in + compile_const reloc p Univ.Instance.empty (Array.append args [|c|]) sz cont | Cast(c,_,_) -> compile_constr reloc c sz cont | Rel i -> pos_rel i reloc sz :: cont | Var id -> pos_named id reloc :: cont - | Const kn -> compile_const reloc kn [||] sz cont + | Const (kn,u) -> compile_const reloc kn u [||] sz cont | Sort _ | Ind _ | Construct _ -> compile_str_cst reloc (str_const c) sz cont @@ -531,7 +538,7 @@ let rec compile_constr reloc c sz cont = begin match kind_of_term f with | Construct _ -> compile_str_cst reloc (str_const c) sz cont - | Const kn -> compile_const reloc kn args sz cont + | Const (kn,u) -> compile_const reloc kn u args sz cont | _ -> comp_app compile_constr compile_constr reloc f args sz cont end | Fix ((rec_args,init),(_,type_bodies,rec_bodies)) -> @@ -682,14 +689,14 @@ and compile_str_cst reloc sc sz cont = (* spiwack : compilation of constants with their arguments. Makes a special treatment with 31-bit integer addition *) and compile_const = - fun reloc-> fun kn -> fun args -> fun sz -> fun cont -> + fun reloc-> fun kn u -> fun args -> fun sz -> fun cont -> let nargs = Array.length args in (* spiwack: checks if there is a specific way to compile the constant if there is not, Not_found is raised, and the function falls back on its normal behavior *) try Retroknowledge.get_vm_compiling_info (!global_env).retroknowledge - (mkConst kn) reloc args sz cont + (mkConstU (kn,u)) reloc args sz cont with Not_found -> if Int.equal nargs 0 then Kgetglobal (get_allias !global_env kn) :: cont @@ -723,7 +730,7 @@ let compile_constant_body env = function match kind_of_term body with | Const kn' -> (* we use the canonical name of the constant*) - let con= constant_of_kn (canonical_con kn') in + let con= constant_of_kn (canonical_con (Univ.out_punivs kn')) in BCallias (get_allias env con) | _ -> let res = compile env body in @@ -751,7 +758,7 @@ let compile_structured_int31 fc args = Const_b0 (Array.fold_left (fun temp_i -> fun t -> match kind_of_term t with - | Construct (_,d) -> 2*temp_i+d-1 + | Construct ((_,d),_) -> 2*temp_i+d-1 | _ -> raise NotClosed) 0 args ) diff --git a/kernel/cemitcodes.ml b/kernel/cemitcodes.ml index 2b9ca425f..2de8ef2bf 100644 --- a/kernel/cemitcodes.ml +++ b/kernel/cemitcodes.ml @@ -320,16 +320,16 @@ let rec subst_strcst s sc = match sc with | Const_sorts _ | Const_b0 _ -> sc | Const_bn(tag,args) -> Const_bn(tag,Array.map (subst_strcst s) args) - | Const_ind(ind) -> let kn,i = ind in Const_ind((subst_ind s kn, i)) + | Const_ind(ind) -> let kn,i = ind in Const_ind((subst_mind s kn, i)) let subst_patch s (ri,pos) = match ri with | Reloc_annot a -> let (kn,i) = a.ci.ci_ind in - let ci = {a.ci with ci_ind = (subst_ind s kn,i)} in + let ci = {a.ci with ci_ind = (subst_mind s kn,i)} in (Reloc_annot {a with ci = ci},pos) | Reloc_const sc -> (Reloc_const (subst_strcst s sc), pos) - | Reloc_getglobal kn -> (Reloc_getglobal (fst (subst_con s kn)), pos) + | Reloc_getglobal kn -> (Reloc_getglobal (fst (subst_con_kn s kn)), pos) let subst_to_patch s (code,pl,fv) = code,List.rev_map (subst_patch s) pl,fv @@ -341,7 +341,7 @@ type body_code = let subst_body_code s = function | BCdefined tp -> BCdefined (subst_to_patch s tp) - | BCallias kn -> BCallias (fst (subst_con s kn)) + | BCallias kn -> BCallias (fst (subst_con_kn s kn)) | BCconstant -> BCconstant type to_patch_substituted = body_code substituted diff --git a/kernel/closure.ml b/kernel/closure.ml index 7b94ecfb8..fd3ab525e 100644 --- a/kernel/closure.ml +++ b/kernel/closure.ml @@ -206,32 +206,39 @@ let unfold_red kn = * instantiations (cbv or lazy) are. *) -type table_key = id_key +type table_key = constant puniverses tableKey +let eq_pconstant_key (c,u) (c',u') = + eq_constant_key c c' && Univ.Instance.eq u u' + module IdKeyHash = struct - type t = id_key - let equal = Names.eq_id_key open Hashset.Combine + type t = table_key + let equal = Names.eq_table_key eq_pconstant_key let hash = function - | ConstKey c -> combinesmall 1 (Constant.UserOrd.hash c) + | ConstKey (c, _) -> combinesmall 1 (Constant.UserOrd.hash c) | VarKey id -> combinesmall 2 (Id.hash id) | RelKey i -> combinesmall 3 (Int.hash i) end module KeyTable = Hashtbl.Make(IdKeyHash) -let eq_table_key = Names.eq_id_key +let eq_table_key = IdKeyHash.equal -type 'a infos = { - i_flags : reds; +type 'a infos_cache = { i_repr : 'a infos -> constr -> 'a; i_env : env; i_sigma : existential -> constr option; i_rels : constr option array; i_tab : 'a KeyTable.t } +and 'a infos = { + i_flags : reds; + i_cache : 'a infos_cache } + let info_flags info = info.i_flags +let info_env info = info.i_cache.i_env let rec assoc_defined id = function | [] -> raise Not_found @@ -239,34 +246,34 @@ let rec assoc_defined id = function | (id', Some c, _) :: ctxt -> if Id.equal id id' then c else assoc_defined id ctxt -let ref_value_cache info ref = +let ref_value_cache ({i_cache = cache} as infos) ref = try - Some (KeyTable.find info.i_tab ref) + Some (KeyTable.find cache.i_tab ref) with Not_found -> try let body = match ref with | RelKey n -> - let len = Array.length info.i_rels in + let len = Array.length cache.i_rels in let i = n - 1 in let () = if i < 0 || len <= i then raise Not_found in - begin match Array.unsafe_get info.i_rels i with + begin match Array.unsafe_get cache.i_rels i with | None -> raise Not_found | Some t -> lift n t end - | VarKey id -> assoc_defined id (named_context info.i_env) - | ConstKey cst -> constant_value info.i_env cst + | VarKey id -> assoc_defined id (named_context cache.i_env) + | ConstKey cst -> constant_value_in cache.i_env cst in - let v = info.i_repr info body in - KeyTable.add info.i_tab ref v; + let v = cache.i_repr infos body in + KeyTable.add cache.i_tab ref v; Some v with | Not_found (* List.assoc *) | NotEvaluableConst _ (* Const *) -> None -let evar_value info ev = - info.i_sigma ev +let evar_value cache ev = + cache.i_sigma ev let defined_rels flags env = (* if red_local_const (snd flags) then*) @@ -282,12 +289,13 @@ let defined_rels flags env = (* else (0,[])*) let create mk_cl flgs env evars = - { i_flags = flgs; - i_repr = mk_cl; - i_env = env; - i_sigma = evars; - i_rels = defined_rels flgs env; - i_tab = KeyTable.create 17 } + let cache = + { i_repr = mk_cl; + i_env = env; + i_sigma = evars; + i_rels = defined_rels flgs env; + i_tab = KeyTable.create 17 } + in { i_flags = flgs; i_cache = cache } (**********************************************************************) @@ -327,9 +335,10 @@ and fterm = | FAtom of constr (* Metas and Sorts *) | FCast of fconstr * cast_kind * fconstr | FFlex of table_key - | FInd of inductive - | FConstruct of constructor + | FInd of pinductive + | FConstruct of pconstructor | FApp of fconstr * fconstr array + | FProj of constant * fconstr | FFix of fixpoint * fconstr subs | FCoFix of cofixpoint * fconstr subs | FCases of case_info * fconstr * fconstr * fconstr array @@ -362,6 +371,7 @@ let update v1 no t = type stack_member = | Zapp of fconstr array | Zcase of case_info * fconstr * fconstr array + | Zproj of int * int * constant | Zfix of fconstr * stack | Zshift of int | Zupdate of fconstr @@ -494,6 +504,9 @@ let rec compact_constr (lg, subs as s) c k = let (s, f') = compact_constr s f k in let (s, v') = compact_vect s v k in if f==f' && v==v' then s, c else s, mkApp(f',v') + | Proj (p,t) -> + let (s, t') = compact_constr s t k in + if t'==t then s, c else s, mkProj (p,t') | Lambda(n,a,b) -> let (s, a') = compact_constr s a k in let (s, b') = compact_constr s b (k+1) in @@ -559,7 +572,7 @@ let mk_clos e t = | Meta _ | Sort _ -> { norm = Norm; term = FAtom t } | Ind kn -> { norm = Norm; term = FInd kn } | Construct kn -> { norm = Cstr; term = FConstruct kn } - | (CoFix _|Lambda _|Fix _|Prod _|Evar _|App _|Case _|Cast _|LetIn _) -> + | (CoFix _|Lambda _|Fix _|Prod _|Evar _|App _|Case _|Cast _|LetIn _|Proj _) -> {norm = Red; term = FCLOS(t,e)} let mk_clos_vect env v = CArray.Fun1.map mk_clos env v @@ -578,6 +591,9 @@ let mk_clos_deep clos_fun env t = | App (f,v) -> { norm = Red; term = FApp (clos_fun env f, CArray.Fun1.map clos_fun env v) } + | Proj (p,c) -> + { norm = Red; + term = FProj (p, clos_fun env c) } | Case (ci,p,c,v) -> { norm = Red; term = FCases (ci, clos_fun env p, clos_fun env c, @@ -609,9 +625,9 @@ let rec to_constr constr_fun lfts v = | FAtom c -> exliftn lfts c | FCast (a,k,b) -> mkCast (constr_fun lfts a, k, constr_fun lfts b) - | FFlex (ConstKey op) -> mkConst op - | FInd op -> mkInd op - | FConstruct op -> mkConstruct op + | FFlex (ConstKey op) -> mkConstU op + | FInd op -> mkIndU op + | FConstruct op -> mkConstructU op | FCases (ci,p,c,ve) -> mkCase (ci, constr_fun lfts p, constr_fun lfts c, @@ -633,6 +649,9 @@ let rec to_constr constr_fun lfts v = | FApp (f,ve) -> mkApp (constr_fun lfts f, CArray.Fun1.map constr_fun lfts ve) + | FProj (p,c) -> + mkProj (p,constr_fun lfts c) + | FLambda _ -> let (na,ty,bd) = destFLambda mk_clos2 v in mkLambda (na, constr_fun lfts ty, @@ -688,6 +707,8 @@ let rec zip m stk rem = match stk with | Zcase(ci,p,br)::s -> let t = FCases(ci, p, m, br) in zip {norm=neutr m.norm; term=t} s rem +| Zproj (i,j,cst) :: s -> + zip {norm=neutr m.norm; term=FProj (cst,m)} s rem | Zfix(fx,par)::s -> zip fx par ((Zapp [|m|] :: s) :: rem) | Zshift(n)::s -> @@ -774,7 +795,7 @@ let rec get_args n tys f e stk = (* Eta expansion: add a reference to implicit surrounding lambda at end of stack *) let rec eta_expand_stack = function - | (Zapp _ | Zfix _ | Zcase _ | Zshift _ | Zupdate _ as e) :: s -> + | (Zapp _ | Zfix _ | Zcase _ | Zshift _ | Zupdate _ | Zproj _ as e) :: s -> e :: eta_expand_stack s | [] -> [Zshift 1; Zapp [|{norm=Norm; term= FRel 1}|]] @@ -808,6 +829,64 @@ let rec drop_parameters depth n argstk = | _ -> assert false (* strip_update_shift_app only produces Zapp and Zshift items *) +let rec get_parameters depth n argstk = + match argstk with + Zapp args::s -> + let q = Array.length args in + if n > q then Array.append args (get_parameters depth (n-q) s) + else if Int.equal n q then [||] + else Array.sub args 0 n + | Zshift(k)::s -> + get_parameters (depth-k) n s + | [] -> (* we know that n < stack_args_size(argstk) (if well-typed term) *) + if Int.equal n 0 then [||] + else raise Not_found (* Trying to eta-expand a partial application..., should do + eta expansion first? *) + | _ -> assert false + (* strip_update_shift_app only produces Zapp and Zshift items *) + +let eta_expand_ind_stack env lft (ind,u) m s (lft, h) = + let mib = lookup_mind (fst ind) env in + match mib.Declarations.mind_record with + | None -> raise Not_found + | Some (exp,_) -> + let pars = mib.Declarations.mind_nparams in + let h' = fapp_stack h in + let (depth, args, _) = strip_update_shift_app m s in + let paramargs = get_parameters depth pars args in + let subs = subs_cons (Array.append paramargs [|h'|], subs_id 0) in + let fexp = mk_clos subs exp in + (lft, (fexp, [])) + +let eta_expand_ind_stacks env ind m s h = + 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 + let h' = fapp_stack h in + let (depth, args, _) = strip_update_shift_app m s in + let primitive = Environ.is_projection projs.(0) env in + if primitive then + let s' = drop_parameters depth pars args in + (* Construct, pars1 .. parsm :: arg1...argn :: s ~= (t, []) -> + arg1..argn :: s ~= (proj1 t...projn t) s + *) + let hstack = Array.map (fun p -> { norm = Red; + term = FProj (p, h') }) projs in + s', [Zapp hstack] + else raise Not_found (* disallow eta-exp for non-primitive records *) + | _ -> raise Not_found + +let rec project_nth_arg n argstk = + match argstk with + | Zapp args :: s -> + let q = Array.length args in + if n >= q then project_nth_arg (n - q) s + else (* n < q *) args.(n) + | _ -> assert false + (* After drop_parameters we have a purely applicative stack *) + + (* Iota reduction: expansion of a fixpoint. * Given a fixpoint and a substitution, returns the corresponding * fixpoint body, and the substitution in which it should be @@ -832,39 +911,48 @@ let contract_fix_vect fix = in (subs_cons(Array.init nfix make_body, env), thisbody) - (*********************************************************************) (* A machine that inspects the head of a term until it finds an atom or a subterm that may produce a redex (abstraction, constructor, cofix, letin, constant), or a neutral term (product, inductive) *) -let rec knh m stk = +let rec knh info m stk = match m.term with - | FLIFT(k,a) -> knh a (zshift k stk) - | FCLOS(t,e) -> knht e t (zupdate m stk) + | FLIFT(k,a) -> knh info a (zshift k stk) + | FCLOS(t,e) -> knht info e t (zupdate m stk) | FLOCKED -> assert false - | FApp(a,b) -> knh a (append_stack b (zupdate m stk)) - | FCases(ci,p,t,br) -> knh t (Zcase(ci,p,br)::zupdate m stk) + | FApp(a,b) -> knh info a (append_stack b (zupdate m stk)) + | FCases(ci,p,t,br) -> knh info t (Zcase(ci,p,br)::zupdate m stk) | FFix(((ri,n),(_,_,_)),_) -> (match get_nth_arg m ri.(n) stk with - (Some(pars,arg),stk') -> knh arg (Zfix(m,pars)::stk') + (Some(pars,arg),stk') -> knh info arg (Zfix(m,pars)::stk') | (None, stk') -> (m,stk')) - | FCast(t,_,_) -> knh t stk + | FCast(t,_,_) -> knh info t stk + | FProj (p,c) -> + if red_set info.i_flags (fCONST p) then + (match try Some (lookup_projection p (info_env info)) with Not_found -> None with + | None -> (m, stk) + | Some pb -> + knh info c (Zproj (pb.Declarations.proj_npars, pb.Declarations.proj_arg, p) + :: zupdate m stk)) + else (m,stk) + (* cases where knh stops *) | (FFlex _|FLetIn _|FConstruct _|FEvar _| FCoFix _|FLambda _|FRel _|FAtom _|FInd _|FProd _) -> (m, stk) (* The same for pure terms *) -and knht e t stk = +and knht info e t stk = match kind_of_term t with | App(a,b) -> - knht e a (append_stack (mk_clos_vect e b) stk) + knht info e a (append_stack (mk_clos_vect e b) stk) | Case(ci,p,t,br) -> - knht e t (Zcase(ci, mk_clos e p, mk_clos_vect e br)::stk) - | Fix _ -> knh (mk_clos2 e t) stk - | Cast(a,_,_) -> knht e a stk - | Rel n -> knh (clos_rel e n) stk + knht info e t (Zcase(ci, mk_clos e p, mk_clos_vect e br)::stk) + | Fix _ -> knh info (mk_clos2 e t) stk + | Cast(a,_,_) -> knht info e a stk + | Rel n -> knh info (clos_rel e n) stk + | Proj (p,c) -> knh info (mk_clos2 e t) stk | (Lambda _|Prod _|Construct _|CoFix _|Ind _| LetIn _|Const _|Var _|Evar _|Meta _|Sort _) -> (mk_clos2 e t, stk) @@ -879,8 +967,8 @@ let rec knr info m stk = (match get_args n tys f e stk with Inl e', s -> knit info e' f s | Inr lam, s -> (lam,s)) - | FFlex(ConstKey kn) when red_set info.i_flags (fCONST kn) -> - (match ref_value_cache info (ConstKey kn) with + | FFlex(ConstKey (kn,_ as c)) when red_set info.i_flags (fCONST kn) -> + (match ref_value_cache info (ConstKey c) with Some v -> kni info v stk | None -> (set_norm m; (m,stk))) | FFlex(VarKey id) when red_set info.i_flags (fVAR id) -> @@ -891,7 +979,7 @@ let rec knr info m stk = (match ref_value_cache info (RelKey k) with Some v -> kni info v stk | None -> (set_norm m; (m,stk))) - | FConstruct(ind,c) when red_set info.i_flags fIOTA -> + | FConstruct((ind,c),u) when red_set info.i_flags fIOTA -> (match strip_update_shift_app m stk with (depth, args, Zcase(ci,_,br)::s) -> assert (ci.ci_npar>=0); @@ -902,6 +990,10 @@ let rec knr info m stk = let stk' = par @ append_stack [|rarg|] s in let (fxe,fxbd) = contract_fix_vect fx.term in knit info fxe fxbd stk' + | (depth, args, Zproj (n, m, cst)::s) -> + let rargs = drop_parameters depth n args in + let rarg = project_nth_arg m rargs in + kni info rarg s | (_,args,s) -> (m,args@s)) | FCoFix _ when red_set info.i_flags fIOTA -> (match strip_update_shift_app m stk with @@ -912,17 +1004,17 @@ let rec knr info m stk = | FLetIn (_,v,_,bd,e) when red_set info.i_flags fZETA -> knit info (subs_cons([|v|],e)) bd stk | FEvar(ev,env) -> - (match evar_value info ev with + (match evar_value info.i_cache ev with Some c -> knit info env c stk | None -> (m,stk)) | _ -> (m,stk) (* Computes the weak head normal form of a term *) and kni info m stk = - let (hm,s) = knh m stk in + let (hm,s) = knh info m stk in knr info hm s and knit info e t stk = - let (ht,s) = knht e t stk in + let (ht,s) = knht info e t stk in knr info ht s let kh info v stk = fapp_stack(kni info v stk) @@ -937,6 +1029,9 @@ let rec zip_term zfun m stk = | Zcase(ci,p,br)::s -> let t = mkCase(ci, zfun p, m, Array.map zfun br) in zip_term zfun t s + | Zproj(_,_,p)::s -> + let t = mkProj (p, m) in + zip_term zfun t s | Zfix(fx,par)::s -> let h = mkApp(zip_term zfun (zfun fx) par,[|m|]) in zip_term zfun h s @@ -985,6 +1080,8 @@ and norm_head info m = mkFix(n,(na, CArray.Fun1.map kl info ftys, CArray.Fun1.map kl info fbds)) | FEvar((i,args),env) -> mkEvar(i, Array.map (fun a -> kl info (mk_clos env a)) args) + | FProj (p,c) -> + mkProj (p, kl info c) | t -> term_of_fconstr m (* Initialization and then normalization *) @@ -1009,6 +1106,20 @@ type clos_infos = fconstr infos let create_clos_infos ?(evars=fun _ -> None) flgs env = create (fun _ -> inject) flgs env evars -let oracle_of_infos { i_env } = Environ.oracle i_env - -let unfold_reference = ref_value_cache +let oracle_of_infos infos = Environ.oracle infos.i_cache.i_env + +let infos_with_reds infos reds = + { infos with i_flags = reds } + +let unfold_reference info key = + match key with + | ConstKey (kn,_) -> + if red_set info.i_flags (fCONST kn) then + ref_value_cache info key + else None + | VarKey i -> + if red_set info.i_flags (fVAR i) then + ref_value_cache info key + else None + | _ -> ref_value_cache info key + diff --git a/kernel/closure.mli b/kernel/closure.mli index 19baedf27..ee35e7d49 100644 --- a/kernel/closure.mli +++ b/kernel/closure.mli @@ -80,14 +80,20 @@ val unfold_side_red : reds val unfold_red : evaluable_global_reference -> reds (***********************************************************************) -type table_key = id_key +type table_key = constant puniverses tableKey + +type 'a infos_cache +type 'a infos = { + i_flags : reds; + i_cache : 'a infos_cache } -type 'a infos val ref_value_cache: 'a infos -> table_key -> 'a option -val info_flags: 'a infos -> reds val create: ('a infos -> constr -> 'a) -> reds -> env -> (existential -> constr option) -> 'a infos -val evar_value : 'a infos -> existential -> constr option +val evar_value : 'a infos_cache -> existential -> constr option + +val info_env : 'a infos -> env +val info_flags: 'a infos -> reds (*********************************************************************** s Lazy reduction. *) @@ -104,9 +110,10 @@ type fterm = | FAtom of constr (** Metas and Sorts *) | FCast of fconstr * cast_kind * fconstr | FFlex of table_key - | FInd of inductive - | FConstruct of constructor + | FInd of inductive puniverses + | FConstruct of constructor puniverses | FApp of fconstr * fconstr array + | FProj of constant * fconstr | FFix of fixpoint * fconstr subs | FCoFix of cofixpoint * fconstr subs | FCases of case_info * fconstr * fconstr * fconstr array @@ -126,6 +133,7 @@ type fterm = type stack_member = | Zapp of fconstr array | Zcase of case_info * fconstr * fconstr array + | Zproj of int * int * constant | Zfix of fconstr * stack | Zshift of int | Zupdate of fconstr @@ -159,11 +167,13 @@ val destFLambda : (fconstr subs -> constr -> fconstr) -> fconstr -> Name.t * fconstr * fconstr (** Global and local constant cache *) -type clos_infos +type clos_infos = fconstr infos val create_clos_infos : ?evars:(existential->constr option) -> reds -> env -> clos_infos val oracle_of_infos : clos_infos -> Conv_oracle.oracle +val infos_with_reds : clos_infos -> reds -> clos_infos + (** Reduction function *) (** [norm_val] is for strong normalization *) @@ -177,6 +187,12 @@ val whd_val : clos_infos -> fconstr -> constr val whd_stack : clos_infos -> fconstr -> stack -> fconstr * stack +val eta_expand_ind_stack : env -> lift -> pinductive -> fconstr -> stack -> + (lift * (fconstr * stack)) -> lift * (fconstr * stack) + +val eta_expand_ind_stacks : env -> inductive -> fconstr -> stack -> + (fconstr * stack) -> stack * stack + (** Conversion auxiliary functions to do step by step normalisation *) (** [unfold_reference] unfolds references in a [fconstr] *) diff --git a/kernel/constr.ml b/kernel/constr.ml index e9e21d30d..89c138a08 100644 --- a/kernel/constr.ml +++ b/kernel/constr.ml @@ -25,7 +25,7 @@ open Util open Names - +open Univ type existential_key = Evar.t type metavariable = int @@ -61,6 +61,10 @@ type ('constr, 'types) pfixpoint = (int array * int) * ('constr, 'types) prec_declaration type ('constr, 'types) pcofixpoint = int * ('constr, 'types) prec_declaration +type 'a puniverses = 'a Univ.puniverses +type pconstant = constant puniverses +type pinductive = inductive puniverses +type pconstructor = constructor puniverses (* [Var] is used for named variables and [Rel] for variables as de Bruijn indices. *) @@ -75,13 +79,13 @@ type ('constr, 'types) kind_of_term = | Lambda of Name.t * 'types * 'constr | LetIn of Name.t * 'constr * 'types * 'constr | App of 'constr * 'constr array - | Const of constant - | Ind of inductive - | Construct of constructor + | Const of pconstant + | Ind of pinductive + | Construct of pconstructor | Case of case_info * 'constr * 'constr * 'constr array | Fix of ('constr, 'types) pfixpoint | CoFix of ('constr, 'types) pcofixpoint - + | Proj of constant * 'constr (* constr is the fixpoint of the previous type. Requires option -rectypes of the Caml compiler to be set *) type t = (t,t) kind_of_term @@ -139,19 +143,29 @@ let mkApp (f, a) = | App (g, cl) -> App (g, Array.append cl a) | _ -> App (f, a) +let out_punivs (a, _) = a +let map_puniverses f (x,u) = (f x, u) +let in_punivs a = (a, Univ.Instance.empty) + (* Constructs a constant *) -let mkConst c = Const c +let mkConst c = Const (in_punivs c) +let mkConstU c = Const c + +(* Constructs an applied projection *) +let mkProj (p,c) = Proj (p,c) (* Constructs an existential variable *) let mkEvar e = Evar e (* Constructs the ith (co)inductive type of the block named kn *) -let mkInd m = Ind m +let mkInd m = Ind (in_punivs m) +let mkIndU m = Ind m (* Constructs the jth constructor of the ith (co)inductive type of the - block named kn. The array of terms correspond to the variables - introduced in the section *) -let mkConstruct c = Construct c + block named kn. *) +let mkConstruct c = Construct (in_punivs c) +let mkConstructU c = Construct c +let mkConstructUi ((ind,u),i) = Construct ((ind,i),u) (* Constructs the term <p>Case c of c1 | c2 .. | cn end *) let mkCase (ci, p, c, ac) = Case (ci, p, c, ac) @@ -225,6 +239,7 @@ let fold f acc c = match kind c with | Lambda (_,t,c) -> f (f acc t) c | LetIn (_,b,t,c) -> f (f (f acc b) t) c | App (c,l) -> Array.fold_left f (f acc c) l + | Proj (p,c) -> f acc c | Evar (_,l) -> Array.fold_left f acc l | Case (_,p,c,bl) -> Array.fold_left f (f (f acc p) c) bl | Fix (_,(lna,tl,bl)) -> @@ -244,6 +259,7 @@ let iter f c = match kind c with | Lambda (_,t,c) -> f t; f c | LetIn (_,b,t,c) -> f b; f t; f c | App (c,l) -> f c; Array.iter f l + | Proj (p,c) -> f c | Evar (_,l) -> Array.iter f l | Case (_,p,c,bl) -> f p; f c; Array.iter f bl | Fix (_,(_,tl,bl)) -> Array.iter f tl; Array.iter f bl @@ -265,6 +281,7 @@ let iter_with_binders g f n c = match kind c with | App (c,l) -> f n c; CArray.Fun1.iter f n l | Evar (_,l) -> CArray.Fun1.iter f n l | Case (_,p,c,bl) -> f n p; f n c; CArray.Fun1.iter f n bl + | Proj (p,c) -> f n c | Fix (_,(_,tl,bl)) -> CArray.Fun1.iter f n tl; CArray.Fun1.iter f (iterate g (Array.length tl) n) bl @@ -305,6 +322,10 @@ let map f c = match kind c with let l' = Array.smartmap f l in if b'==b && l'==l then c else mkApp (b', l') + | Proj (p,t) -> + let t' = f t in + if t' == t then c + else mkProj (p, t') | Evar (e,l) -> let l' = Array.smartmap f l in if l'==l then c @@ -413,6 +434,10 @@ let map_with_binders g f l c0 = match kind c0 with let al' = CArray.Fun1.smartmap f l al in if c' == c && al' == al then c0 else mkApp (c', al') + | Proj (p, t) -> + let t' = f l t in + if t' == t then c0 + else mkProj (p, t') | Evar (e, al) -> let al' = CArray.Fun1.smartmap f l al in if al' == al then c0 @@ -435,13 +460,13 @@ let map_with_binders g f l c0 = match kind c0 with let bl' = CArray.Fun1.smartmap f l' bl in mkCoFix (ln,(lna,tl',bl')) -(* [compare f c1 c2] compare [c1] and [c2] using [f] to compare - the immediate subterms of [c1] of [c2] if needed; Cast's, +(* [compare_head_gen u s f c1 c2] compare [c1] and [c2] using [f] to compare + the immediate subterms of [c1] of [c2] if needed, [u] to compare universe + instances and [s] to compare sorts; Cast's, application associativity, binders name and Cases annotations are not taken into account *) - -let compare_head f t1 t2 = +let compare_head_gen eq_universes eq_sorts f t1 t2 = match kind t1, kind t2 with | Rel n1, Rel n2 -> Int.equal n1 n2 | Meta m1, Meta m2 -> Int.equal m1 m2 @@ -458,9 +483,10 @@ let compare_head f t1 t2 = Int.equal (Array.length l1) (Array.length l2) && f c1 c2 && Array.equal f l1 l2 | Evar (e1,l1), Evar (e2,l2) -> Evar.equal e1 e2 && Array.equal f l1 l2 - | Const c1, Const c2 -> eq_constant c1 c2 - | Ind c1, Ind c2 -> eq_ind c1 c2 - | Construct c1, Construct c2 -> eq_constructor c1 c2 + | Proj (p1,c1), Proj (p2,c2) -> eq_constant p1 p2 && f c1 c2 + | Const (c1,u1), Const (c2,u2) -> eq_constant c1 c2 && eq_universes true u1 u2 + | Ind (c1,u1), Ind (c2,u2) -> eq_ind c1 c2 && eq_universes false u1 u2 + | Construct (c1,u1), Construct (c2,u2) -> eq_constructor c1 c2 && eq_universes false u1 u2 | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) -> f p1 p2 && f c1 c2 && Array.equal f bl1 bl2 | Fix ((ln1, i1),(_,tl1,bl1)), Fix ((ln2, i2),(_,tl2,bl2)) -> @@ -470,6 +496,44 @@ let compare_head f t1 t2 = Int.equal ln1 ln2 && Array.equal f tl1 tl2 && Array.equal f bl1 bl2 | _ -> false +let compare_head = compare_head_gen (fun _ -> Univ.Instance.eq) Sorts.equal + +(* [compare_head_gen_leq u s sl eq leq c1 c2] compare [c1] and [c2] using [eq] to compare + the immediate subterms of [c1] of [c2] for conversion if needed, [leq] for cumulativity, + [u] to compare universe instances and [s] to compare sorts; Cast's, + application associativity, binders name and Cases annotations are + not taken into account *) + +let compare_head_gen_leq eq_universes eq_sorts leq_sorts eq leq t1 t2 = + match kind t1, kind t2 with + | Rel n1, Rel n2 -> Int.equal n1 n2 + | Meta m1, Meta m2 -> Int.equal m1 m2 + | Var id1, Var id2 -> Int.equal (id_ord id1 id2) 0 + | Sort s1, Sort s2 -> leq_sorts s1 s2 + | Cast (c1,_,_), _ -> leq c1 t2 + | _, Cast (c2,_,_) -> leq t1 c2 + | Prod (_,t1,c1), Prod (_,t2,c2) -> eq t1 t2 && leq c1 c2 + | Lambda (_,t1,c1), Lambda (_,t2,c2) -> eq t1 t2 && eq c1 c2 + | LetIn (_,b1,t1,c1), LetIn (_,b2,t2,c2) -> eq b1 b2 && eq t1 t2 && leq c1 c2 + | App (Cast(c1, _, _),l1), _ -> leq (mkApp (c1,l1)) t2 + | _, App (Cast (c2, _, _),l2) -> leq t1 (mkApp (c2,l2)) + | App (c1,l1), App (c2,l2) -> + Int.equal (Array.length l1) (Array.length l2) && + eq c1 c2 && Array.equal eq l1 l2 + | Proj (p1,c1), Proj (p2,c2) -> eq_constant p1 p2 && eq c1 c2 + | Evar (e1,l1), Evar (e2,l2) -> Evar.equal e1 e2 && Array.equal eq l1 l2 + | Const (c1,u1), Const (c2,u2) -> eq_constant c1 c2 && eq_universes true u1 u2 + | Ind (c1,u1), Ind (c2,u2) -> eq_ind c1 c2 && eq_universes false u1 u2 + | Construct (c1,u1), Construct (c2,u2) -> eq_constructor c1 c2 && eq_universes false u1 u2 + | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) -> + eq p1 p2 && eq c1 c2 && Array.equal eq bl1 bl2 + | Fix ((ln1, i1),(_,tl1,bl1)), Fix ((ln2, i2),(_,tl2,bl2)) -> + Int.equal i1 i2 && Array.equal Int.equal ln1 ln2 + && Array.equal eq tl1 tl2 && Array.equal eq bl1 bl2 + | CoFix(ln1,(_,tl1,bl1)), CoFix(ln2,(_,tl2,bl2)) -> + Int.equal ln1 ln2 && Array.equal eq tl1 tl2 && Array.equal eq bl1 bl2 + | _ -> false + (*******************************) (* alpha conversion functions *) (*******************************) @@ -477,10 +541,81 @@ let compare_head f t1 t2 = (* alpha conversion : ignore print names and casts *) let rec eq_constr m n = - (m == n) || compare_head eq_constr m n + (m == n) || compare_head_gen (fun _ -> Univ.Instance.eq) Sorts.equal eq_constr m n + +(** Strict equality of universe instances. *) +let compare_constr = compare_head_gen (fun _ -> Univ.Instance.eq) Sorts.equal let equal m n = eq_constr m n (* to avoid tracing a recursive fun *) +let eq_constr_univs univs m n = + if m == n then true + else + let eq_universes _ = Univ.Instance.check_eq univs in + let eq_sorts s1 s2 = Univ.check_eq univs (Sorts.univ_of_sort s1) (Sorts.univ_of_sort s2) in + let rec eq_constr' m n = + m == n || compare_head_gen eq_universes eq_sorts eq_constr' m n + in compare_head_gen eq_universes eq_sorts eq_constr' m n + +let leq_constr_univs univs m n = + if m == n then true + else + let eq_universes _ = Univ.Instance.check_eq univs in + let eq_sorts s1 s2 = Univ.check_eq univs (Sorts.univ_of_sort s1) (Sorts.univ_of_sort s2) in + let leq_sorts s1 s2 = Univ.check_leq univs (Sorts.univ_of_sort s1) (Sorts.univ_of_sort s2) in + let rec eq_constr' m n = + m == n || compare_head_gen eq_universes eq_sorts eq_constr' m n + in + let rec compare_leq m n = + compare_head_gen_leq eq_universes eq_sorts leq_sorts eq_constr' leq_constr' m n + and leq_constr' m n = m == n || compare_leq m n in + compare_leq m n + +let eq_constr_universes m n = + if m == n then true, UniverseConstraints.empty + else + let cstrs = ref UniverseConstraints.empty in + let eq_universes strict l l' = + cstrs := Univ.enforce_eq_instances_univs strict l l' !cstrs; true in + let eq_sorts s1 s2 = + cstrs := Univ.UniverseConstraints.add + (Sorts.univ_of_sort s1, Univ.UEq, Sorts.univ_of_sort s2) !cstrs; + true + in + let rec eq_constr' m n = + m == n || compare_head_gen eq_universes eq_sorts eq_constr' m n + in + let res = compare_head_gen eq_universes eq_sorts eq_constr' m n in + res, !cstrs + +let leq_constr_universes m n = + if m == n then true, UniverseConstraints.empty + else + let cstrs = ref UniverseConstraints.empty in + let eq_universes strict l l' = + cstrs := Univ.enforce_eq_instances_univs strict l l' !cstrs; true in + let eq_sorts s1 s2 = + cstrs := Univ.UniverseConstraints.add + (Sorts.univ_of_sort s1,Univ.UEq,Sorts.univ_of_sort s2) !cstrs; true + in + let leq_sorts s1 s2 = + cstrs := Univ.UniverseConstraints.add + (Sorts.univ_of_sort s1,Univ.ULe,Sorts.univ_of_sort s2) !cstrs; true + in + let rec eq_constr' m n = + m == n || compare_head_gen eq_universes eq_sorts eq_constr' m n + in + let rec compare_leq m n = + compare_head_gen_leq eq_universes eq_sorts leq_sorts eq_constr' leq_constr' m n + and leq_constr' m n = m == n || compare_leq m n in + let res = compare_leq m n in + res, !cstrs + +let always_true _ _ = true + +let rec eq_constr_nounivs m n = + (m == n) || compare_head_gen (fun _ -> always_true) always_true eq_constr_nounivs m n + (** We only use this function over blocks! *) let tag t = Obj.tag (Obj.repr t) @@ -509,11 +644,12 @@ let constr_ord_int f t1 t2 = | App (Cast(c1,_,_),l1), _ -> f (mkApp (c1,l1)) t2 | _, App (Cast(c2, _,_),l2) -> f t1 (mkApp (c2,l2)) | App (c1,l1), App (c2,l2) -> (f =? (Array.compare f)) c1 c2 l1 l2 + | Proj (p1,c1), Proj (p2,c2) -> (con_ord =? f) p1 p2 c1 c2 | Evar (e1,l1), Evar (e2,l2) -> (Evar.compare =? (Array.compare f)) e1 e2 l1 l2 - | Const c1, Const c2 -> con_ord c1 c2 - | Ind ind1, Ind ind2 -> ind_ord ind1 ind2 - | Construct ct1, Construct ct2 -> constructor_ord ct1 ct2 + | Const (c1,u1), Const (c2,u2) -> con_ord c1 c2 + | Ind (ind1, u1), Ind (ind2, u2) -> ind_ord ind1 ind2 + | Construct (ct1,u1), Construct (ct2,u2) -> constructor_ord ct1 ct2 | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) -> ((f =? f) ==? (Array.compare f)) p1 p2 c1 c2 bl1 bl2 | Fix (ln1,(_,tl1,bl1)), Fix (ln2,(_,tl2,bl2)) -> @@ -587,12 +723,14 @@ let hasheq t1 t2 = | Lambda (n1,t1,c1), Lambda (n2,t2,c2) -> n1 == n2 && t1 == t2 && c1 == c2 | LetIn (n1,b1,t1,c1), LetIn (n2,b2,t2,c2) -> n1 == n2 && b1 == b2 && t1 == t2 && c1 == c2 + | Proj (c1,t1), Proj (c2,t2) -> c1 == c2 && t1 == t2 | App (c1,l1), App (c2,l2) -> c1 == c2 && array_eqeq l1 l2 | Evar (e1,l1), Evar (e2,l2) -> Evar.equal e1 e2 && array_eqeq l1 l2 - | Const c1, Const c2 -> c1 == c2 - | Ind (sp1,i1), Ind (sp2,i2) -> sp1 == sp2 && Int.equal i1 i2 - | Construct ((sp1,i1),j1), Construct ((sp2,i2),j2) -> - sp1 == sp2 && Int.equal i1 i2 && Int.equal j1 j2 + | Const (c1,u1), Const (c2,u2) -> c1 == c2 && Univ.Instance.eqeq u1 u2 + | Ind ((sp1,i1),u1), Ind ((sp2,i2),u2) -> + sp1 == sp2 && Int.equal i1 i2 && Univ.Instance.eqeq u1 u2 + | Construct (((sp1,i1),j1),u1), Construct (((sp2,i2),j2),u2) -> + sp1 == sp2 && Int.equal i1 i2 && Int.equal j1 j2 && Univ.Instance.eqeq u1 u2 | Case (ci1,p1,c1,bl1), Case (ci2,p2,c2,bl2) -> ci1 == ci2 && p1 == p2 && c1 == c2 && array_eqeq bl1 bl2 | Fix ((ln1, i1),(lna1,tl1,bl1)), Fix ((ln2, i2),(lna2,tl2,bl2)) -> @@ -631,6 +769,8 @@ let hash_cast_kind = function | DEFAULTcast -> 2 | REVERTcast -> 3 +let hash_instance = Univ.Instance.hcons + (* [hashcons hash_consing_functions constr] computes an hash-consed representation for [constr] using [hash_consing_functions] on leaves. *) @@ -665,12 +805,16 @@ let hashcons (sh_sort,sh_ci,sh_construct,sh_ind,sh_con,sh_na,sh_id) = | Evar (e,l) -> let l, hl = hash_term_array l in (Evar (e,l), combinesmall 8 (combine (Evar.hash e) hl)) - | Const c -> - (Const (sh_con c), combinesmall 9 (Constant.hash c)) - | Ind ind -> - (Ind (sh_ind ind), combinesmall 10 (ind_hash ind)) - | Construct c -> - (Construct (sh_construct c), combinesmall 11 (constructor_hash c)) + | Proj (p,c) -> + let c, hc = sh_rec c in + let p' = sh_con p in + (Proj (p', c), combinesmall 17 (Hashtbl.hash p')) (** FIXME *) + | Const (c,u) -> + (Const (sh_con c, hash_instance u), combinesmall 9 (Constant.hash c)) + | Ind (ind, u) -> + (Ind (sh_ind ind, hash_instance u), combinesmall 10 (ind_hash ind)) + | Construct (c, u) -> + (Construct (sh_construct c, hash_instance u), combinesmall 11 (constructor_hash c)) | Case (ci,p,c,bl) -> let p, hp = sh_rec p and c, hc = sh_rec c in @@ -742,13 +886,15 @@ let rec hash t = | App (Cast(c, _, _),l) -> hash (mkApp (c,l)) | App (c,l) -> combinesmall 7 (combine (hash_term_array l) (hash c)) + | Proj (p,c) -> + combinesmall 17 (combine (Hashtbl.hash p) (hash c)) | Evar (e,l) -> combinesmall 8 (combine (Evar.hash e) (hash_term_array l)) - | Const c -> + | Const (c, _) -> combinesmall 9 (Constant.hash c) - | Ind ind -> + | Ind (ind, _) -> combinesmall 10 (ind_hash ind) - | Construct c -> + | Construct (c, _) -> combinesmall 11 (constructor_hash c) | Case (_ , p, c, bl) -> combinesmall 12 (combine3 (hash c) (hash p) (hash_term_array bl)) @@ -799,8 +945,32 @@ module Hcaseinfo = Hashcons.Make(CaseinfoHash) let case_info_hash = CaseinfoHash.hash +module Hsorts = + Hashcons.Make( + struct + open Sorts + + type t = Sorts.t + type u = universe -> universe + let hashcons huniv = function + Prop c -> Prop c + | Type u -> Type (huniv u) + let equal s1 s2 = + s1 == s2 || + match (s1,s2) with + (Prop c1, Prop c2) -> c1 == c2 + | (Type u1, Type u2) -> u1 == u2 + |_ -> false + let hash = Hashtbl.hash + end) + +let hcons_sorts = Hashcons.simple_hcons Hsorts.generate hcons_univ let hcons_caseinfo = Hashcons.simple_hcons Hcaseinfo.generate hcons_ind +let hcons_pconstruct (c,u) = (hcons_construct c, Univ.Instance.hcons u) +let hcons_pind (i,u) = (hcons_ind i, Univ.Instance.hcons u) +let hcons_pcon (c,u) = (hcons_con c, Univ.Instance.hcons u) + let hcons = hashcons (Sorts.hcons, diff --git a/kernel/constr.mli b/kernel/constr.mli index 82a2de094..be6250257 100644 --- a/kernel/constr.mli +++ b/kernel/constr.mli @@ -8,6 +8,14 @@ open Names +(** {6 Value under universe substitution } *) +type 'a puniverses = 'a Univ.puniverses + +(** {6 Simply type aliases } *) +type pconstant = constant puniverses +type pinductive = inductive puniverses +type pconstructor = constructor puniverses + (** {6 Existential variables } *) type existential_key = Evar.t @@ -88,20 +96,26 @@ val mkLetIn : Name.t * constr * types * constr -> constr {% $(f~t_1~\dots~t_n)$ %}. *) val mkApp : constr * constr array -> constr -(** Constructs a constant - The array of terms correspond to the variables introduced in the section *) +val map_puniverses : ('a -> 'b) -> 'a puniverses -> 'b puniverses + +(** Constructs a constant *) val mkConst : constant -> constr +val mkConstU : pconstant -> constr + +(** Constructs a projection application *) +val mkProj : (constant * constr) -> constr (** Inductive types *) -(** Constructs the ith (co)inductive type of the block named kn - The array of terms correspond to the variables introduced in the section *) +(** Constructs the ith (co)inductive type of the block named kn *) val mkInd : inductive -> constr +val mkIndU : pinductive -> constr (** Constructs the jth constructor of the ith (co)inductive type of the - block named kn. The array of terms correspond to the variables - introduced in the section *) + block named kn. *) val mkConstruct : constructor -> constr +val mkConstructU : pconstructor -> constr +val mkConstructUi : pinductive * int -> constr (** Constructs a destructor of inductive type. @@ -170,12 +184,13 @@ type ('constr, 'types) kind_of_term = | Lambda of Name.t * 'types * 'constr | LetIn of Name.t * 'constr * 'types * 'constr | App of 'constr * 'constr array - | Const of constant - | Ind of inductive - | Construct of constructor + | Const of constant puniverses + | Ind of inductive puniverses + | Construct of constructor puniverses | Case of case_info * 'constr * 'constr * 'constr array | Fix of ('constr, 'types) pfixpoint | CoFix of ('constr, 'types) pcofixpoint + | Proj of constant * 'constr (** User view of [constr]. For [App], it is ensured there is at least one argument and the function is not itself an applicative @@ -187,6 +202,26 @@ val kind : constr -> (constr, types) kind_of_term and application grouping *) val equal : constr -> constr -> bool +(** [eq_constr_univs a b] [true, c] if [a] equals [b] modulo alpha, casts, + application grouping and the universe equalities in [c]. *) +val eq_constr_univs : constr Univ.check_function + +(** [leq_constr_univs a b] [true, c] if [a] is convertible to [b] modulo + alpha, casts, application grouping and the universe inequalities in [c]. *) +val leq_constr_univs : constr Univ.check_function + +(** [eq_constr_universes a b] [true, c] if [a] equals [b] modulo alpha, casts, + application grouping and the universe equalities in [c]. *) +val eq_constr_universes : constr -> constr -> bool Univ.universe_constrained + +(** [leq_constr_universes a b] [true, c] if [a] is convertible to [b] modulo + alpha, casts, application grouping and the universe inequalities in [c]. *) +val leq_constr_universes : constr -> constr -> bool Univ.universe_constrained + +(** [eq_constr_univs a b] [true, c] if [a] equals [b] modulo alpha, casts, + application grouping and ignoring universe instances. *) +val eq_constr_nounivs : constr -> constr -> bool + (** Total ordering compatible with [equal] *) val compare : constr -> constr -> int diff --git a/kernel/conv_oracle.mli b/kernel/conv_oracle.mli index cd8cd2cf7..ae501ce87 100644 --- a/kernel/conv_oracle.mli +++ b/kernel/conv_oracle.mli @@ -16,7 +16,7 @@ val empty : oracle If [oracle_order kn1 kn2] is true, then unfold kn1 first. Note: the oracle does not introduce incompleteness, it only tries to postpone unfolding of "opaque" constants. *) -val oracle_order : oracle -> bool -> 'a tableKey -> 'a tableKey -> bool +val oracle_order : oracle -> bool -> constant tableKey -> constant tableKey -> bool (** Priority for the expansion of constant in the conversion test. * Higher levels means that the expansion is less prioritary. @@ -29,14 +29,14 @@ val transparent : level (** Check whether a level is transparent *) val is_transparent : level -> bool -val get_strategy : oracle -> 'a tableKey -> level +val get_strategy : oracle -> constant tableKey -> level (** Sets the level of a constant. * Level of RelKey constant cannot be set. *) -val set_strategy : oracle -> 'a tableKey -> level -> oracle +val set_strategy : oracle -> constant tableKey -> level -> oracle (** Fold over the non-transparent levels of the oracle. Order unspecified. *) -val fold_strategy : (unit tableKey -> level -> 'a -> 'a) -> oracle -> 'a -> 'a +val fold_strategy : (constant tableKey -> level -> 'a -> 'a) -> oracle -> 'a -> 'a val get_transp_state : oracle -> transparent_state diff --git a/kernel/cooking.ml b/kernel/cooking.ml index dbe188bd4..4bae6de66 100644 --- a/kernel/cooking.ml +++ b/kernel/cooking.ml @@ -19,6 +19,7 @@ open Names open Term open Declarations open Environ +open Univ (*s Cooking the constants. *) @@ -56,27 +57,36 @@ end module RefTable = Hashtbl.Make(RefHash) +let instantiate_my_gr gr u = + match gr with + | ConstRef c -> mkConstU (c, u) + | IndRef i -> mkIndU (i, u) + | ConstructRef c -> mkConstructU (c, u) + let share cache r (cstl,knl) = try RefTable.find cache r with Not_found -> - let f,l = + let f,(u,l) = match r with | IndRef (kn,i) -> - mkInd (pop_mind kn,i), Mindmap.find kn knl + IndRef (pop_mind kn,i), Mindmap.find kn knl | ConstructRef ((kn,i),j) -> - mkConstruct ((pop_mind kn,i),j), Mindmap.find kn knl + ConstructRef ((pop_mind kn,i),j), Mindmap.find kn knl | ConstRef cst -> - mkConst (pop_con cst), Cmap.find cst cstl in - let c = mkApp (f, Array.map mkVar l) in + ConstRef (pop_con cst), Cmap.find cst cstl in + let c = (f, (u, Array.map mkVar l)) in RefTable.add cache r c; c +let share_univs cache r u l = + let r', (u', args) = share cache r l in + mkApp (instantiate_my_gr r' (Instance.append u' u), args) + let update_case_info cache ci modlist = try let ind, n = - match kind_of_term (share cache (IndRef ci.ci_ind) modlist) with - | App (f,l) -> (destInd f, Array.length l) - | Ind ind -> ind, 0 + match share cache (IndRef ci.ci_ind) modlist with + | (IndRef f,(u,l)) -> (f, Array.length l) | _ -> assert false in { ci with ci_ind = ind; ci_npar = ci.ci_npar + n } with Not_found -> @@ -86,31 +96,43 @@ let is_empty_modlist (cm, mm) = Cmap.is_empty cm && Mindmap.is_empty mm let expmod_constr cache modlist c = - let share = share cache in + let share_univs = share_univs cache in let update_case_info = update_case_info cache in let rec substrec c = match kind_of_term c with | Case (ci,p,t,br) -> map_constr substrec (mkCase (update_case_info ci modlist,p,t,br)) - | Ind ind -> + | Ind (ind,u) -> (try - share (IndRef ind) modlist + share_univs (IndRef ind) u modlist with | Not_found -> map_constr substrec c) - | Construct cstr -> + | Construct (cstr,u) -> (try - share (ConstructRef cstr) modlist + share_univs (ConstructRef cstr) u modlist with | Not_found -> map_constr substrec c) - | Const cst -> + | Const (cst,u) -> (try - share (ConstRef cst) modlist + share_univs (ConstRef cst) u modlist with | Not_found -> map_constr substrec c) + | Proj (p, c') -> + (try + let p' = share_univs (ConstRef p) Univ.Instance.empty modlist in + match kind_of_term p' with + | Const (p',_) -> mkProj (p', substrec c') + | App (f, args) -> + (match kind_of_term f with + | Const (p', _) -> mkProj (p', substrec c') + | _ -> assert false) + | _ -> assert false + with Not_found -> map_constr substrec c) + | _ -> map_constr substrec c in @@ -127,7 +149,8 @@ type recipe = { from : constant_body; info : Opaqueproof.cooking_info } type inline = bool type result = - constant_def * constant_type * Univ.constraints * inline + constant_def * constant_type * projection_body option * + bool * constant_universes * inline * Context.section_context option let on_body ml hy f = function @@ -142,15 +165,17 @@ let constr_of_def = function | Def cs -> Mod_subst.force_constr cs | OpaqueDef lc -> Opaqueproof.force_proof lc + let cook_constr { Opaqueproof.modlist ; abstract } c = let cache = RefTable.create 13 in - let hyps = Context.map_named_context (expmod_constr cache modlist) abstract in + let hyps = Context.map_named_context (expmod_constr cache modlist) (fst abstract) in abstract_constant_body (expmod_constr cache modlist c) hyps let cook_constant env { from = cb; info = { Opaqueproof.modlist; abstract } } = let cache = RefTable.create 13 in + let abstract, abs_ctx = abstract in let hyps = Context.map_named_context (expmod_constr cache modlist) abstract in - let body = on_body modlist hyps + let body = on_body modlist (hyps, abs_ctx) (fun c -> abstract_constant_body (expmod_constr cache modlist c) hyps) cb.const_body in @@ -158,18 +183,43 @@ let cook_constant env { from = cb; info = { Opaqueproof.modlist; abstract } } = Context.fold_named_context (fun (h,_,_) hyps -> List.filter (fun (id,_,_) -> not (Id.equal id h)) hyps) hyps ~init:cb.const_hyps in - let typ = match cb.const_type with - | NonPolymorphicType t -> - let typ = - abstract_constant_type (expmod_constr cache modlist t) hyps in - NonPolymorphicType typ - | PolymorphicArity (ctx,s) -> - let t = mkArity (ctx,Type s.poly_level) in - let typ = - abstract_constant_type (expmod_constr cache modlist t) hyps in - let j = make_judge (constr_of_def body) typ in - Typeops.make_polymorphic_if_constant_for_ind env j + + (* let typ = match cb.const_type with *) + (* | NonPolymorphicType t -> *) + (* let typ = *) + (* abstract_constant_type (expmod_constr cache r.d_modlist t) hyps in *) + (* NonPolymorphicType typ *) + (* | PolymorphicArity (ctx,s) -> *) + (* let t = mkArity (ctx,Type s.poly_level) in *) + (* let typ = *) + (* abstract_constant_type (expmod_constr cache r.d_modlist t) hyps in *) + (* let j = make_judge (constr_of_def body) typ in *) + (* Typeops.make_polymorphic_if_constant_for_ind env j *) + (* in *) + let typ = + abstract_constant_type (expmod_constr cache modlist cb.const_type) hyps in - (body, typ, cb.const_constraints, cb.const_inline_code, Some const_hyps) + let projection pb = + let c' = abstract_constant_body (expmod_constr cache modlist pb.proj_body) hyps in + let ((mind, _), _), n' = + try + let c' = share_univs cache (IndRef (pb.proj_ind,0)) Univ.Instance.empty modlist in + match kind_of_term c' with + | App (f,l) -> (destInd f, Array.length l) + | Ind ind -> ind, 0 + | _ -> assert false + with Not_found -> (((pb.proj_ind,0),Univ.Instance.empty), 0) + in + let ctx, ty' = decompose_prod_n (n' + pb.proj_npars + 1) typ in + { proj_ind = mind; proj_npars = pb.proj_npars + n'; proj_arg = pb.proj_arg; + proj_type = ty'; proj_body = c' } + in + let univs = Future.from_val (UContext.union abs_ctx (Future.force cb.const_universes)) in + (body, typ, Option.map projection cb.const_proj, + cb.const_polymorphic, univs, cb.const_inline_code, + Some const_hyps) + +(* let cook_constant_key = Profile.declare_profile "cook_constant" *) +(* let cook_constant = Profile.profile2 cook_constant_key cook_constant *) let expmod_constr modlist c = expmod_constr (RefTable.create 13) modlist c diff --git a/kernel/cooking.mli b/kernel/cooking.mli index 030e88829..489360af7 100644 --- a/kernel/cooking.mli +++ b/kernel/cooking.mli @@ -17,7 +17,8 @@ type recipe = { from : constant_body; info : Opaqueproof.cooking_info } type inline = bool type result = - constant_def * constant_type * Univ.constraints * inline + constant_def * constant_type * projection_body option * + bool * constant_universes * inline * Context.section_context option val cook_constant : env -> recipe -> result diff --git a/kernel/declarations.mli b/kernel/declarations.mli index 1e94e243c..f3cb41f32 100644 --- a/kernel/declarations.mli +++ b/kernel/declarations.mli @@ -18,14 +18,7 @@ type engagement = ImpredicativeSet (** {6 Representation of constants (Definition/Axiom) } *) -type polymorphic_arity = { - poly_param_levels : Univ.universe option list; - poly_level : Univ.universe; -} - -type constant_type = - | NonPolymorphicType of types - | PolymorphicArity of rel_context * polymorphic_arity +type constant_type = types (** Inlining level of parameters at functor applications. None means no inlining *) @@ -35,11 +28,24 @@ type inline = int option (** A constant can have no body (axiom/parameter), or a transparent body, or an opaque one *) +(** Projections are a particular kind of constant: + always transparent. *) + +type projection_body = { + proj_ind : mutual_inductive; + proj_npars : int; + proj_arg : int; + proj_type : types; (* Type under params *) + proj_body : constr; (* For compatibility, the match version *) +} + type constant_def = | Undef of inline | Def of constr Mod_subst.substituted | OpaqueDef of Opaqueproof.opaque +type constant_universes = Univ.universe_context Future.computation + (* some contraints are in constant_constraints, some other may be in * the OpaueDef *) type constant_body = { @@ -47,7 +53,9 @@ type constant_body = { const_body : constant_def; const_type : constant_type; const_body_code : Cemitcodes.to_patch_substituted; - const_constraints : Univ.constraints; + const_polymorphic : bool; (** Is it polymorphic or not *) + const_universes : constant_universes; + const_proj : projection_body option; const_inline_code : bool } type side_effect = @@ -71,15 +79,11 @@ type wf_paths = recarg Rtree.t v} *) -type monomorphic_inductive_arity = { - mind_user_arity : constr; +type inductive_arity = { + mind_user_arity : types; mind_sort : sorts; } -type inductive_arity = -| Monomorphic of monomorphic_inductive_arity -| Polymorphic of polymorphic_arity - type one_inductive_body = { (** {8 Primitive datas } *) @@ -87,7 +91,7 @@ type one_inductive_body = { mind_arity_ctxt : rel_context; (** Arity context of [Ii] with parameters: [forall params, Ui] *) - mind_arity : inductive_arity; (** Arity sort and original user arity if monomorphic *) + mind_arity : inductive_arity; (** Arity sort and original user arity *) mind_consnames : Id.t array; (** Names of the constructors: [cij] *) @@ -129,7 +133,9 @@ type mutual_inductive_body = { mind_packets : one_inductive_body array; (** The component of the mutual inductive block *) - mind_record : bool; (** Whether the inductive type has been declared as a record *) + mind_record : (constr * constant array) option; + (** Whether the inductive type has been declared as a record, + In that case we get its canonical eta-expansion and list of projections. *) mind_finite : bool; (** Whether the type is inductive or coinductive *) @@ -143,7 +149,9 @@ type mutual_inductive_body = { mind_params_ctxt : rel_context; (** The context of parameters (includes let-in declaration) *) - mind_constraints : Univ.constraints; (** Universes constraints enforced by the inductive declaration *) + mind_polymorphic : bool; (** Is it polymorphic or not *) + + mind_universes : Univ.universe_context; (** Local universe variables and constraints *) } diff --git a/kernel/declareops.ml b/kernel/declareops.ml index 1b67de0ea..0e4b80495 100644 --- a/kernel/declareops.ml +++ b/kernel/declareops.ml @@ -20,8 +20,9 @@ let body_of_constant cb = match cb.const_body with | Def c -> Some (force_constr c) | OpaqueDef o -> Some (Opaqueproof.force_proof o) -let constraints_of_constant cb = Univ.union_constraints cb.const_constraints - (match cb.const_body with +let constraints_of_constant cb = Univ.Constraint.union + (Univ.UContext.constraints (Future.force cb.const_universes)) + (match cb.const_body with | Undef _ -> Univ.empty_constraint | Def c -> Univ.empty_constraint | OpaqueDef o -> Opaqueproof.force_constraints o) @@ -43,36 +44,48 @@ let subst_rel_declaration sub (id,copt,t as x) = let subst_rel_context sub = List.smartmap (subst_rel_declaration sub) -let subst_const_type sub arity = match arity with - | NonPolymorphicType s -> - let s' = subst_mps sub s in - if s==s' then arity else NonPolymorphicType s' - | PolymorphicArity (ctx,s) -> - let ctx' = subst_rel_context sub ctx in - if ctx==ctx' then arity else PolymorphicArity (ctx',s) +(* let subst_const_type sub arity = match arity with *) +(* | NonPolymorphicType s -> *) +(* let s' = subst_mps sub s in *) +(* if s==s' then arity else NonPolymorphicType s' *) +(* | PolymorphicArity (ctx,s) -> *) +(* let ctx' = subst_rel_context sub ctx in *) +(* if ctx==ctx' then arity else PolymorphicArity (ctx',s) *) + +let subst_const_type sub arity = + if is_empty_subst sub then arity + else subst_mps sub arity (** No need here to check for physical equality after substitution, at least for Def due to the delayed substitution [subst_constr_subst]. *) - let subst_const_def sub def = match def with | Undef _ -> def | Def c -> Def (subst_constr sub c) | OpaqueDef o -> OpaqueDef (Opaqueproof.subst_opaque sub o) +let subst_const_proj sub pb = + { pb with proj_ind = subst_mind sub pb.proj_ind; + proj_type = subst_mps sub pb.proj_type; + proj_body = subst_const_type sub pb.proj_body } + let subst_const_body sub cb = assert (List.is_empty cb.const_hyps); (* we're outside sections *) if is_empty_subst sub then cb else let body' = subst_const_def sub cb.const_body in let type' = subst_const_type sub cb.const_type in - if body' == cb.const_body && type' == cb.const_type then cb + let proj' = Option.smartmap (subst_const_proj sub) cb.const_proj in + if body' == cb.const_body && type' == cb.const_type + && proj' == cb.const_proj then cb else { const_hyps = []; const_body = body'; const_type = type'; + const_proj = proj'; const_body_code = Cemitcodes.subst_to_patch_subst sub cb.const_body_code; - const_constraints = cb.const_constraints; + const_polymorphic = cb.const_polymorphic; + const_universes = cb.const_universes; const_inline_code = cb.const_inline_code } (** {7 Hash-consing of constants } *) @@ -89,16 +102,7 @@ let hcons_rel_decl ((n,oc,t) as d) = let hcons_rel_context l = List.smartmap hcons_rel_decl l -let hcons_polyarity ar = - { poly_param_levels = - List.smartmap (Option.smartmap Univ.hcons_univ) ar.poly_param_levels; - poly_level = Univ.hcons_univ ar.poly_level } - -let hcons_const_type = function - | NonPolymorphicType t -> - NonPolymorphicType (Term.hcons_constr t) - | PolymorphicArity (ctx,s) -> - PolymorphicArity (hcons_rel_context ctx, hcons_polyarity s) +let hcons_const_type t = Term.hcons_constr t let hcons_const_def = function | Undef inl -> Undef inl @@ -111,7 +115,11 @@ let hcons_const_body cb = { cb with const_body = hcons_const_def cb.const_body; const_type = hcons_const_type cb.const_type; - const_constraints = Univ.hcons_constraints cb.const_constraints; } + const_universes = + if Future.is_val cb.const_universes then + Future.from_val + (Univ.hcons_universe_context (Future.force cb.const_universes)) + else (* FIXME: Why not? *) cb.const_universes } (** {6 Inductive types } *) @@ -124,10 +132,10 @@ let eq_recarg r1 r2 = match r1, r2 with let subst_recarg sub r = match r with | Norec -> r | Mrec (kn,i) -> - let kn' = subst_ind sub kn in + let kn' = subst_mind sub kn in if kn==kn' then r else Mrec (kn',i) | Imbr (kn,i) -> - let kn' = subst_ind sub kn in + let kn' = subst_mind sub kn in if kn==kn' then r else Imbr (kn',i) let mk_norec = Rtree.mk_node Norec [||] @@ -156,63 +164,108 @@ let subst_wf_paths sub p = Rtree.smartmap (subst_recarg sub) p (** {7 Substitution of inductive declarations } *) -let subst_indarity sub ar = match ar with - | Monomorphic s -> - let uar' = subst_mps sub s.mind_user_arity in - if uar' == s.mind_user_arity then ar - else Monomorphic { mind_user_arity = uar'; mind_sort = s.mind_sort } - | Polymorphic _ -> ar - -let subst_mind_packet sub mip = - let { mind_nf_lc = nf; - mind_user_lc = user; - mind_arity_ctxt = ctxt; - mind_arity = ar; - mind_recargs = ra } = mip - in - let nf' = Array.smartmap (subst_mps sub) nf in - let user' = - (* maintain sharing of [mind_user_lc] and [mind_nf_lc] *) - if user==nf then nf' - else Array.smartmap (subst_mps sub) user - in - let ctxt' = subst_rel_context sub ctxt in - let ar' = subst_indarity sub ar in - let ra' = subst_wf_paths sub ra in - if nf==nf' && user==user' && ctxt==ctxt' && ar==ar' && ra==ra' - then mip - else - { mip with - mind_nf_lc = nf'; - mind_user_lc = user'; - mind_arity_ctxt = ctxt'; - mind_arity = ar'; - mind_recargs = ra' } - -let subst_mind sub mib = - assert (List.is_empty mib.mind_hyps); (* we're outside sections *) - if is_empty_subst sub then mib - else - let params = mib.mind_params_ctxt in - let params' = Context.map_rel_context (subst_mps sub) params in - let packets = mib.mind_packets in - let packets' = Array.smartmap (subst_mind_packet sub) packets in - if params==params' && packets==packets' then mib - else - { mib with - mind_params_ctxt = params'; - mind_packets = packets' } - -(** {6 Hash-consing of inductive declarations } *) - -(** Just as for constants, this hash-consing is quite partial *) - -let hcons_indarity = function - | Monomorphic a -> - Monomorphic - { mind_user_arity = Term.hcons_constr a.mind_user_arity; - mind_sort = Term.hcons_sorts a.mind_sort } - | Polymorphic a -> Polymorphic (hcons_polyarity a) +(* OLD POLYMORPHISM *) +(* let subst_indarity sub ar = match ar with *) +(* | Monomorphic s -> *) +(* let uar' = subst_mps sub s.mind_user_arity in *) +(* if uar' == s.mind_user_arity then ar *) +(* else Monomorphic { mind_user_arity = uar'; mind_sort = s.mind_sort } *) +(* | Polymorphic _ -> ar *) + +(* let subst_mind_packet sub mip = *) +(* let { mind_nf_lc = nf; *) +(* mind_user_lc = user; *) +(* mind_arity_ctxt = ctxt; *) +(* mind_arity = ar; *) +(* mind_recargs = ra } = mip *) +(* in *) +(* let nf' = Array.smartmap (subst_mps sub) nf in *) +(* let user' = *) +(* (\* maintain sharing of [mind_user_lc] and [mind_nf_lc] *\) *) +(* if user==nf then nf' *) +(* else Array.smartmap (subst_mps sub) user *) +(* in *) +(* let ctxt' = subst_rel_context sub ctxt in *) +(* let ar' = subst_indarity sub ar in *) +(* let ra' = subst_wf_paths sub ra in *) +(* if nf==nf' && user==user' && ctxt==ctxt' && ar==ar' && ra==ra' *) +(* then mip *) +(* else *) +(* { mip with *) +(* mind_nf_lc = nf'; *) +(* mind_user_lc = user'; *) +(* mind_arity_ctxt = ctxt'; *) +(* mind_arity = ar'; *) +(* mind_recargs = ra' } *) + +(* let subst_mind sub mib = *) +(* assert (List.is_empty mib.mind_hyps); (\* we're outside sections *\) *) +(* if is_empty_subst sub then mib *) +(* else *) +(* let params = mib.mind_params_ctxt in *) +(* let params' = Context.map_rel_context (subst_mps sub) params in *) +(* let packets = mib.mind_packets in *) +(* let packets' = Array.smartmap (subst_mind_packet sub) packets in *) +(* if params==params' && packets==packets' then mib *) +(* else *) +(* { mib with *) +(* mind_params_ctxt = params'; *) +(* mind_packets = packets'; *) +(* mind_native_name = ref NotLinked } *) + +(* (\** {6 Hash-consing of inductive declarations } *\) *) + +(* (\** Just as for constants, this hash-consing is quite partial *\) *) + +(* let hcons_indarity = function *) +(* | Monomorphic a -> *) +(* Monomorphic *) +(* { mind_user_arity = Term.hcons_constr a.mind_user_arity; *) +(* mind_sort = Term.hcons_sorts a.mind_sort } *) +(* | Polymorphic a -> Polymorphic (hcons_polyarity a) *) + +(** Substitution of inductive declarations *) + +let subst_indarity sub s = + { mind_user_arity = subst_mps sub s.mind_user_arity; + mind_sort = s.mind_sort; + } + +let subst_mind_packet sub mbp = + { mind_consnames = mbp.mind_consnames; + mind_consnrealdecls = mbp.mind_consnrealdecls; + mind_consnrealargs = mbp.mind_consnrealargs; + mind_typename = mbp.mind_typename; + mind_nf_lc = Array.smartmap (subst_mps sub) mbp.mind_nf_lc; + mind_arity_ctxt = subst_rel_context sub mbp.mind_arity_ctxt; + mind_arity = subst_indarity sub mbp.mind_arity; + mind_user_lc = Array.smartmap (subst_mps sub) mbp.mind_user_lc; + mind_nrealargs = mbp.mind_nrealargs; + mind_nrealargs_ctxt = mbp.mind_nrealargs_ctxt; + mind_kelim = mbp.mind_kelim; + mind_recargs = subst_wf_paths sub mbp.mind_recargs (*wf_paths*); + mind_nb_constant = mbp.mind_nb_constant; + mind_nb_args = mbp.mind_nb_args; + mind_reloc_tbl = mbp.mind_reloc_tbl } + +let subst_mind_body sub mib = + { mind_record = mib.mind_record ; + mind_finite = mib.mind_finite ; + mind_ntypes = mib.mind_ntypes ; + mind_hyps = (match mib.mind_hyps with [] -> [] | _ -> assert false); + mind_nparams = mib.mind_nparams; + mind_nparams_rec = mib.mind_nparams_rec; + mind_params_ctxt = + Context.map_rel_context (subst_mps sub) mib.mind_params_ctxt; + mind_packets = Array.smartmap (subst_mind_packet sub) mib.mind_packets ; + mind_polymorphic = mib.mind_polymorphic; + mind_universes = mib.mind_universes } + +(** Hash-consing of inductive declarations *) + +let hcons_indarity a = + { mind_user_arity = Term.hcons_constr a.mind_user_arity; + mind_sort = Term.hcons_sorts a.mind_sort } let hcons_mind_packet oib = let user = Array.smartmap Term.hcons_types oib.mind_user_lc in @@ -231,11 +284,12 @@ let hcons_mind mib = { mib with mind_packets = Array.smartmap hcons_mind_packet mib.mind_packets; mind_params_ctxt = hcons_rel_context mib.mind_params_ctxt; - mind_constraints = Univ.hcons_constraints mib.mind_constraints } + mind_universes = Univ.hcons_universe_context mib.mind_universes } (** {6 Stm machinery } *) let join_constant_body cb = + ignore(Future.join cb.const_universes); match cb.const_body with | OpaqueDef o -> Opaqueproof.join_opaque o | _ -> () diff --git a/kernel/declareops.mli b/kernel/declareops.mli index 800b167ab..0c5f3584e 100644 --- a/kernel/declareops.mli +++ b/kernel/declareops.mli @@ -57,7 +57,7 @@ val recarg_length : wf_paths -> int -> int val subst_wf_paths : substitution -> wf_paths -> wf_paths -val subst_mind : substitution -> mutual_inductive_body -> mutual_inductive_body +val subst_mind_body : substitution -> mutual_inductive_body -> mutual_inductive_body val join_constant_body : constant_body -> unit diff --git a/kernel/entries.mli b/kernel/entries.mli index 73efc7372..24e029bc0 100644 --- a/kernel/entries.mli +++ b/kernel/entries.mli @@ -44,12 +44,16 @@ type mutual_inductive_entry = { mind_entry_record : bool; mind_entry_finite : bool; mind_entry_params : (Id.t * local_entry) list; - mind_entry_inds : one_inductive_entry list } + mind_entry_inds : one_inductive_entry list; + mind_entry_polymorphic : bool; + mind_entry_universes : Univ.universe_context } (** {6 Constants (Definition/Axiom) } *) type proof_output = constr * Declareops.side_effects type const_entry_body = proof_output Future.computation +type projection = mutual_inductive * int * int * types + type definition_entry = { const_entry_body : const_entry_body; (* List of sectoin variables *) @@ -57,12 +61,16 @@ type definition_entry = { (* State id on which the completion of type checking is reported *) const_entry_feedback : Stateid.t option; const_entry_type : types option; + const_entry_polymorphic : bool; + const_entry_universes : Univ.universe_context; + const_entry_proj : projection option; const_entry_opaque : bool; const_entry_inline_code : bool } type inline = int option (* inlining level, None for no inlining *) -type parameter_entry = Context.section_context option * types * inline +type parameter_entry = + Context.section_context option * bool * types Univ.in_universe_context * inline type constant_entry = | DefinitionEntry of definition_entry diff --git a/kernel/environ.ml b/kernel/environ.ml index d306599ad..323d6fcea 100644 --- a/kernel/environ.ml +++ b/kernel/environ.ml @@ -26,7 +26,6 @@ open Names open Term open Context open Vars -open Univ open Declarations open Pre_env @@ -46,6 +45,12 @@ let empty_named_context_val = empty_named_context_val let empty_env = empty_env let engagement env = env.env_stratification.env_engagement + +let is_impredicative_set env = + match engagement env with + | Some ImpredicativeSet -> true + | _ -> false + let universes env = env.env_stratification.env_universes let named_context env = env.env_named_context let named_context_val env = env.env_named_context,env.env_named_vals @@ -160,6 +165,30 @@ let fold_named_context f env ~init = let fold_named_context_reverse f ~init env = Context.fold_named_context_reverse f ~init:init (named_context env) + +(* Universe constraints *) + +let add_constraints c env = + if Univ.Constraint.is_empty c then + env + else + let s = env.env_stratification in + { env with env_stratification = + { s with env_universes = Univ.merge_constraints c s.env_universes } } + +let check_constraints c env = + Univ.check_constraints c env.env_stratification.env_universes + +let set_engagement c env = (* Unsafe *) + { env with env_stratification = + { env.env_stratification with env_engagement = Some c } } + +let push_constraints_to_env (_,univs) env = + add_constraints univs env + +let push_context ctx env = add_constraints (Univ.UContext.constraints ctx) env +let push_context_set ctx env = add_constraints (Univ.ContextSet.constraints ctx) env + (* Global constants *) let lookup_constant = lookup_constant @@ -177,30 +206,113 @@ let add_constant_key kn cb linkinfo env = let add_constant kn cb env = add_constant_key kn cb (no_link_info ()) env +let universes_of cb = + Future.force cb.const_universes + +let universes_and_subst_of cb u = + let univs = universes_of cb in + let subst = Univ.make_universe_subst u univs in + subst, Univ.instantiate_univ_context subst univs + (* constant_type gives the type of a constant *) -let constant_type env kn = +let constant_type env (kn,u) = let cb = lookup_constant kn env in - cb.const_type + if cb.const_polymorphic then + let subst, csts = universes_and_subst_of cb u in + (subst_univs_constr subst cb.const_type, csts) + else cb.const_type, Univ.Constraint.empty -type const_evaluation_result = NoBody | Opaque +let constant_type_in_ctx env kn = + let cb = lookup_constant kn env in + cb.const_type, Future.force cb.const_universes + +let constant_context env kn = + let cb = lookup_constant kn env in + if cb.const_polymorphic then Future.force cb.const_universes + else Univ.UContext.empty + +type const_evaluation_result = NoBody | Opaque | IsProj exception NotEvaluableConst of const_evaluation_result -let constant_value env kn = +let constant_value env (kn,u) = + let cb = lookup_constant kn env in + if cb.const_proj = None then + match cb.const_body with + | Def l_body -> + if cb.const_polymorphic then + let subst, csts = universes_and_subst_of cb u in + (subst_univs_constr subst (Mod_subst.force_constr l_body), csts) + else Mod_subst.force_constr l_body, Univ.Constraint.empty + | OpaqueDef _ -> raise (NotEvaluableConst Opaque) + | Undef _ -> raise (NotEvaluableConst NoBody) + else raise (NotEvaluableConst IsProj) + +let constant_opt_value env cst = + try Some (constant_value env cst) + with NotEvaluableConst _ -> None + +let constant_value_and_type env (kn, u) = + let cb = lookup_constant kn env in + if cb.const_polymorphic then + let subst, cst = universes_and_subst_of cb u in + let b' = match cb.const_body with + | Def l_body -> Some (subst_univs_constr subst (Mod_subst.force_constr l_body)) + | OpaqueDef _ -> None + | Undef _ -> None + in b', subst_univs_constr subst cb.const_type, cst + else + let b' = match cb.const_body with + | Def l_body -> Some (Mod_subst.force_constr l_body) + | OpaqueDef _ -> None + | Undef _ -> None + in b', cb.const_type, Univ.Constraint.empty + +(* These functions should be called under the invariant that [env] + already contains the constraints corresponding to the constant + application. *) + +(* constant_type gives the type of a constant *) +let constant_type_in env (kn,u) = + let cb = lookup_constant kn env in + if cb.const_polymorphic then + let subst = Univ.make_universe_subst u (Future.force cb.const_universes) in + subst_univs_constr subst cb.const_type + else cb.const_type + +let constant_value_in env (kn,u) = let cb = lookup_constant kn env in match cb.const_body with - | Def l_body -> Mod_subst.force_constr l_body + | Def l_body -> + let b = Mod_subst.force_constr l_body in + if cb.const_polymorphic then + let subst = Univ.make_universe_subst u (Future.force cb.const_universes) in + subst_univs_constr subst b + else b | OpaqueDef _ -> raise (NotEvaluableConst Opaque) | Undef _ -> raise (NotEvaluableConst NoBody) -let constant_opt_value env cst = - try Some (constant_value env cst) +let constant_opt_value_in env cst = + try Some (constant_value_in env cst) with NotEvaluableConst _ -> None (* A global const is evaluable if it is defined and not opaque *) -let evaluable_constant cst env = - try let _ = constant_value env cst in true - with NotEvaluableConst _ -> false +let evaluable_constant kn env = + let cb = lookup_constant kn env in + match cb.const_body with + | Def _ -> true + | OpaqueDef _ -> false + | Undef _ -> false + +let lookup_projection cst env = + match (lookup_constant cst env).const_proj with + | Some pb -> pb + | None -> anomaly (Pp.str "lookup_projection: constant is not a projection") + +let is_projection cst env = + match (lookup_constant cst env).const_proj with + | Some _ -> true + | None -> false (* Mutual Inductives *) let lookup_mind = lookup_mind @@ -215,21 +327,10 @@ let add_mind_key kn mind_key env = let add_mind kn mib env = let li = no_link_info () in add_mind_key kn (mib, li) env -(* Universe constraints *) - -let add_constraints c env = - if is_empty_constraint c then - env - else - let s = env.env_stratification in - { env with env_stratification = - { s with env_universes = merge_constraints c s.env_universes } } +(* Lookup of section variables *) -let set_engagement c env = (* Unsafe *) - { env with env_stratification = - { env.env_stratification with env_engagement = Some c } } +let constant_body_hyps cb = cb.const_hyps -(* Lookup of section variables *) let lookup_constant_variables c env = let cmap = lookup_constant c env in Context.vars_of_named_context cmap.const_hyps @@ -246,9 +347,10 @@ let lookup_constructor_variables (ind,_) env = let vars_of_global env constr = match kind_of_term constr with Var id -> Id.Set.singleton id - | Const kn -> lookup_constant_variables kn env - | Ind ind -> lookup_inductive_variables ind env - | Construct cstr -> lookup_constructor_variables cstr env + | Const (kn, _) -> lookup_constant_variables kn env + | Ind (ind, _) -> lookup_inductive_variables ind env + | Construct (cstr, _) -> lookup_constructor_variables cstr env + (** FIXME: is Proj missing? *) | _ -> raise Not_found let global_vars_set env constr = @@ -423,7 +525,7 @@ let unregister env field = is abstract, and that the only function which add elements to the retroknowledge is Environ.register which enforces this shape *) (match kind_of_term (retroknowledge find env field) with - | Ind i31t -> let i31c = mkConstruct (i31t, 1) in + | Ind i31t -> let i31c = mkConstructUi (i31t, 1) in {env with retroknowledge = remove (retroknowledge clear_info env i31c) field} | _ -> assert false) @@ -487,7 +589,7 @@ let register = let add_int31_before_match rk grp v = let rk = add_vm_before_match_info rk v Cbytegen.int31_escape_before_match in match kind_of_term (Retroknowledge.find rk (KInt31 (grp,Int31Bits))) with - | Ind i31bit_type -> + | Ind (i31bit_type,_) -> add_native_before_match_info rk v (Nativelambda.before_match_int31 i31bit_type) | _ -> anomaly ~label:"Environ.register" (Pp.str "Int31Bits should be an inductive type") @@ -498,13 +600,13 @@ fun env field value -> operators to the reactive retroknowledge. *) let add_int31_binop_from_const op prim = match kind_of_term value with - | Const kn -> retroknowledge add_int31_op env value 2 + | Const (kn,_) -> retroknowledge add_int31_op env value 2 op prim kn | _ -> anomaly ~label:"Environ.register" (Pp.str "should be a constant") in let add_int31_unop_from_const op prim = match kind_of_term value with - | Const kn -> retroknowledge add_int31_op env value 1 + | Const (kn,_) -> retroknowledge add_int31_op env value 1 op prim kn | _ -> anomaly ~label:"Environ.register" (Pp.str "should be a constant") in @@ -516,9 +618,9 @@ fun env field value -> match field with | KInt31 (grp, Int31Type) -> (match kind_of_term (Retroknowledge.find rk (KInt31 (grp,Int31Bits))) with - | Ind i31bit_type -> + | Ind (i31bit_type,_) -> (match kind_of_term value with - | Ind i31t -> + | Ind (i31t,_) -> Retroknowledge.add_vm_decompile_constant_info rk value (constr_of_int31 i31t i31bit_type) | _ -> anomaly ~label:"Environ.register" (Pp.str "should be an inductive type")) @@ -530,7 +632,7 @@ fun env field value -> match field with | KInt31 (grp, Int31Type) -> let i31c = match kind_of_term value with - | Ind i31t -> mkConstruct (i31t, 1) + | Ind i31t -> mkConstructUi (i31t, 1) | _ -> anomaly ~label:"Environ.register" (Pp.str "should be an inductive type") in add_int31_decompilation_from_type @@ -554,7 +656,7 @@ fun env field value -> Primitives.Int31mulc | KInt31 (_, Int31Div21) -> (* this is a ternary operation *) (match kind_of_term value with - | Const kn -> + | Const (kn,u) -> retroknowledge add_int31_op env value 3 Cbytecodes.Kdiv21int31 Primitives.Int31div21 kn | _ -> anomaly ~label:"Environ.register" (Pp.str "should be a constant")) @@ -562,7 +664,7 @@ fun env field value -> Primitives.Int31div | KInt31 (_, Int31AddMulDiv) -> (* this is a ternary operation *) (match kind_of_term value with - | Const kn -> + | Const (kn,u) -> retroknowledge add_int31_op env value 3 Cbytecodes.Kaddmuldivint31 Primitives.Int31addmuldiv kn | _ -> anomaly ~label:"Environ.register" (Pp.str "should be a constant")) diff --git a/kernel/environ.mli b/kernel/environ.mli index 652cd59bf..fb5d79718 100644 --- a/kernel/environ.mli +++ b/kernel/environ.mli @@ -10,6 +10,7 @@ open Names open Term open Context open Declarations +open Univ (** Unsafe environments. We define here a datatype for environments. Since typing is not yet defined, it is not possible to check the @@ -47,6 +48,7 @@ val named_context_val : env -> named_context_val val engagement : env -> engagement option +val is_impredicative_set : env -> bool (** is the local context empty *) val empty_context : env -> bool @@ -125,17 +127,36 @@ val add_constant_key : constant -> constant_body -> Pre_env.link_info ref -> val lookup_constant : constant -> env -> constant_body val evaluable_constant : constant -> env -> bool +val lookup_projection : Names.projection -> env -> projection_body +val is_projection : constant -> env -> bool + (** {6 ... } *) (** [constant_value env c] raises [NotEvaluableConst Opaque] if [c] is opaque and [NotEvaluableConst NoBody] if it has no - body and [Not_found] if it does not exist in [env] *) + body and [NotEvaluableConst IsProj] if [c] is a projection + and [Not_found] if it does not exist in [env] *) -type const_evaluation_result = NoBody | Opaque +type const_evaluation_result = NoBody | Opaque | IsProj exception NotEvaluableConst of const_evaluation_result -val constant_value : env -> constant -> constr -val constant_type : env -> constant -> constant_type -val constant_opt_value : env -> constant -> constr option +val constant_value : env -> constant puniverses -> constr constrained +val constant_type : env -> constant puniverses -> types constrained +val constant_type_in_ctx : env -> constant -> types Univ.in_universe_context + +val constant_opt_value : env -> constant puniverses -> (constr * Univ.constraints) option +val constant_value_and_type : env -> constant puniverses -> + types option * constr * Univ.constraints +(** The universe context associated to the constant, empty if not + polymorphic *) +val constant_context : env -> constant -> Univ.universe_context + +(* These functions should be called under the invariant that [env] + already contains the constraints corresponding to the constant + application. *) +val constant_value_in : env -> constant puniverses -> constr +val constant_type_in : env -> constant puniverses -> types +val constant_opt_value_in : env -> constant puniverses -> constr option + (** {5 Inductive types } *) val add_mind_key : mutual_inductive -> Pre_env.mind_key -> env -> env @@ -157,8 +178,17 @@ val lookup_modtype : module_path -> env -> module_type_body (** {5 Universe constraints } *) +(** Add universe constraints to the environment. + @raises UniverseInconsistency +*) val add_constraints : Univ.constraints -> env -> env +(** Check constraints are satifiable in the environment. *) +val check_constraints : Univ.constraints -> env -> bool +val push_context : Univ.universe_context -> env -> env +val push_context_set : Univ.universe_context_set -> env -> env +val push_constraints_to_env : 'a Univ.constrained -> env -> env + val set_engagement : engagement -> env -> env (** {6 Sets of referred section variables } diff --git a/kernel/fast_typeops.ml b/kernel/fast_typeops.ml new file mode 100644 index 000000000..b441e02a3 --- /dev/null +++ b/kernel/fast_typeops.ml @@ -0,0 +1,475 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Errors +open Util +open Names +open Univ +open Term +open Vars +open Context +open Declarations +open Environ +open Entries +open Reduction +open Inductive +open Type_errors + +let conv_leq l2r env x y = default_conv CUMUL ~l2r env x y + +let conv_leq_vecti env v1 v2 = + Array.fold_left2_i + (fun i _ t1 t2 -> + try conv_leq false env t1 t2 + with NotConvertible -> raise (NotConvertibleVect i)) + () + v1 + v2 + +let check_constraints cst env = + if Environ.check_constraints cst env then () + else error_unsatisfied_constraints env cst + +(* This should be a type (a priori without intension to be an assumption) *) +let type_judgment env c t = + match kind_of_term(whd_betadeltaiota env t) with + | Sort s -> {utj_val = c; utj_type = s } + | _ -> error_not_type env (make_judge c t) + +let check_type env c t = + match kind_of_term(whd_betadeltaiota env t) with + | Sort s -> s + | _ -> error_not_type env (make_judge c t) + +(* This should be a type intended to be assumed. The error message is *) +(* not as useful as for [type_judgment]. *) +let assumption_of_judgment env t ty = + try let _ = check_type env t ty in t + with TypeError _ -> + error_assumption env (make_judge t ty) + +(************************************************) +(* Incremental typing rules: builds a typing judgement given the *) +(* judgements for the subterms. *) + +(*s Type of sorts *) + +(* Prop and Set *) + +let judge_of_prop = mkSort type1_sort +let judge_of_set = judge_of_prop + +let judge_of_prop_contents _ = judge_of_prop + +(* Type of Type(i). *) + +let judge_of_type u = + let uu = Universe.super u in + mkType uu + +(*s Type of a de Bruijn index. *) + +let judge_of_relative env n = + try + let (_,_,typ) = lookup_rel n env in + lift n typ + with Not_found -> + error_unbound_rel env n + +(* Type of variables *) +let judge_of_variable env id = + try named_type id env + with Not_found -> + error_unbound_var env id + +(* Management of context of variables. *) + +(* Checks if a context of variables can be instantiated by the + variables of the current env *) +(* TODO: check order? *) +let check_hyps_inclusion env f c sign = + Context.fold_named_context + (fun (id,_,ty1) () -> + try + let ty2 = named_type id env in + if not (eq_constr ty2 ty1) then raise Exit + with Not_found | Exit -> + error_reference_variables env id (f c)) + sign + ~init:() + +(* Instantiation of terms on real arguments. *) + +(* Make a type polymorphic if an arity *) + +(* Type of constants *) + +let type_of_constant env cst = constant_type env cst +let type_of_constant_in env cst = constant_type_in env cst +let type_of_constant_knowing_parameters env t _ = t + +let judge_of_constant env (kn,u as cst) = + let cb = lookup_constant kn env in + let () = check_hyps_inclusion env mkConstU cst cb.const_hyps in + let ty, cu = type_of_constant env cst in + let () = check_constraints cu env in + ty + +let type_of_projection env (cst,u) = + let cb = lookup_constant cst env in + match cb.const_proj with + | Some pb -> + if cb.const_polymorphic then + let mib,_ = lookup_mind_specif env (pb.proj_ind,0) in + let subst = make_inductive_subst mib u in + Vars.subst_univs_constr subst pb.proj_type + else pb.proj_type + | None -> raise (Invalid_argument "type_of_projection: not a projection") + + +(* Type of a lambda-abstraction. *) + +(* [judge_of_abstraction env name var j] implements the rule + + env, name:typ |- j.uj_val:j.uj_type env, |- (name:typ)j.uj_type : s + ----------------------------------------------------------------------- + env |- [name:typ]j.uj_val : (name:typ)j.uj_type + + Since all products are defined in the Calculus of Inductive Constructions + and no upper constraint exists on the sort $s$, we don't need to compute $s$ +*) + +let judge_of_abstraction env name var ty = + mkProd (name, var, ty) + +(* Type of let-in. *) + +let judge_of_letin env name defj typj j = + subst1 defj j + +(* Type of an application. *) + +let make_judgev c t = + Array.map2 make_judge c t + +let judge_of_apply env func funt argsv argstv = + let len = Array.length argsv in + let rec apply_rec i typ = + if Int.equal i len then typ + else + (match kind_of_term (whd_betadeltaiota env typ) with + | Prod (_,c1,c2) -> + let arg = argsv.(i) and argt = argstv.(i) in + (try + let () = conv_leq false env argt c1 in + apply_rec (i+1) (subst1 arg c2) + with NotConvertible -> + error_cant_apply_bad_type env + (i+1,c1,argt) + (make_judge func funt) + (make_judgev argsv argstv)) + + | _ -> + error_cant_apply_not_functional env + (make_judge func funt) + (make_judgev argsv argstv)) + in apply_rec 0 funt + +(* Type of product *) + +let sort_of_product env domsort rangsort = + match (domsort, rangsort) with + (* Product rule (s,Prop,Prop) *) + | (_, Prop Null) -> rangsort + (* Product rule (Prop/Set,Set,Set) *) + | (Prop _, Prop Pos) -> rangsort + (* Product rule (Type,Set,?) *) + | (Type u1, Prop Pos) -> + begin match engagement env with + | Some ImpredicativeSet -> + (* Rule is (Type,Set,Set) in the Set-impredicative calculus *) + rangsort + | _ -> + (* Rule is (Type_i,Set,Type_i) in the Set-predicative calculus *) + Type (Universe.sup Universe.type0 u1) + end + (* Product rule (Prop,Type_i,Type_i) *) + | (Prop Pos, Type u2) -> Type (Universe.sup Universe.type0 u2) + (* Product rule (Prop,Type_i,Type_i) *) + | (Prop Null, Type _) -> rangsort + (* Product rule (Type_i,Type_i,Type_i) *) + | (Type u1, Type u2) -> Type (Universe.sup u1 u2) + +(* [judge_of_product env name (typ1,s1) (typ2,s2)] implements the rule + + env |- typ1:s1 env, name:typ1 |- typ2 : s2 + ------------------------------------------------------------------------- + s' >= (s1,s2), env |- (name:typ)j.uj_val : s' + + where j.uj_type is convertible to a sort s2 +*) +let judge_of_product env name s1 s2 = + let s = sort_of_product env s1 s2 in + mkSort s + +(* Type of a type cast *) + +(* [judge_of_cast env (c,typ1) (typ2,s)] implements the rule + + env |- c:typ1 env |- typ2:s env |- typ1 <= typ2 + --------------------------------------------------------------------- + env |- c:typ2 +*) + +let judge_of_cast env c ct k expected_type = + try + match k with + | VMcast -> + vm_conv CUMUL env ct expected_type + | DEFAULTcast -> + default_conv ~l2r:false CUMUL env ct expected_type + | REVERTcast -> + default_conv ~l2r:true CUMUL env ct expected_type + | NATIVEcast -> + let sigma = Nativelambda.empty_evars in + native_conv CUMUL sigma env ct expected_type + with NotConvertible -> + error_actual_type env (make_judge c ct) expected_type + +(* Inductive types. *) + +(* The type is parametric over the uniform parameters whose conclusion + is in Type; to enforce the internal constraints between the + parameters and the instances of Type occurring in the type of the + constructors, we use the level variables _statically_ assigned to + the conclusions of the parameters as mediators: e.g. if a parameter + has conclusion Type(alpha), static constraints of the form alpha<=v + exist between alpha and the Type's occurring in the constructor + types; when the parameters is finally instantiated by a term of + conclusion Type(u), then the constraints u<=alpha is computed in + the App case of execute; from this constraints, the expected + dynamic constraints of the form u<=v are enforced *) + +(* let judge_of_inductive_knowing_parameters env ind jl = *) +(* let c = mkInd ind in *) +(* let (mib,mip) = lookup_mind_specif env ind in *) +(* check_args env c mib.mind_hyps; *) +(* let paramstyp = Array.map (fun j -> j.uj_type) jl in *) +(* let t = in *) +(* make_judge c t *) + +let judge_of_inductive env (ind,u as indu) = + let (mib,mip) = lookup_mind_specif env ind in + check_hyps_inclusion env mkIndU indu mib.mind_hyps; + let t,cst = Inductive.constrained_type_of_inductive env ((mib,mip),u) in + check_constraints cst env; + t + +(* Constructors. *) + +let judge_of_constructor env (c,u as cu) = + let _ = + let ((kn,_),_) = c in + let mib = lookup_mind kn env in + check_hyps_inclusion env mkConstructU cu mib.mind_hyps in + let specif = lookup_mind_specif env (inductive_of_constructor c) in + let t,cst = constrained_type_of_constructor cu specif in + let () = check_constraints cst env in + t + +(* Case. *) + +let check_branch_types env (ind,u) c ct lft explft = + try conv_leq_vecti env lft explft + with + NotConvertibleVect i -> + error_ill_formed_branch env c ((ind,i+1),u) lft.(i) explft.(i) + | Invalid_argument _ -> + error_number_branches env (make_judge c ct) (Array.length explft) + +let judge_of_case env ci p pt c ct lf lft = + let (pind, _ as indspec) = + try find_rectype env ct + with Not_found -> error_case_not_inductive env (make_judge c ct) in + let _ = check_case_info env pind ci in + let (bty,rslty) = + type_case_branches env indspec (make_judge p pt) c in + let () = check_branch_types env pind c ct lft bty in + rslty + +let judge_of_projection env p c ct = + let pb = lookup_projection p env in + let (ind,u), args = + try find_rectype env ct + with Not_found -> error_case_not_inductive env (make_judge c ct) + in + assert(eq_mind pb.proj_ind (fst ind)); + let usubst = make_inductive_subst (fst (lookup_mind_specif env ind)) u in + let ty = Vars.subst_univs_constr usubst pb.Declarations.proj_type in + substl (c :: List.rev args) ty + + +(* Fixpoints. *) + +(* Checks the type of a general (co)fixpoint, i.e. without checking *) +(* the specific guard condition. *) + +let type_fixpoint env lna lar vdef vdeft = + let lt = Array.length vdeft in + assert (Int.equal (Array.length lar) lt); + try + conv_leq_vecti env vdeft (Array.map (fun ty -> lift lt ty) lar) + with NotConvertibleVect i -> + error_ill_typed_rec_body env i lna (make_judgev vdef vdeft) lar + +(************************************************************************) +(************************************************************************) + +(* The typing machine. *) + (* ATTENTION : faudra faire le typage du contexte des Const, + Ind et Constructsi un jour cela devient des constructions + arbitraires et non plus des variables *) +let rec execute env cstr = + match kind_of_term cstr with + (* Atomic terms *) + | Sort (Prop c) -> + judge_of_prop_contents c + + | Sort (Type u) -> + judge_of_type u + + | Rel n -> + judge_of_relative env n + + | Var id -> + judge_of_variable env id + + | Const c -> + judge_of_constant env c + + | Proj (p, c) -> + let ct = execute env c in + judge_of_projection env p c ct + + (* Lambda calculus operators *) + | App (f,args) -> + let argst = execute_array env args in + let ft = execute env f in + judge_of_apply env f ft args argst + + | Lambda (name,c1,c2) -> + let _ = execute_is_type env c1 in + let env1 = push_rel (name,None,c1) env in + let c2t = execute env1 c2 in + judge_of_abstraction env name c1 c2t + + | Prod (name,c1,c2) -> + let vars = execute_is_type env c1 in + let env1 = push_rel (name,None,c1) env in + let vars' = execute_is_type env1 c2 in + judge_of_product env name vars vars' + + | LetIn (name,c1,c2,c3) -> + let c1t = execute env c1 in + let _c2s = execute_is_type env c2 in + let _ = judge_of_cast env c1 c1t DEFAULTcast c2 in + let env1 = push_rel (name,Some c1,c2) env in + let c3t = execute env1 c3 in + subst1 c1 c3t + + | Cast (c,k,t) -> + let ct = execute env c in + let _ts = execute_type env t in + let _ = judge_of_cast env c ct k t in + t + + (* Inductive types *) + | Ind ind -> + judge_of_inductive env ind + + | Construct c -> + judge_of_constructor env c + + | Case (ci,p,c,lf) -> + let ct = execute env c in + let pt = execute env p in + let lft = execute_array env lf in + judge_of_case env ci p pt c ct lf lft + + | Fix ((vn,i as vni),recdef) -> + let (fix_ty,recdef') = execute_recdef env recdef i in + let fix = (vni,recdef') in + check_fix env fix; fix_ty + + | CoFix (i,recdef) -> + let (fix_ty,recdef') = execute_recdef env recdef i in + let cofix = (i,recdef') in + check_cofix env cofix; fix_ty + + (* Partial proofs: unsupported by the kernel *) + | Meta _ -> + anomaly (Pp.str "the kernel does not support metavariables") + + | Evar _ -> + anomaly (Pp.str "the kernel does not support existential variables") + +and execute_is_type env constr = + let t = execute env constr in + check_type env constr t + +and execute_type env constr = + let t = execute env constr in + type_judgment env constr t + +and execute_recdef env (names,lar,vdef) i = + let lart = execute_array env lar in + let lara = Array.map2 (assumption_of_judgment env) lar lart in + let env1 = push_rec_types (names,lara,vdef) env in + let vdeft = execute_array env1 vdef in + let () = type_fixpoint env1 names lara vdef vdeft in + (lara.(i),(names,lara,vdef)) + +and execute_array env = Array.map (execute env) + +(* Derived functions *) +let infer env constr = + let t = execute env constr in + make_judge constr t + +(* let infer_key = Profile.declare_profile "Fast_infer" *) +(* let infer = Profile.profile2 infer_key infer *) + +let infer_type env constr = + execute_type env constr + +let infer_v env cv = + let jv = execute_array env cv in + make_judgev cv jv + +(* Typing of several terms. *) + +let infer_local_decl env id = function + | LocalDef c -> + let t = execute env c in + (Name id, Some c, t) + | LocalAssum c -> + let t = execute env c in + (Name id, None, assumption_of_judgment env c t) + +let infer_local_decls env decls = + let rec inferec env = function + | (id, d) :: l -> + let (env, l) = inferec env l in + let d = infer_local_decl env id d in + (push_rel d env, add_rel_decl d l) + | [] -> (env, empty_rel_context) in + inferec env decls + +(* Exported typing functions *) + +let typing env c = infer env c diff --git a/kernel/fast_typeops.mli b/kernel/fast_typeops.mli new file mode 100644 index 000000000..7ff5577cb --- /dev/null +++ b/kernel/fast_typeops.mli @@ -0,0 +1,28 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Names +open Univ +open Term +open Context +open Environ +open Entries +open Declarations + +(** {6 Typing functions (not yet tagged as safe) } + + They return unsafe judgments that are "in context" of a set of + (local) universe variables (the ones that appear in the term) + and associated constraints. In case of polymorphic definitions, + these variables and constraints will be generalized. + *) + + +val infer : env -> constr -> unsafe_judgment +val infer_v : env -> constr array -> unsafe_judgment array +val infer_type : env -> types -> unsafe_type_judgment diff --git a/kernel/indtypes.ml b/kernel/indtypes.ml index 2defb66f4..0ac6a4e4a 100644 --- a/kernel/indtypes.ml +++ b/kernel/indtypes.ml @@ -20,6 +20,15 @@ open Environ open Reduction open Typeops open Entries +open Pp + +(* Tell if indices (aka real arguments) contribute to size of inductive type *) +(* If yes, this is compatible with the univalent model *) + +let indices_matter = ref false + +let enforce_indices_matter () = indices_matter := true +let is_indices_matter () = !indices_matter (* Same as noccur_between but may perform reductions. Could be refined more... *) @@ -107,26 +116,22 @@ let is_logic_constr infos = List.for_all (fun (logic,small) -> logic) infos *) let is_unit constrsinfos = match constrsinfos with (* One info = One constructor *) - | [constrinfos] -> is_logic_constr constrinfos + | [level] -> is_type0m_univ level | [] -> (* type without constructors *) true | _ -> false -let rec infos_and_sort env t = - let t = whd_betadeltaiota env t in - match kind_of_term t with - | Prod (name,c1,c2) -> - let (varj,_) = infer_type env c1 in +let infos_and_sort env ctx t = + let rec aux env ctx t max = + let t = whd_betadeltaiota env t in + match kind_of_term t with + | Prod (name,c1,c2) -> + let varj = infer_type env c1 in let env1 = Environ.push_rel (name,None,varj.utj_val) env in - let logic = is_logic_type varj in - let small = Term.is_small varj.utj_type in - (logic,small) :: (infos_and_sort env1 c2) - | _ when is_constructor_head t -> [] - | _ -> (* don't fail if not positive, it is tested later *) [] - -let small_unit constrsinfos = - let issmall = List.for_all is_small constrsinfos - and isunit = is_unit constrsinfos in - issmall, isunit + let max = Universe.sup max (univ_of_sort varj.utj_type) in + aux env1 ctx c2 max + | _ when is_constructor_head t -> max + | _ -> (* don't fail if not positive, it is tested later *) max + in aux env ctx t Universe.type0m (* Computing the levels of polymorphic inductive types @@ -148,40 +153,52 @@ let small_unit constrsinfos = w1,w2,w3 <= u3 *) -let extract_level (_,_,_,lc,lev) = +let extract_level (_,_,lc,(_,lev)) = (* Enforce that the level is not in Prop if more than one constructor *) - if Array.length lc >= 2 then sup type0_univ lev else lev + (* if Array.length lc >= 2 then sup type0_univ lev else lev *) + lev let inductive_levels arities inds = - let levels = Array.map pi3 arities in let cstrs_levels = Array.map extract_level inds in (* Take the transitive closure of the system of constructors *) (* level constraints and remove the recursive dependencies *) - solve_constraints_system levels cstrs_levels + cstrs_levels (* This (re)computes informations relevant to extraction and the sort of an arity or type constructor; we do not to recompute universes constraints *) -let constraint_list_union = - List.fold_left union_constraints empty_constraint +let context_set_list_union = + List.fold_left ContextSet.union ContextSet.empty -let infer_constructor_packet env_ar_par params lc = +let infer_constructor_packet env_ar_par ctx params lc = (* type-check the constructors *) - let jlc,cstl = List.split (List.map (infer_type env_ar_par) lc) in - let cst = constraint_list_union cstl in + let jlc = List.map (infer_type env_ar_par) lc in let jlc = Array.of_list jlc in (* generalize the constructor over the parameters *) let lc'' = Array.map (fun j -> it_mkProd_or_LetIn j.utj_val params) jlc in - (* compute the max of the sorts of the products of the constructor type *) - let level = max_inductive_sort (Array.map (fun j -> j.utj_type) jlc) in - (* compute *) - let info = small_unit (List.map (infos_and_sort env_ar_par) lc) in - - (info,lc'',level,cst) + (* compute the max of the sorts of the products of the constructors types *) + let levels = List.map (infos_and_sort env_ar_par ctx) lc in + let level = List.fold_left (fun max l -> Universe.sup max l) Universe.type0m levels in + (lc'',(is_unit levels,level)) + +(* If indices matter *) +let cumulate_arity_large_levels env sign = + fst (List.fold_right + (fun (_,_,t as d) (lev,env) -> + let tj = infer_type env t in + let u = univ_of_sort tj.utj_type in + (Universe.sup u lev, push_rel d env)) + sign (Universe.type0m,env)) + +let is_impredicative env u = + is_type0m_univ u || (is_type0_univ u && engagement env = Some ImpredicativeSet) (* Type-check an inductive definition. Does not check positivity conditions. *) -let typecheck_inductive env mie = +(* TODO check that we don't overgeneralize construcors/inductive arities with + universes that are absent from them. Is it possible? +*) +let typecheck_inductive env ctx mie = let () = match mie.mind_entry_inds with | [] -> anomaly (Pp.str "empty inductive types declaration") | _ -> () @@ -189,116 +206,103 @@ let typecheck_inductive env mie = (* Check unicity of names *) mind_check_names mie; (* Params are typed-checked here *) - let env_params, params, cst1 = infer_local_decls env mie.mind_entry_params in + let env' = push_context ctx env in + let (env_params, params) = infer_local_decls env' mie.mind_entry_params in (* We first type arity of each inductive definition *) (* This allows to build the environment of arities and to share *) (* the set of constraints *) - let cst, env_arities, rev_arity_list = + let env_arities, rev_arity_list = List.fold_left - (fun (cst,env_ar,l) ind -> + (fun (env_ar,l) ind -> (* Arities (without params) are typed-checked here *) - let arity, cst2 = infer_type env_params ind.mind_entry_arity in + let arity = + if isArity ind.mind_entry_arity then + let (ctx,s) = destArity ind.mind_entry_arity in + match s with + | Type u when Univ.universe_level u = None -> + (** We have an algebraic universe as the conclusion of the arity, + typecheck the dummy Π ctx, Prop and do a special case for the conclusion. + *) + let proparity = infer_type env_params (mkArity (ctx, prop_sort)) in + let (cctx, _) = destArity proparity.utj_val in + (* Any universe is well-formed, we don't need to check [s] here *) + mkArity (cctx, s) + | _ -> let arity = infer_type env_params ind.mind_entry_arity in + arity.utj_val + else let arity = infer_type env_params ind.mind_entry_arity in + arity.utj_val + in + let (sign, deflev) = dest_arity env_params arity in + let inflev = + (* The level of the inductive includes levels of indices if + in indices_matter mode *) + if !indices_matter + then Some (cumulate_arity_large_levels env_params sign) + else None + in (* We do not need to generate the universe of full_arity; if later, after the validation of the inductive definition, full_arity is used as argument or subject to cast, an upper universe will be generated *) - let full_arity = it_mkProd_or_LetIn arity.utj_val params in - let cst = union_constraints cst cst2 in + let full_arity = it_mkProd_or_LetIn arity params in let id = ind.mind_entry_typename in let env_ar' = - push_rel (Name id, None, full_arity) - (add_constraints cst2 env_ar) in - let lev = - (* Decide that if the conclusion is not explicitly Type *) - (* then the inductive type is not polymorphic *) - match kind_of_term ((strip_prod_assum arity.utj_val)) with - | Sort (Type u) -> Some u - | _ -> None in - (cst,env_ar',(id,full_arity,lev)::l)) - (cst1,env,[]) + push_rel (Name id, None, full_arity) env_ar in + (* (add_constraints cst2 env_ar) in *) + (env_ar', (id,full_arity,sign @ params,deflev,inflev)::l)) + (env',[]) mie.mind_entry_inds in let arity_list = List.rev rev_arity_list in (* builds the typing context "Gamma, I1:A1, ... In:An, params" *) - let env_ar_par = - push_rel_context params (add_constraints cst1 env_arities) in + let env_ar_par = push_rel_context params env_arities in (* Now, we type the constructors (without params) *) - let inds,cst = + let inds = List.fold_right2 - (fun ind arity_data (inds,cst) -> - let (info,lc',cstrs_univ,cst') = - infer_constructor_packet env_ar_par params ind.mind_entry_lc in + (fun ind arity_data inds -> + let (lc',cstrs_univ) = + infer_constructor_packet env_ar_par ContextSet.empty + params ind.mind_entry_lc in let consnames = ind.mind_entry_consnames in - let ind' = (arity_data,consnames,info,lc',cstrs_univ) in - (ind'::inds, union_constraints cst cst')) + let ind' = (arity_data,consnames,lc',cstrs_univ) in + ind'::inds) mie.mind_entry_inds arity_list - ([],cst) in + ([]) in let inds = Array.of_list inds in - let arities = Array.of_list arity_list in - let has_some_univ u = function - | Some v when Universe.equal u v -> true - | _ -> false - in - let remove_some_univ u = function - | Some v when Universe.equal u v -> None - | x -> x - in - let fold l (_, b, p) = match b with - | None -> - (* Parameter contributes to polymorphism only if explicit Type *) - let c = strip_prod_assum p in - (* Add Type levels to the ordered list of parameters contributing to *) - (* polymorphism unless there is aliasing (i.e. non distinct levels) *) - begin match kind_of_term c with - | Sort (Type u) -> - if List.exists (has_some_univ u) l then - None :: List.map (remove_some_univ u) l - else - Some u :: l - | _ -> - None :: l - end - | _ -> l - in - let param_ccls = List.fold_left fold [] params in (* Compute/check the sorts of the inductive types *) - let ind_min_levels = inductive_levels arities inds in - let inds, cst = - Array.fold_map2' (fun ((id,full_arity,ar_level),cn,info,lc,_) lev cst -> - let sign, s = - try dest_arity env full_arity - with NotArity -> raise (InductiveError (NotAnArity (env, full_arity))) + + let inds = + Array.map (fun ((id,full_arity,sign,def_level,inf_level),cn,lc,(is_unit,clev)) -> + let defu = Term.univ_of_sort def_level in + let infu = + (** Inferred level, with parameters and constructors. *) + match inf_level with + | Some alev -> Universe.sup clev alev + | None -> clev + in + let is_natural = + check_leq (universes env') infu defu && + not (is_type0m_univ defu && not is_unit) in - let status,cst = match s with - | Type u when ar_level != None (* Explicitly polymorphic *) - && no_upper_constraints u cst -> - (* The polymorphic level is a function of the level of the *) - (* conclusions of the parameters *) - (* We enforce [u >= lev] in case [lev] has a strict upper *) - (* constraints over [u] *) - Inr (param_ccls, lev), enforce_leq lev u cst - | Type u (* Not an explicit occurrence of Type *) -> - Inl (info,full_arity,s), enforce_leq lev u cst - | Prop Pos when - begin match engagement env with - | Some ImpredicativeSet -> false - | _ -> true - end -> - (* Predicative set: check that the content is indeed predicative *) - if not (is_type0m_univ lev) && not (is_type0_univ lev) then - raise (InductiveError LargeNonPropInductiveNotInType); - Inl (info,full_arity,s), cst - | Prop _ -> - Inl (info,full_arity,s), cst in - (id,cn,lc,(sign,status)),cst) - inds ind_min_levels cst in - - (env_arities, params, inds, cst) + let _ = + (** Impredicative sort, always allow *) + if is_impredicative env defu then () + else (** Predicative case: the inferred level must be lower or equal to the + declared level. *) + if not is_natural then + anomaly ~label:"check_inductive" + (Pp.str"Incorrect universe " ++ + Universe.pr defu ++ Pp.str " declared for inductive type, inferred level is " + ++ Universe.pr infu) + in + (id,cn,lc,(sign,(not is_natural,full_arity,defu)))) + inds + in (env_arities, params, inds) (************************************************************************) (************************************************************************) @@ -387,7 +391,7 @@ if Int.equal nmr 0 then 0 else in find 0 (n-1) (lpar,List.rev hyps) let lambda_implicit_lift n a = - let level = UniverseLevel.make (DirPath.make [Id.of_string "implicit"]) 0 in + let level = Level.make (DirPath.make [Id.of_string "implicit"]) 0 in let implicit_sort = mkType (Universe.make level) in let lambda_implicit a = mkLambda (Anonymous, implicit_sort, a) in iterate lambda_implicit n (lift n a) @@ -413,12 +417,13 @@ let abstract_mind_lc env ntyps npars lc = let ienv_push_var (env, n, ntypes, lra) (x,a,ra) = (push_rel (x,None,a) env, n+1, ntypes, (Norec,ra)::lra) -let ienv_push_inductive (env, n, ntypes, ra_env) (mi,lpar) = +let ienv_push_inductive (env, n, ntypes, ra_env) ((mi,u),lpar) = let auxntyp = 1 in - let specif = lookup_mind_specif env mi in + let specif = (lookup_mind_specif env mi, u) in + let ty = type_of_inductive env specif in let env' = push_rel (Anonymous,None, - hnf_prod_applist env (type_of_inductive env specif) lpar) env in + hnf_prod_applist env ty lpar) env in let ra_env' = (Imbr mi,(Rtree.mk_rec_calls 1).(0)) :: List.map (fun (r,t) -> (r,Rtree.lift 1 t)) ra_env in @@ -476,7 +481,7 @@ let check_positivity_one (env,_,ntypes,_ as ienv) hyps (_,i as ind) nargs lcname else failwith_non_pos_list n ntypes (x::largs) (* accesses to the environment are not factorised, but is it worth? *) - and check_positive_nested (env,n,ntypes,ra_env as ienv) nmr (mi, largs) = + and check_positive_nested (env,n,ntypes,ra_env as ienv) nmr ((mi,u), largs) = let (mib,mip) = lookup_mind_specif env mi in let auxnpar = mib.mind_nparams_rec in let nonrecpar = mib.mind_nparams - auxnpar in @@ -495,7 +500,7 @@ let check_positivity_one (env,_,ntypes,_ as ienv) hyps (_,i as ind) nargs lcname let auxlcvect = abstract_mind_lc env auxntyp auxnpar mip.mind_nf_lc in (* Extends the environment with a variable corresponding to the inductive def *) - let (env',_,_,_ as ienv') = ienv_push_inductive ienv (mi,lpar) in + let (env',_,_,_ as ienv') = ienv_push_inductive ienv ((mi,u),lpar) in (* Parameters expressed in env' *) let lpar' = List.map (lift auxntyp) lpar in let irecargs_nmr = @@ -586,40 +591,72 @@ let all_sorts = [InProp;InSet;InType] let small_sorts = [InProp;InSet] let logical_sorts = [InProp] -let allowed_sorts issmall isunit s = - match family_of_sort s with - (* Type: all elimination allowed *) - | InType -> all_sorts - - (* Small Set is predicative: all elimination allowed *) - | InSet when issmall -> all_sorts - - (* Large Set is necessarily impredicative: forbids large elimination *) - | InSet -> small_sorts - - (* Unitary/empty Prop: elimination to all sorts are realizable *) - (* unless the type is large. If it is large, forbids large elimination *) - (* which otherwise allows to simulate the inconsistent system Type:Type *) - | InProp when isunit -> if issmall then all_sorts else small_sorts - - (* Other propositions: elimination only to Prop *) - | InProp -> logical_sorts +let allowed_sorts is_smashed s = + if not is_smashed + then (** Naturally in the defined sort. + If [s] is Prop, it must be small and unitary. + Unsmashed, predicative Type and Set: all elimination allowed + as well. *) + all_sorts + else + match family_of_sort s with + (* Type: all elimination allowed: above and below *) + | InType -> all_sorts + (* Smashed Set is necessarily impredicative: forbids large elimination *) + | InSet -> small_sorts + (* Smashed to Prop, no informative eliminations allowed *) + | InProp -> logical_sorts + +(* Previous comment: *) +(* Unitary/empty Prop: elimination to all sorts are realizable *) +(* unless the type is large. If it is large, forbids large elimination *) +(* which otherwise allows to simulate the inconsistent system Type:Type. *) +(* -> this is now handled by is_smashed: *) +(* - all_sorts in case of small, unitary Prop (not smashed) *) +(* - logical_sorts in case of large, unitary Prop (smashed) *) let fold_inductive_blocks f = - let concl = function - | Inr _ -> mkSet (* dummy *) - | Inl (_,ar,_) -> ar - in - Array.fold_left (fun acc (_,_,lc,(arsign,ar)) -> - f (Array.fold_left f acc lc) (it_mkProd_or_LetIn (concl ar) arsign)) + Array.fold_left (fun acc (_,_,lc,(arsign,ar)) -> + f (Array.fold_left f acc lc) (it_mkProd_or_LetIn (pi2 ar) arsign)) let used_section_variables env inds = let ids = fold_inductive_blocks (fun l c -> Id.Set.union (Environ.global_vars_set env c) l) Id.Set.empty inds in keep_hyps env ids - -let build_inductive env env_ar params isrecord isfinite inds nmr recargs cst = +let lift_decl n d = + map_rel_declaration (lift n) d + +let rel_vect n m = Array.init m (fun i -> mkRel(n+m-i)) +let rel_list n m = Array.to_list (rel_vect n m) +let rel_appvect n m = rel_vect n (List.length m) + +exception UndefinableExpansion + +(** From a rel context describing the constructor arguments, + build an expansion function. + The term built is expecting to be substituted first by + a substitution of the form [params, x : ind params] *) +let compute_expansion ((kn, _ as ind), u) params ctx = + let mp, dp, l = repr_mind kn in + let make_proj id = Constant.make1 (KerName.make mp dp (Label.of_id id)) in + let rec projections acc (na, b, t) = + match b with + | Some c -> acc + | None -> + match na with + | Name id -> make_proj id :: acc + | Anonymous -> raise UndefinableExpansion + in + let projs = List.fold_left projections [] ctx in + let projarr = Array.of_list projs in + let exp = + mkApp (mkConstructU ((ind, 1),u), + Array.append (rel_appvect 1 params) + (Array.map (fun p -> mkProj (p, mkRel 1)) projarr)) + in exp, projarr + +let build_inductive env p ctx env_ar params kn isrecord isfinite inds nmr recargs = let ntypes = Array.length inds in (* Compute the set of used section variables *) let hyps = used_section_variables env inds in @@ -637,18 +674,13 @@ let build_inductive env env_ar params isrecord isfinite inds nmr recargs cst = Array.map (fun (d,_) -> rel_context_nhyps d - rel_context_nhyps params) splayed_lc in (* Elimination sorts *) - let arkind,kelim = match ar_kind with - | Inr (param_levels,lev) -> - Polymorphic { - poly_param_levels = param_levels; - poly_level = lev; - }, all_sorts - | Inl ((issmall,isunit),ar,s) -> - let kelim = allowed_sorts issmall isunit s in - Monomorphic { - mind_user_arity = ar; - mind_sort = s; - }, kelim in + let arkind,kelim = + let (info,ar,defs) = ar_kind in + let s = sort_of_univ defs in + let kelim = allowed_sorts info s in + { mind_user_arity = ar; + mind_sort = s; + }, kelim in (* Assigning VM tags to constructors *) let nconst, nblock = ref 0, ref 0 in let transf num = @@ -681,6 +713,19 @@ let build_inductive env env_ar params isrecord isfinite inds nmr recargs cst = mind_reloc_tbl = rtbl; } in let packets = Array.map2 build_one_packet inds recargs in + let isrecord = + let pkt = packets.(0) in + if isrecord (* || (Array.length pkt.mind_consnames = 1 && *) + (* inductive_sort_family pkt <> InProp) *) then + let rctx, _ = decompose_prod_assum pkt.mind_nf_lc.(0) in + let u = if p then Univ.UContext.instance ctx else Univ.Instance.empty in + try + let exp = compute_expansion ((kn, 0), u) params + (List.firstn pkt.mind_consnrealdecls.(0) rctx) + in Some exp + with UndefinableExpansion -> None + else None + in (* Build the mutual inductive *) { mind_record = isrecord; mind_ntypes = ntypes; @@ -690,7 +735,8 @@ let build_inductive env env_ar params isrecord isfinite inds nmr recargs cst = mind_nparams_rec = nmr; mind_params_ctxt = params; mind_packets = packets; - mind_constraints = cst + mind_polymorphic = p; + mind_universes = ctx; } (************************************************************************) @@ -698,9 +744,14 @@ let build_inductive env env_ar params isrecord isfinite inds nmr recargs cst = let check_inductive env kn mie = (* First type-check the inductive definition *) - let (env_ar, params, inds, cst) = typecheck_inductive env mie in + let env = push_context mie.mind_entry_universes env in + let (env_ar, params, inds) = + typecheck_inductive env mie.mind_entry_universes mie + in (* Then check positivity conditions *) let (nmr,recargs) = check_positivity kn env_ar params inds in (* Build the inductive packets *) - build_inductive env env_ar params mie.mind_entry_record mie.mind_entry_finite - inds nmr recargs cst + build_inductive env mie.mind_entry_polymorphic + mie.mind_entry_universes + env_ar params kn mie.mind_entry_record mie.mind_entry_finite + inds nmr recargs diff --git a/kernel/indtypes.mli b/kernel/indtypes.mli index 016a1a5b5..8730a3045 100644 --- a/kernel/indtypes.mli +++ b/kernel/indtypes.mli @@ -34,5 +34,12 @@ exception InductiveError of inductive_error (** The following function does checks on inductive declarations. *) -val check_inductive : - env -> mutual_inductive -> mutual_inductive_entry -> mutual_inductive_body +val check_inductive : env -> mutual_inductive -> mutual_inductive_entry -> mutual_inductive_body + +(** The following enforces a system compatible with the univalent model *) + +val enforce_indices_matter : unit -> unit +val is_indices_matter : unit -> bool + +val compute_expansion : pinductive -> + Context.rel_context -> Context.rel_context -> (constr * constant array) diff --git a/kernel/inductive.ml b/kernel/inductive.ml index 2b2caaf3b..e57b0b4ad 100644 --- a/kernel/inductive.ml +++ b/kernel/inductive.ml @@ -19,6 +19,9 @@ open Environ open Reduction open Type_errors +type pinductive = inductive puniverses +type pconstructor = constructor puniverses + type mind_specif = mutual_inductive_body * one_inductive_body (* raise Not_found if not an inductive type *) @@ -38,31 +41,55 @@ let find_inductive env c = let (t, l) = decompose_app (whd_betadeltaiota env c) in match kind_of_term t with | Ind ind - when (fst (lookup_mind_specif env ind)).mind_finite -> (ind, l) + when (fst (lookup_mind_specif env (out_punivs ind))).mind_finite -> (ind, l) | _ -> raise Not_found let find_coinductive env c = let (t, l) = decompose_app (whd_betadeltaiota env c) in match kind_of_term t with | Ind ind - when not (fst (lookup_mind_specif env ind)).mind_finite -> (ind, l) + when not (fst (lookup_mind_specif env (out_punivs ind))).mind_finite -> (ind, l) | _ -> raise Not_found let inductive_params (mib,_) = mib.mind_nparams +let make_inductive_subst mib u = + if mib.mind_polymorphic then + make_universe_subst u mib.mind_universes + else Univ.empty_subst + +let inductive_params_ctxt (mib,u) = + let subst = make_inductive_subst mib u in + Vars.subst_univs_context subst mib.mind_params_ctxt + +let inductive_instance mib = + if mib.mind_polymorphic then + UContext.instance mib.mind_universes + else Instance.empty + +let inductive_context mib = + if mib.mind_polymorphic then + mib.mind_universes + else UContext.empty + +let instantiate_inductive_constraints mib subst = + if mib.mind_polymorphic then + instantiate_univ_context subst mib.mind_universes + else Constraint.empty + (************************************************************************) (* Build the substitution that replaces Rels by the appropriate *) (* inductives *) -let ind_subst mind mib = +let ind_subst mind mib u = let ntypes = mib.mind_ntypes in - let make_Ik k = mkInd (mind,ntypes-k-1) in + let make_Ik k = mkIndU ((mind,ntypes-k-1),u) in List.init ntypes make_Ik (* Instantiate inductives in constructor type *) -let constructor_instantiate mind mib c = - let s = ind_subst mind mib in - substl s c +let constructor_instantiate mind u subst mib c = + let s = ind_subst mind mib u in + substl s (subst_univs_constr subst c) let instantiate_params full t args sign = let fail () = @@ -81,13 +108,16 @@ let instantiate_params full t args sign = let () = if not (List.is_empty rem_args) then fail () in substl subs ty -let full_inductive_instantiate mib params sign = +let full_inductive_instantiate mib u params sign = let dummy = prop_sort in let t = mkArity (sign,dummy) in - fst (destArity (instantiate_params true t params mib.mind_params_ctxt)) + let subst = make_inductive_subst mib u in + let ar = fst (destArity (instantiate_params true t params mib.mind_params_ctxt)) in + Vars.subst_univs_context subst ar -let full_constructor_instantiate ((mind,_),(mib,_),params) = - let inst_ind = constructor_instantiate mind mib in +let full_constructor_instantiate ((mind,_),u,(mib,_),params) = + let subst = make_inductive_subst mib u in + let inst_ind = constructor_instantiate mind u subst mib in (fun t -> instantiate_params true (inst_ind t) params mib.mind_params_ctxt) @@ -119,122 +149,85 @@ Remark: Set (predicative) is encoded as Type(0) let sort_as_univ = function | Type u -> u -| Prop Null -> type0m_univ -| Prop Pos -> type0_univ +| Prop Null -> Universe.type0m +| Prop Pos -> Universe.type0 let cons_subst u su subst = try - (u, sup su (List.assoc_f Universe.equal u subst)) :: - List.remove_assoc_f Universe.equal u subst + (u, Universe.sup su (List.assoc_f Universe.eq u subst)) :: + List.remove_assoc_f Universe.eq u subst with Not_found -> (u, su) :: subst -let actualize_decl_level env lev t = - let sign,s = dest_arity env t in - mkArity (sign,lev) - -let polymorphism_on_non_applied_parameters = false - -(* Bind expected levels of parameters to actual levels *) -(* Propagate the new levels in the signature *) -let rec make_subst env = function - | (_,Some _,_ as t)::sign, exp, args -> - let ctx,subst = make_subst env (sign, exp, args) in - t::ctx, subst - | d::sign, None::exp, args -> - let args = match args with _::args -> args | [] -> [] in - let ctx,subst = make_subst env (sign, exp, args) in - d::ctx, subst - | d::sign, Some u::exp, a::args -> - (* We recover the level of the argument, but we don't change the *) - (* level in the corresponding type in the arity; this level in the *) - (* arity is a global level which, at typing time, will be enforce *) - (* to be greater than the level of the argument; this is probably *) - (* a useless extra constraint *) - let s = sort_as_univ (snd (dest_arity env (Lazy.force a))) in - let ctx,subst = make_subst env (sign, exp, args) in - d::ctx, cons_subst u s subst - | (na,None,t as d)::sign, Some u::exp, [] -> - (* No more argument here: we instantiate the type with a fresh level *) - (* which is first propagated to the corresponding premise in the arity *) - (* (actualize_decl_level), then to the conclusion of the arity (via *) - (* the substitution) *) - let ctx,subst = make_subst env (sign, exp, []) in - if polymorphism_on_non_applied_parameters then - let s = fresh_local_univ () in - let t = actualize_decl_level env (Type s) t in - (na,None,t)::ctx, cons_subst u s subst - else - d::ctx, subst - | sign, [], _ -> - (* Uniform parameters are exhausted *) - sign,[] - | [], _, _ -> - assert false - -let instantiate_universes env ctx ar argsorts = - let args = Array.to_list argsorts in - let ctx,subst = make_subst env (ctx,ar.poly_param_levels,args) in - let level = subst_large_constraints subst ar.poly_level in - ctx, - (* Singleton type not containing types are interpretable in Prop *) - if is_type0m_univ level then prop_sort - (* Non singleton type not containing types are interpretable in Set *) - else if is_type0_univ level then set_sort - (* This is a Type with constraints *) - else Type level - exception SingletonInductiveBecomesProp of Id.t -let type_of_inductive_knowing_parameters ?(polyprop=true) env mip paramtyps = - match mip.mind_arity with - | Monomorphic s -> - s.mind_user_arity - | Polymorphic ar -> - let ctx = List.rev mip.mind_arity_ctxt in - let ctx,s = instantiate_universes env ctx ar paramtyps in - (* The Ocaml extraction cannot handle (yet?) "Prop-polymorphism", i.e. - the situation where a non-Prop singleton inductive becomes Prop - when applied to Prop params *) - if not polyprop && not (is_type0m_univ ar.poly_level) && is_prop_sort s - then raise (SingletonInductiveBecomesProp mip.mind_typename); - mkArity (List.rev ctx,s) - -(* Type of a (non applied) inductive type *) - -let type_of_inductive env (_,mip) = - type_of_inductive_knowing_parameters env mip [||] +(* Type of an inductive type *) + +let type_of_inductive_gen env ((mib,mip),u) = + let subst = make_inductive_subst mib u in + (subst_univs_constr subst mip.mind_arity.mind_user_arity, subst) + +let type_of_inductive env pind = + fst (type_of_inductive_gen env pind) + +let constrained_type_of_inductive env ((mib,mip),u as pind) = + let ty, subst = type_of_inductive_gen env pind in + let cst = instantiate_inductive_constraints mib subst in + (ty, cst) + +let type_of_inductive_knowing_parameters env ?(polyprop=false) mip args = + type_of_inductive env mip (* The max of an array of universes *) let cumulate_constructor_univ u = function | Prop Null -> u - | Prop Pos -> sup type0_univ u - | Type u' -> sup u u' + | Prop Pos -> Universe.sup Universe.type0 u + | Type u' -> Universe.sup u u' let max_inductive_sort = - Array.fold_left cumulate_constructor_univ type0m_univ + Array.fold_left cumulate_constructor_univ Universe.type0m (************************************************************************) (* Type of a constructor *) -let type_of_constructor cstr (mib,mip) = +let type_of_constructor_subst cstr u subst (mib,mip) = let ind = inductive_of_constructor cstr in let specif = mip.mind_user_lc in let i = index_of_constructor cstr in let nconstr = Array.length mip.mind_consnames in if i > nconstr then error "Not enough constructors in the type."; - constructor_instantiate (fst ind) mib specif.(i-1) + let c = constructor_instantiate (fst ind) u subst mib specif.(i-1) in + c + +let type_of_constructor_gen (cstr,u) (mib,mip as mspec) = + let subst = make_inductive_subst mib u in + type_of_constructor_subst cstr u subst mspec, subst -let arities_of_specif kn (mib,mip) = +let type_of_constructor cstru mspec = + fst (type_of_constructor_gen cstru mspec) + +let type_of_constructor_in_ctx cstr (mib,mip as mspec) = + let u = UContext.instance mib.mind_universes in + let c = type_of_constructor_gen (cstr, u) mspec in + (fst c, mib.mind_universes) + +let constrained_type_of_constructor (cstr,u as cstru) (mib,mip as ind) = + let ty, subst = type_of_constructor_gen cstru ind in + let cst = instantiate_inductive_constraints mib subst in + (ty, cst) + +let arities_of_specif (kn,u) (mib,mip) = let specif = mip.mind_nf_lc in - Array.map (constructor_instantiate kn mib) specif + let subst = make_inductive_subst mib u in + Array.map (constructor_instantiate kn u subst mib) specif let arities_of_constructors ind specif = - arities_of_specif (fst ind) specif + arities_of_specif (fst (fst ind), snd ind) specif -let type_of_constructors ind (mib,mip) = +let type_of_constructors (ind,u) (mib,mip) = let specif = mip.mind_user_lc in - Array.map (constructor_instantiate (fst ind) mib) specif + let subst = make_inductive_subst mib u in + Array.map (constructor_instantiate (fst ind) u subst mib) specif (************************************************************************) @@ -255,16 +248,14 @@ let local_rels ctxt = (* Get type of inductive, with parameters instantiated *) let inductive_sort_family mip = - match mip.mind_arity with - | Monomorphic s -> family_of_sort s.mind_sort - | Polymorphic _ -> InType + family_of_sort mip.mind_arity.mind_sort let mind_arity mip = mip.mind_arity_ctxt, inductive_sort_family mip -let get_instantiated_arity (mib,mip) params = +let get_instantiated_arity (ind,u) (mib,mip) params = let sign, s = mind_arity mip in - full_inductive_instantiate mib params sign, s + full_inductive_instantiate mib u params sign, s let elim_sorts (_,mip) = mip.mind_kelim @@ -279,7 +270,7 @@ let extended_rel_list n hyps = let build_dependent_inductive ind (_,mip) params = let realargs,_ = List.chop mip.mind_nrealargs_ctxt mip.mind_arity_ctxt in applist - (mkInd ind, + (mkIndU ind, List.map (lift mip.mind_nrealargs_ctxt) params @ extended_rel_list 0 realargs) @@ -295,15 +286,15 @@ let check_allowed_sort ksort specif = raise (LocalArity (Some(ksort,s,error_elim_explain ksort s))) let is_correct_arity env c pj ind specif params = - let arsign,_ = get_instantiated_arity specif params in - let rec srec env pt ar u = + let arsign,_ = get_instantiated_arity ind specif params in + let rec srec env pt ar = let pt' = whd_betadeltaiota env pt in match kind_of_term pt', ar with | Prod (na1,a1,t), (_,None,a1')::ar' -> - let univ = + let () = try conv env a1 a1' with NotConvertible -> raise (LocalArity None) in - srec (push_rel (na1,None,a1) env) t ar' (union_constraints u univ) + srec (push_rel (na1,None,a1) env) t ar' (* The last Prod domain is the type of the scrutinee *) | Prod (na1,a1,a2), [] -> (* whnf of t was not needed here! *) let env' = push_rel (na1,None,a1) env in @@ -311,17 +302,16 @@ let is_correct_arity env c pj ind specif params = | Sort s -> family_of_sort s | _ -> raise (LocalArity None) in let dep_ind = build_dependent_inductive ind specif params in - let univ = + let _ = try conv env a1 dep_ind with NotConvertible -> raise (LocalArity None) in - check_allowed_sort ksort specif; - union_constraints u univ + check_allowed_sort ksort specif | _, (_,Some _,_ as d)::ar' -> - srec (push_rel d env) (lift 1 pt') ar' u + srec (push_rel d env) (lift 1 pt') ar' | _ -> raise (LocalArity None) in - try srec env pj.uj_type (List.rev arsign) empty_constraint + try srec env pj.uj_type (List.rev arsign) with LocalArity kinds -> error_elim_arity env ind (elim_sorts specif) c pj kinds @@ -331,16 +321,16 @@ let is_correct_arity env c pj ind specif params = (* [p] is the predicate, [i] is the constructor number (starting from 0), and [cty] is the type of the constructor (params not instantiated) *) -let build_branches_type ind (_,mip as specif) params p = +let build_branches_type (ind,u) (_,mip as specif) params p = let build_one_branch i cty = - let typi = full_constructor_instantiate (ind,specif,params) cty in + let typi = full_constructor_instantiate (ind,u,specif,params) cty in let (args,ccl) = decompose_prod_assum typi in let nargs = rel_context_length args in let (_,allargs) = decompose_app ccl in let (lparams,vargs) = List.chop (inductive_params specif) allargs in let cargs = let cstr = ith_constructor_of_inductive ind (i+1) in - let dep_cstr = applist (mkConstruct cstr,lparams@(local_rels args)) in + let dep_cstr = applist (mkConstructU (cstr,u),lparams@(local_rels args)) in vargs @ [dep_cstr] in let base = beta_appvect (lift nargs p) (Array.of_list cargs) in it_mkProd_or_LetIn base args in @@ -348,31 +338,31 @@ let build_branches_type ind (_,mip as specif) params p = (* [p] is the predicate, [c] is the match object, [realargs] is the list of real args of the inductive type *) -let build_case_type n p c realargs = - whd_betaiota (betazeta_appvect (n+1) p (Array.of_list (realargs@[c]))) +let build_case_type env n p c realargs = + whd_betaiota env (betazeta_appvect (n+1) p (Array.of_list (realargs@[c]))) -let type_case_branches env (ind,largs) pj c = - let specif = lookup_mind_specif env ind in +let type_case_branches env (pind,largs) pj c = + let specif = lookup_mind_specif env (fst pind) in let nparams = inductive_params specif in let (params,realargs) = List.chop nparams largs in let p = pj.uj_val in - let univ = is_correct_arity env c pj ind specif params in - let lc = build_branches_type ind specif params p in - let ty = build_case_type (snd specif).mind_nrealargs_ctxt p c realargs in - (lc, ty, univ) + let () = is_correct_arity env c pj pind specif params in + let lc = build_branches_type pind specif params p in + let ty = build_case_type env (snd specif).mind_nrealargs_ctxt p c realargs in + (lc, ty) (************************************************************************) (* Checking the case annotation is relevent *) -let check_case_info env indsp ci = +let check_case_info env (indsp,u) ci = let (mib,mip) = lookup_mind_specif env indsp in if not (eq_ind indsp ci.ci_ind) || not (Int.equal mib.mind_nparams ci.ci_npar) || not (Array.equal Int.equal mip.mind_consnrealdecls ci.ci_cstr_ndecls) || not (Array.equal Int.equal mip.mind_consnrealargs ci.ci_cstr_nargs) - then raise (TypeError(env,WrongCaseInfo(indsp,ci))) + then raise (TypeError(env,WrongCaseInfo((indsp,u),ci))) (************************************************************************) (************************************************************************) @@ -450,7 +440,7 @@ type guard_env = genv : subterm_spec Lazy.t list; } -let make_renv env recarg (kn,tyi) = +let make_renv env recarg ((kn,tyi),u) = let mib = Environ.lookup_mind kn env in let mind_recvec = Array.map (fun mip -> mip.mind_recargs) mib.mind_packets in @@ -552,7 +542,6 @@ let rec subterm_specif renv stack t = let f,l = decompose_app (whd_betadeltaiota renv.env t) in match kind_of_term f with | Rel k -> subterm_var k renv - | Case (ci,p,c,lbr) -> let stack' = push_stack_closures renv l stack in if not (check_inductive_codomain renv.env p) then Not_subterm @@ -581,7 +570,7 @@ let rec subterm_specif renv stack t = with Not_found -> None in (match oind with None -> Not_subterm (* happens if fix is polymorphic *) - | Some ind -> + | Some (ind, _) -> let nbfix = Array.length typarray in let recargs = lookup_subterms renv.env ind in (* pushing the fixpoints *) @@ -668,7 +657,7 @@ let check_one_fix renv recpos def = (* if [t] does not make recursive calls, it is guarded: *) if noccur_with_meta renv.rel_min nfi t then () else - let (f,l) = decompose_app (whd_betaiotazeta t) in + let (f,l) = decompose_app (whd_betaiotazeta renv.env t) in match kind_of_term f with | Rel p -> (* Test if [p] is a fixpoint (recursive call) *) @@ -739,11 +728,11 @@ let check_one_fix renv recpos def = else check_rec_call renv' [] body) bodies - | Const kn -> + | Const (kn,u as cu) -> if evaluable_constant kn renv.env then try List.iter (check_rec_call renv []) l with (FixGuardError _ ) -> - let value = (applist(constant_value renv.env kn, l)) in + let value = (applist(constant_value_in renv.env cu, l)) in check_rec_call renv stack value else List.iter (check_rec_call renv []) l @@ -785,6 +774,8 @@ let check_one_fix renv recpos def = | (Evar _ | Meta _) -> () | (App _ | LetIn _ | Cast _) -> assert false (* beta zeta reduction *) + + | Proj (p, c) -> check_rec_call renv [] c and check_nested_fix_body renv decr recArgsDecrArg body = if Int.equal decr 0 then @@ -888,7 +879,7 @@ let check_one_cofix env nbfix def deftype = else if not(List.for_all (noccur_with_meta n nbfix) args) then raise (CoFixGuardError (env,NestedRecursiveOccurrences)) - | Construct (_,i as cstr_kn) -> + | Construct ((_,i as cstr_kn),u) -> let lra = vlra.(i-1) in let mI = inductive_of_constructor cstr_kn in let (mib,mip) = lookup_mind_specif env mI in @@ -947,7 +938,7 @@ let check_one_cofix env nbfix def deftype = | _ -> raise (CoFixGuardError (env,NotGuardedForm t)) in - let (mind, _) = codomain_is_coind env deftype in + let ((mind, _),_) = codomain_is_coind env deftype in let vlra = lookup_subterms env mind in check_rec_call env false 1 (dest_subterms vlra) def diff --git a/kernel/inductive.mli b/kernel/inductive.mli index d9841085e..c4a7452f0 100644 --- a/kernel/inductive.mli +++ b/kernel/inductive.mli @@ -7,9 +7,9 @@ (************************************************************************) open Names -open Univ open Term open Context +open Univ open Declarations open Environ @@ -21,9 +21,9 @@ open Environ only a coinductive type. They raise [Not_found] if not convertible to a recursive type. *) -val find_rectype : env -> types -> inductive * constr list -val find_inductive : env -> types -> inductive * constr list -val find_coinductive : env -> types -> inductive * constr list +val find_rectype : env -> types -> pinductive * constr list +val find_inductive : env -> types -> pinductive * constr list +val find_coinductive : env -> types -> pinductive * constr list type mind_specif = mutual_inductive_body * one_inductive_body @@ -33,23 +33,38 @@ type mind_specif = mutual_inductive_body * one_inductive_body val lookup_mind_specif : env -> inductive -> mind_specif (** {6 Functions to build standard types related to inductive } *) -val ind_subst : mutual_inductive -> mutual_inductive_body -> constr list +val ind_subst : mutual_inductive -> mutual_inductive_body -> universe_instance -> constr list + +val make_inductive_subst : mutual_inductive_body -> universe_instance -> universe_subst + +val inductive_instance : mutual_inductive_body -> universe_instance +val inductive_context : mutual_inductive_body -> universe_context +val inductive_params_ctxt : mutual_inductive_body puniverses -> rel_context + +val instantiate_inductive_constraints : mutual_inductive_body -> universe_subst -> constraints -val type_of_inductive : env -> mind_specif -> types +val constrained_type_of_inductive : env -> mind_specif puniverses -> types constrained + +val type_of_inductive : env -> mind_specif puniverses -> types + +val type_of_inductive_knowing_parameters : env -> ?polyprop:bool -> mind_specif puniverses -> types Lazy.t array -> types val elim_sorts : mind_specif -> sorts_family list (** Return type as quoted by the user *) -val type_of_constructor : constructor -> mind_specif -> types + +val constrained_type_of_constructor : pconstructor -> mind_specif -> types constrained +val type_of_constructor : pconstructor -> mind_specif -> types +val type_of_constructor_in_ctx : constructor -> mind_specif -> types in_universe_context (** Return constructor types in normal form *) -val arities_of_constructors : inductive -> mind_specif -> types array +val arities_of_constructors : pinductive -> mind_specif -> types array (** Return constructor types in user form *) -val type_of_constructors : inductive -> mind_specif -> types array +val type_of_constructors : pinductive -> mind_specif -> types array (** Transforms inductive specification into types (in nf) *) -val arities_of_specif : mutual_inductive -> mind_specif -> types array +val arities_of_specif : mutual_inductive puniverses -> mind_specif -> types array val inductive_params : mind_specif -> int @@ -61,11 +76,11 @@ val inductive_params : mind_specif -> int the universe constraints generated. *) val type_case_branches : - env -> inductive * constr list -> unsafe_judgment -> constr - -> types array * types * constraints + env -> pinductive * constr list -> unsafe_judgment -> constr + -> types array * types val build_branches_type : - inductive -> mutual_inductive_body * one_inductive_body -> + pinductive -> mutual_inductive_body * one_inductive_body -> constr list -> constr -> types array (** Return the arity of an inductive type *) @@ -75,7 +90,7 @@ val inductive_sort_family : one_inductive_body -> sorts_family (** Check a [case_info] actually correspond to a Case expression on the given inductive type. *) -val check_case_info : env -> inductive -> case_info -> unit +val check_case_info : env -> pinductive -> case_info -> unit (** {6 Guard conditions for fix and cofix-points. } *) val check_fix : env -> fixpoint -> unit @@ -92,14 +107,8 @@ val check_cofix : env -> cofixpoint -> unit exception SingletonInductiveBecomesProp of Id.t -val type_of_inductive_knowing_parameters : ?polyprop:bool -> - env -> one_inductive_body -> types Lazy.t array -> types - val max_inductive_sort : sorts array -> universe -val instantiate_universes : env -> rel_context -> - polymorphic_arity -> types Lazy.t array -> rel_context * sorts - (** {6 Debug} *) type size = Large | Strict diff --git a/kernel/kernel.mllib b/kernel/kernel.mllib index 0d0adf9a7..29fe887d7 100644 --- a/kernel/kernel.mllib +++ b/kernel/kernel.mllib @@ -32,6 +32,7 @@ Type_errors Modops Inductive Typeops +Fast_typeops Indtypes Cooking Term_typing @@ -39,7 +40,6 @@ Subtyping Mod_typing Nativelibrary Safe_typing - Vm Csymtable Vconv diff --git a/kernel/mod_subst.ml b/kernel/mod_subst.ml index 9589c0656..cfe46152e 100644 --- a/kernel/mod_subst.ml +++ b/kernel/mod_subst.ml @@ -271,7 +271,7 @@ let progress f x ~orelse = let y = f x in if y != x then y else orelse -let subst_ind sub mind = +let subst_mind sub mind = let mpu,dir,l = MutInd.repr3 mind in let mpc = KerName.modpath (MutInd.canonical mind) in try @@ -284,7 +284,14 @@ let subst_ind sub mind = MutInd.make knu knc' with No_subst -> mind -let subst_con0 sub cst = +let subst_ind sub (ind,i as indi) = + let ind' = subst_mind sub ind in + if ind' == ind then indi else ind',i + +let subst_pind sub (ind,u) = + (subst_ind sub ind, u) + +let subst_con0 sub (cst,u) = let mpu,dir,l = Constant.repr3 cst in let mpc = KerName.modpath (Constant.canonical cst) in let mpu,mpc,resolve,user = subst_dual_mp sub mpu mpc in @@ -299,11 +306,28 @@ let subst_con0 sub cst = progress (kn_of_delta resolve) (if user then knu else knc) ~orelse:knc in let cst' = Constant.make knu knc' in - cst', mkConst cst' + cst', mkConstU (cst',u) let subst_con sub cst = try subst_con0 sub cst - with No_subst -> cst, mkConst cst + with No_subst -> fst cst, mkConstU cst + +let subst_con_kn sub con = + subst_con sub (con,Univ.Instance.empty) + +let subst_pcon sub (con,u as pcon) = + try let con', can = subst_con0 sub pcon in + con',u + with No_subst -> pcon + +let subst_pcon_term sub (con,u as pcon) = + try let con', can = subst_con0 sub pcon in + (con',u), can + with No_subst -> pcon, mkConstU pcon + +let subst_constant sub con = + try fst (subst_con0 sub (con,Univ.Instance.empty)) + with No_subst -> con (* Here the semantics is completely unclear. What does "Hint Unfold t" means when "t" is a parameter? @@ -312,18 +336,25 @@ let subst_con sub cst = interpretation (i.e. an evaluable reference is never expanded). *) let subst_evaluable_reference subst = function | EvalVarRef id -> EvalVarRef id - | EvalConstRef kn -> EvalConstRef (fst (subst_con subst kn)) + | EvalConstRef kn -> EvalConstRef (subst_constant subst kn) let rec map_kn f f' c = let func = map_kn f f' in match kind_of_term c with | Const kn -> (try snd (f' kn) with No_subst -> c) - | Ind (kn,i) -> + | Proj (kn,t) -> + let kn' = try fst (f' (kn,Univ.Instance.empty)) + with No_subst -> kn + in + let t' = func t in + if kn' == kn && t' == t then c + else mkProj (kn', t') + | Ind ((kn,i),u) -> let kn' = f kn in - if kn'==kn then c else mkInd (kn',i) - | Construct ((kn,i),j) -> + if kn'==kn then c else mkIndU ((kn',i),u) + | Construct (((kn,i),j),u) -> let kn' = f kn in - if kn'==kn then c else mkConstruct ((kn',i),j) + if kn'==kn then c else mkConstructU (((kn',i),j),u) | Case (ci,p,ct,l) -> let ci_ind = let (kn,i) = ci.ci_ind in @@ -382,7 +413,7 @@ let rec map_kn f f' c = let subst_mps sub c = if is_empty_subst sub then c - else map_kn (subst_ind sub) (subst_con0 sub) c + else map_kn (subst_mind sub) (subst_con0 sub) c let rec replace_mp_in_mp mpfrom mpto mp = match mp with diff --git a/kernel/mod_subst.mli b/kernel/mod_subst.mli index 34f10b31a..5a913a906 100644 --- a/kernel/mod_subst.mli +++ b/kernel/mod_subst.mli @@ -118,15 +118,32 @@ val debug_pr_delta : delta_resolver -> Pp.std_ppcmds val subst_mp : substitution -> module_path -> module_path -val subst_ind : +val subst_mind : substitution -> mutual_inductive -> mutual_inductive +val subst_ind : + substitution -> inductive -> inductive + +val subst_pind : substitution -> pinductive -> pinductive + val subst_kn : substitution -> kernel_name -> kernel_name val subst_con : + substitution -> pconstant -> constant * constr + +val subst_pcon : + substitution -> pconstant -> pconstant + +val subst_pcon_term : + substitution -> pconstant -> pconstant * constr + +val subst_con_kn : substitution -> constant -> constant * constr +val subst_constant : + substitution -> constant -> constant + (** Here the semantics is completely unclear. What does "Hint Unfold t" means when "t" is a parameter? Does the user mean "Unfold X.t" or does she mean "Unfold y" diff --git a/kernel/mod_typing.ml b/kernel/mod_typing.ml index 6c0f1b060..b20fe9671 100644 --- a/kernel/mod_typing.ml +++ b/kernel/mod_typing.ml @@ -52,7 +52,7 @@ let rec rebuild_mp mp l = | []-> mp | i::r -> rebuild_mp (MPdot(mp,Label.of_id i)) r -let (+++) = Univ.union_constraints +let (+++) = Univ.Constraint.union let rec check_with_def env struc (idl,c) mp equiv = let lab,idl = match idl with @@ -72,24 +72,31 @@ let rec check_with_def env struc (idl,c) mp equiv = (* In the spirit of subtyping.check_constant, we accept any implementations of parameters and opaques terms, as long as they have the right type *) + let env' = Environ.add_constraints + (Univ.UContext.constraints (Future.force cb.const_universes)) env' in let c',cst = match cb.const_body with | Undef _ | OpaqueDef _ -> - let j,cst1 = Typeops.infer env' c in + let j = Typeops.infer env' c in let typ = Typeops.type_of_constant_type env' cb.const_type in - let cst2 = Reduction.conv_leq env' j.uj_type typ in - let cst = cb.const_constraints +++ cst1 +++ cst2 in - j.uj_val, cst + let cst = Reduction.infer_conv_leq env' (Environ.universes env') + j.uj_type typ in + j.uj_val,cst | Def cs -> - let cst1 = Reduction.conv env' c (Mod_subst.force_constr cs) in - let cst = cb.const_constraints +++ cst1 in - c, cst + let cst = Reduction.infer_conv env' (Environ.universes env') c + (Mod_subst.force_constr cs) in + let cst = + if cb.const_polymorphic then cst + else (*FIXME MS: computed above *) + (Univ.UContext.constraints (Future.force cb.const_universes)) +++ cst + in + c, cst in let def = Def (Mod_subst.from_val c') in let cb' = { cb with const_body = def; - const_body_code = Cemitcodes.from_val (compile_constant_body env' def); - const_constraints = cst } + const_body_code = Cemitcodes.from_val (compile_constant_body env' def) } + (* const_universes = Future.from_val cst } *) in before@(lab,SFBconst(cb'))::after, c', cst else @@ -185,7 +192,7 @@ let rec check_with_mod env struc (idl,mp1) mp equiv = | Algebraic (NoFunctor (MEident mp0)) -> let mpnew = rebuild_mp mp0 idl in check_modpath_equiv env' mpnew mp; - before@(lab,spec)::after, equiv, Univ.empty_constraint + before@(lab,spec)::after, equiv, Univ.Constraint.empty | _ -> error_generative_module_expected lab end with @@ -229,7 +236,7 @@ let rec translate_mse env mpo inl = function let mtb = lookup_modtype mp1 env in mtb.typ_expr, mtb.typ_delta in - sign,Some (MEident mp1),reso,Univ.empty_constraint + sign,Some (MEident mp1),reso,Univ.Constraint.empty |MEapply (fe,mp1) -> translate_apply env inl (translate_mse env mpo inl fe) mp1 (mk_alg_app mpo) |MEwith(me, with_decl) -> @@ -297,7 +304,7 @@ let finalize_module env mp (sign,alg,reso,cst) restype = match restype with typ_mp = mp; typ_expr = sign; typ_expr_alg = None; - typ_constraints = Univ.empty_constraint; + typ_constraints = Univ.Constraint.empty; typ_delta = reso } in let cst' = Subtyping.check_subtypes env auto_mtb res_mtb in let impl = match alg with Some e -> Algebraic e | None -> Struct sign in @@ -322,7 +329,7 @@ let rec translate_mse_incl env mp inl = function |MEident mp1 -> let mb = strengthen_and_subst_mb (lookup_module mp1 env) mp true in let sign = clean_bounded_mod_expr mb.mod_type in - sign,None,mb.mod_delta,Univ.empty_constraint + sign,None,mb.mod_delta,Univ.Constraint.empty |MEapply (fe,arg) -> let ftrans = translate_mse_incl env mp inl fe in translate_apply env inl ftrans arg (fun _ _ -> None) diff --git a/kernel/modops.ml b/kernel/modops.ml index 6d0e919f8..093ee7024 100644 --- a/kernel/modops.ml +++ b/kernel/modops.ml @@ -210,7 +210,7 @@ and subst_structure sub do_delta sign = let cb' = subst_const_body sub cb in if cb==cb' then orig else (l,SFBconst cb') |SFBmind mib -> - let mib' = subst_mind sub mib in + let mib' = subst_mind_body sub mib in if mib==mib' then orig else (l,SFBmind mib') |SFBmodule mb -> let mb' = subst_module sub do_delta mb in @@ -460,7 +460,7 @@ and strengthen_and_subst_struct str subst mp_from mp_to alias incl reso = because reso' contains mp_to maps to reso(mp_from) *) reso', item'::rest' | (l,SFBmind mib) :: rest -> - let item' = l,SFBmind (subst_mind subst mib) in + let item' = l,SFBmind (subst_mind_body subst mib) in let reso',rest' = strengthen_and_subst_struct rest subst mp_from mp_to alias incl reso in diff --git a/kernel/names.ml b/kernel/names.ml index ef0e812ed..c76d95937 100644 --- a/kernel/names.ml +++ b/kernel/names.ml @@ -309,6 +309,11 @@ module ModPath = struct let initial = MPfile DirPath.initial + let rec dp = function + | MPfile sl -> sl + | MPbound (_,_,dp) -> dp + | MPdot (mp,l) -> dp mp + module Self_Hashcons = struct type t = module_path type u = (DirPath.t -> DirPath.t) * (MBId.t -> MBId.t) * @@ -424,7 +429,6 @@ module KerName = struct let hcons = Hashcons.simple_hcons HashKN.generate (ModPath.hcons,DirPath.hcons,String.hcons) - end module KNmap = HMap.Make(KerName) @@ -567,6 +571,7 @@ let constr_modpath (ind,_) = ind_modpath ind let ith_mutual_inductive (mind, _) i = (mind, i) let ith_constructor_of_inductive ind i = (ind, i) +let ith_constructor_of_pinductive (ind,u) i = ((ind,i),u) let inductive_of_constructor (ind, i) = ind let index_of_constructor (ind, i) = i @@ -663,8 +668,7 @@ let hcons_mind = Hashcons.simple_hcons MutInd.HashKP.generate KerName.hcons let hcons_ind = Hashcons.simple_hcons Hind.generate hcons_mind let hcons_construct = Hashcons.simple_hcons Hconstruct.generate hcons_ind - -(*******) +(*****************) type transparent_state = Id.Pred.t * Cpred.t @@ -674,25 +678,26 @@ let var_full_transparent_state = (Id.Pred.full, Cpred.empty) let cst_full_transparent_state = (Id.Pred.empty, Cpred.full) type 'a tableKey = - | ConstKey of Constant.t + | ConstKey of 'a | VarKey of Id.t - | RelKey of 'a - + | RelKey of Int.t type inv_rel_key = int (* index in the [rel_context] part of environment starting by the end, {\em inverse} of de Bruijn indice *) -type id_key = inv_rel_key tableKey +type id_key = Constant.t tableKey -let eq_id_key ik1 ik2 = +let eq_table_key f ik1 ik2 = if ik1 == ik2 then true else match ik1,ik2 with - | ConstKey c1, ConstKey c2 -> Constant.UserOrd.equal c1 c2 + | ConstKey c1, ConstKey c2 -> f c1 c2 | VarKey id1, VarKey id2 -> Id.equal id1 id2 | RelKey k1, RelKey k2 -> Int.equal k1 k2 | _ -> false +let eq_id_key = eq_table_key Constant.UserOrd.equal + let eq_con_chk = Constant.UserOrd.equal let eq_mind_chk = MutInd.UserOrd.equal let eq_ind_chk (kn1,i1) (kn2,i2) = Int.equal i1 i2 && eq_mind_chk kn1 kn2 @@ -777,6 +782,7 @@ let kn_ord = KerName.compare (** Compatibility layer for [Constant] *) type constant = Constant.t +type projection = constant let constant_of_kn = Constant.make1 let constant_of_kn_equiv = Constant.make @@ -787,6 +793,7 @@ let user_con = Constant.user let con_label = Constant.label let con_modpath = Constant.modpath let eq_constant = Constant.equal +let eq_constant_key = Constant.UserOrd.equal let con_ord = Constant.CanOrd.compare let con_user_ord = Constant.UserOrd.compare let string_of_con = Constant.to_string diff --git a/kernel/names.mli b/kernel/names.mli index db973ed3a..49a838ae5 100644 --- a/kernel/names.mli +++ b/kernel/names.mli @@ -216,6 +216,8 @@ sig val initial : t (** Name of the toplevel structure ([= MPfile initial_dir]) *) + val dp : t -> DirPath.t + end module MPset : Set.S with type elt = ModPath.t @@ -440,10 +442,11 @@ val hcons_construct : constructor -> constructor (******) type 'a tableKey = - | ConstKey of Constant.t + | ConstKey of 'a | VarKey of Id.t - | RelKey of 'a + | RelKey of Int.t +(** Sets of names *) type transparent_state = Id.Pred.t * Cpred.t val empty_transparent_state : transparent_state @@ -455,8 +458,10 @@ type inv_rel_key = int (** index in the [rel_context] part of environment starting by the end, {e inverse} of de Bruijn indice *) -type id_key = inv_rel_key tableKey +type id_key = Constant.t tableKey +val eq_table_key : ('a -> 'a -> bool) -> 'a tableKey -> 'a tableKey -> bool +val eq_constant_key : Constant.t -> Constant.t -> bool val eq_id_key : id_key -> id_key -> bool (** equalities on constant and inductive names (for the checker) *) @@ -629,6 +634,8 @@ val kn_ord : kernel_name -> kernel_name -> int type constant = Constant.t (** @deprecated Alias type *) +type projection = constant + val constant_of_kn_equiv : KerName.t -> KerName.t -> constant (** @deprecated Same as [Constant.make] *) diff --git a/kernel/nativecode.ml b/kernel/nativecode.ml index 1f6effba6..bd659a471 100644 --- a/kernel/nativecode.ml +++ b/kernel/nativecode.ml @@ -48,6 +48,7 @@ type gname = | Gind of string * inductive (* prefix, inductive name *) | Gconstruct of string * constructor (* prefix, constructor name *) | Gconstant of string * constant (* prefix, constant name *) + | Gproj of string * constant (* prefix, constant name *) | Gcase of label option * int | Gpred of label option * int | Gfixtype of label option * int @@ -95,6 +96,7 @@ let gname_hash gn = match gn with | Ginternal s -> combinesmall 9 (String.hash s) | Grel i -> combinesmall 10 (Int.hash i) | Gnamed id -> combinesmall 11 (Id.hash id) +| Gproj (s, p) -> combinesmall 12 (combine (String.hash s) (Constant.hash p)) let case_ctr = ref (-1) @@ -253,6 +255,7 @@ type primitive = | Mk_cofix of int | Mk_rel of int | Mk_var of identifier + | Mk_proj | Is_accu | Is_int | Cast_accu @@ -298,6 +301,8 @@ let eq_primitive p1 p2 = | Force_cofix, Force_cofix -> true | Mk_meta, Mk_meta -> true | Mk_evar, Mk_evar -> true + | Mk_proj, Mk_proj -> true + | _ -> false let primitive_hash = function @@ -344,6 +349,7 @@ let primitive_hash = function | Coq_primitive (prim, None) -> combinesmall 36 (Primitives.hash prim) | Coq_primitive (prim, Some (prefix,kn)) -> combinesmall 37 (combine3 (String.hash prefix) (Constant.hash kn) (Primitives.hash prim)) + | Mk_proj -> 38 type mllambda = | MLlocal of lname @@ -1002,6 +1008,7 @@ let compile_prim decl cond paux = | Lapp(f,args) -> MLapp(ml_of_lam env l f, Array.map (ml_of_lam env l) args) | Lconst (prefix,c) -> MLglobal(Gconstant (prefix,c)) + | Lproj (prefix,c) -> MLglobal(Gproj (prefix,c)) | Lprim _ -> let decl,cond,paux = extract_prim (ml_of_lam env l) t in compile_prim decl cond paux @@ -1461,6 +1468,8 @@ let string_of_gname g = Format.sprintf "%sconstruct_%s_%i_%i" prefix (string_of_mind mind) i (j-1) | Gconstant (prefix, c) -> Format.sprintf "%sconst_%s" prefix (string_of_con c) + | Gproj (prefix, c) -> + Format.sprintf "%sproj_%s" prefix (string_of_con c) | Gcase (l,i) -> Format.sprintf "case_%s_%i" (string_of_label_def l) i | Gpred (l,i) -> @@ -1518,12 +1527,12 @@ let pp_mllam fmt l = | MLif(t,l1,l2) -> Format.fprintf fmt "@[(if %a then@\n %a@\nelse@\n %a)@]" pp_mllam t pp_mllam l1 pp_mllam l2 - | MLmatch (asw, c, accu_br, br) -> - let mind,i = asw.asw_ind in - let prefix = asw.asw_prefix in - let accu = Format.sprintf "%sAccu_%s_%i" prefix (string_of_mind mind) i in - Format.fprintf fmt - "@[begin match Obj.magic (%a) with@\n| %s _ ->@\n %a@\n%aend@]" + | MLmatch (annot, c, accu_br, br) -> + let mind,i = annot.asw_ind in + let prefix = annot.asw_prefix in + let accu = Format.sprintf "%sAccu_%s_%i" prefix (string_of_mind mind) i in + Format.fprintf fmt + "@[begin match Obj.magic (%a) with@\n| %s _ ->@\n %a@\n%aend@]" pp_mllam c accu pp_mllam accu_br (pp_branches prefix) br | MLconstruct(prefix,c,args) -> @@ -1626,6 +1635,7 @@ let pp_mllam fmt l = | Mk_rel i -> Format.fprintf fmt "mk_rel_accu %i" i | Mk_var id -> Format.fprintf fmt "mk_var_accu (Names.id_of_string \"%s\")" (string_of_id id) + | Mk_proj -> Format.fprintf fmt "mk_proj_accu" | Is_accu -> Format.fprintf fmt "is_accu" | Is_int -> Format.fprintf fmt "is_int" | Cast_accu -> Format.fprintf fmt "cast_accu" @@ -1758,9 +1768,11 @@ and compile_named env sigma auxdefs id = | None -> Glet(Gnamed id, MLprimitive (Mk_var id))::auxdefs -let compile_constant env sigma prefix ~interactive con body = - match body with - | Def t -> +let compile_constant env sigma prefix ~interactive con cb = + match cb.const_proj with + | None -> + begin match cb.const_body with + | Def t -> let t = Mod_subst.force_constr t in let code = lambda_of_constr env sigma t in if !Flags.debug then Pp.msg_debug (Pp.str "Generated lambda code"); @@ -1778,11 +1790,42 @@ let compile_constant env sigma prefix ~interactive con body = in if !Flags.debug then Pp.msg_debug (Pp.str "Optimized mllambda code"); code, name - | _ -> + | _ -> + let i = push_symbol (SymbConst con) in + [Glet(Gconstant ("",con), MLapp (MLprimitive Mk_const, [|get_const_code i|]))], + if interactive then LinkedInteractive prefix + else Linked prefix + end + | Some pb -> + let mind = pb.proj_ind in + let ind = (mind,0) in + let mib = lookup_mind mind env in + let oib = mib.mind_packets.(0) in + let tbl = oib.mind_reloc_tbl in + (* Building info *) + let prefix = get_mind_prefix env mind in + let ci = { ci_ind = ind; ci_npar = mib.mind_nparams; + ci_cstr_nargs = [|0|]; + ci_cstr_ndecls = [||] (*FIXME*); + ci_pp_info = { ind_nargs = 0; style = RegularStyle } } in + let asw = { asw_ind = ind; asw_prefix = prefix; asw_ci = ci; + asw_reloc = tbl; asw_finite = true } in + let c_uid = fresh_lname Anonymous in + let _, arity = tbl.(0) in + let ci_uid = fresh_lname Anonymous in + let cargs = Array.init arity + (fun i -> if Int.equal i pb.proj_arg then Some ci_uid else None) + in let i = push_symbol (SymbConst con) in - [Glet(Gconstant ("",con), MLapp (MLprimitive Mk_const, [|get_const_code i|]))], - if interactive then LinkedInteractive prefix - else Linked prefix + let accu = MLapp (MLprimitive Cast_accu, [|MLlocal c_uid|]) in + let accu_br = MLapp (MLprimitive Mk_proj, [|get_const_code i;accu|]) in + let code = MLmatch(asw,MLlocal c_uid,accu_br,[|[((ind,1),cargs)],MLlocal ci_uid|]) in + let gn = Gproj ("",con) in + let fargs = Array.init (pb.proj_npars + 1) (fun _ -> fresh_lname Anonymous) in + let arg = fargs.(pb.proj_npars) in + Glet(Gconstant ("",con), mkMLlam fargs (MLapp (MLglobal gn, [|MLlocal + arg|]))):: + [Glet(gn, mkMLlam [|c_uid|] code)], Linked prefix let loaded_native_files = ref ([] : string list) @@ -1858,8 +1901,8 @@ let compile_mind_deps env prefix ~interactive reverse order, as well as linking information updates *) let rec compile_deps env sigma prefix ~interactive init t = match kind_of_term t with - | Ind (mind,_) -> compile_mind_deps env prefix ~interactive init mind - | Const c -> + | Ind ((mind,_),u) -> compile_mind_deps env prefix ~interactive init mind + | Const (c,u) -> let c = get_allias env c in let cb,(nameref,_) = lookup_constant_key c env in let (_, (_, const_updates)) = init in @@ -1873,12 +1916,14 @@ let rec compile_deps env sigma prefix ~interactive init t = | _ -> init in let code, name = - compile_constant env sigma prefix ~interactive c cb.const_body + compile_constant env sigma prefix ~interactive c cb in let comp_stack = code@comp_stack in let const_updates = Cmap_env.add c (nameref, name) const_updates in comp_stack, (mind_updates, const_updates) - | Construct ((mind,_),_) -> compile_mind_deps env prefix ~interactive init mind + | Construct (((mind,_),_),u) -> compile_mind_deps env prefix ~interactive init mind + | Proj (p,c) -> + compile_deps env sigma prefix ~interactive init (mkApp (mkConst p, [|c|])) | Case (ci, p, c, ac) -> let mind = fst ci.ci_ind in let init = compile_mind_deps env prefix ~interactive init mind in @@ -1888,7 +1933,7 @@ let rec compile_deps env sigma prefix ~interactive init t = let compile_constant_field env prefix con acc cb = let (gl, _) = compile_constant ~interactive:false env empty_evars prefix - con cb.const_body + con cb in gl@acc diff --git a/kernel/nativeconv.ml b/kernel/nativeconv.ml index 82786df64..766e6513c 100644 --- a/kernel/nativeconv.ml +++ b/kernel/nativeconv.ml @@ -70,7 +70,7 @@ and conv_atom pb lvl a1 a2 cu = if not (eq_constant c1 c2) then raise NotConvertible; cu | Asort s1, Asort s2 -> - sort_cmp pb s1 s2 cu + ignore(sort_cmp_universes pb s1 s2 (cu, None)); cu | Avar id1, Avar id2 -> if not (Id.equal id1 id2) then raise NotConvertible; cu @@ -131,9 +131,9 @@ let native_conv pb sigma env t1 t2 = vm_conv pb env t1 t2 end else - let env = Environ.pre_env env in + let penv = Environ.pre_env env in let ml_filename, prefix = get_ml_filename () in - let code, upds = mk_conv_code env sigma prefix t1 t2 in + let code, upds = mk_conv_code penv sigma prefix t1 t2 in match compile ml_filename code with | (0,fn) -> begin @@ -144,7 +144,7 @@ let native_conv pb sigma env t1 t2 = let time_info = Format.sprintf "Evaluation done in %.5f@." (t1 -. t0) in if !Flags.debug then Pp.msg_debug (Pp.str time_info); (* TODO change 0 when we can have deBruijn *) - conv_val pb 0 !rt1 !rt2 empty_constraint + ignore(conv_val pb 0 !rt1 !rt2 (Environ.universes env)) end | _ -> anomaly (Pp.str "Compilation failure") diff --git a/kernel/nativeinstr.mli b/kernel/nativeinstr.mli index 13d61841f..7d1bf0d19 100644 --- a/kernel/nativeinstr.mli +++ b/kernel/nativeinstr.mli @@ -29,6 +29,7 @@ and lambda = | Llet of name * lambda * lambda | Lapp of lambda * lambda array | Lconst of prefix * constant + | Lproj of prefix * constant (* prefix, projection name *) | Lprim of prefix * constant * Primitives.t * lambda array | Lcase of annot_sw * lambda * lambda * lam_branches (* annotations, term being matched, accu, branches *) diff --git a/kernel/nativelambda.ml b/kernel/nativelambda.ml index 8ea28ddff..16ca444e3 100644 --- a/kernel/nativelambda.ml +++ b/kernel/nativelambda.ml @@ -79,12 +79,12 @@ let get_const_prefix env c = | NotLinked -> "" | Linked s -> s | LinkedInteractive s -> s - + (* A generic map function *) let map_lam_with_binders g f n lam = match lam with - | Lrel _ | Lvar _ | Lconst _ | Luint _ | Lval _ | Lsort _ | Lind _ + | Lrel _ | Lvar _ | Lconst _ | Lproj _ | Luint _ | Lval _ | Lsort _ | Lind _ | Lconstruct _ | Llazy | Lforce | Lmeta _ | Levar _ -> lam | Lprod(dom,codom) -> let dom' = f n dom in @@ -183,7 +183,7 @@ let lam_subst_args subst args = let can_subst lam = match lam with - | Lrel _ | Lvar _ | Lconst _ | Lval _ | Lsort _ | Lind _ | Llam _ + | Lrel _ | Lvar _ | Lconst _ | Lproj _ | Lval _ | Lsort _ | Lind _ | Llam _ | Lconstruct _ | Lmeta _ | Levar _ -> true | _ -> false @@ -257,6 +257,7 @@ and simplify_app substf f substa args = let args = Array.append (lam_subst_args substf args') (lam_subst_args substa args) in simplify_app substf f subst_id args + (* TODO | Lproj -> simplify if the argument is known or a known global *) | _ -> mkLapp (simplify substf f) (simplify_args substa args) and simplify_args subst args = Array.smartmap (simplify subst) args @@ -290,7 +291,7 @@ let rec occurence k kind lam = if Int.equal n k then if kind then false else raise Not_found else kind - | Lvar _ | Lconst _ | Luint _ | Lval _ | Lsort _ | Lind _ + | Lvar _ | Lconst _ | Lproj _ | Luint _ | Lval _ | Lsort _ | Lind _ | Lconstruct _ | Llazy | Lforce | Lmeta _ | Levar _ -> kind | Lprod(dom, codom) -> occurence k (occurence k kind dom) codom @@ -504,7 +505,7 @@ let is_lazy prefix t = match kind_of_term t with | App (f,args) -> begin match kind_of_term f with - | Construct c -> + | Construct (c,_) -> let entry = mkInd (fst c) in (try let _ = @@ -552,7 +553,7 @@ let rec lambda_of_constr env sigma c = | Sort s -> Lsort s - | Ind ind -> + | Ind (ind,u) -> let prefix = get_mind_prefix !global_env (fst ind) in Lind (prefix, ind) @@ -584,6 +585,9 @@ let rec lambda_of_constr env sigma c = | Construct _ -> lambda_of_app env sigma c empty_args + | Proj (p, c) -> + mkLapp (Lproj (get_const_prefix !global_env p, p)) [|lambda_of_constr env sigma c|] + | Case(ci,t,a,branches) -> let (mind,i as ind) = ci.ci_ind in let mib = lookup_mind mind !global_env in @@ -642,7 +646,7 @@ let rec lambda_of_constr env sigma c = and lambda_of_app env sigma f args = match kind_of_term f with - | Const kn -> + | Const (kn,u) -> let kn = get_allias !global_env kn in let cb = lookup_constant kn !global_env in (try @@ -654,7 +658,7 @@ and lambda_of_app env sigma f args = f args with Not_found -> begin match cb.const_body with - | Def csubst -> + | Def csubst -> (* TODO optimize if f is a proj and argument is known *) if cb.const_inline_code then lambda_of_app env sigma (Mod_subst.force_constr csubst) args else @@ -669,7 +673,7 @@ and lambda_of_app env sigma f args = let prefix = get_const_prefix !global_env kn in mkLapp (Lconst (prefix, kn)) (lambda_of_args env sigma 0 args) end) - | Construct c -> + | Construct (c,u) -> let tag, nparams, arity = Renv.get_construct_info env c in let expected = nparams + arity in let nargs = Array.length args in @@ -737,7 +741,7 @@ let compile_static_int31 fc args = Luint (UintVal (Uint31.of_int (Array.fold_left (fun temp_i -> fun t -> match kind_of_term t with - | Construct (_,d) -> 2*temp_i+d-1 + | Construct ((_,d),_) -> 2*temp_i+d-1 | _ -> raise NotClosed) 0 args))) diff --git a/kernel/nativelambda.mli b/kernel/nativelambda.mli index a2763626c..33a0dacf6 100644 --- a/kernel/nativelambda.mli +++ b/kernel/nativelambda.mli @@ -12,7 +12,6 @@ open Nativevalues open Nativeinstr (** This file defines the lambda code generation phase of the native compiler *) - type evars = { evars_val : existential -> constr option; evars_typ : existential -> types; @@ -26,6 +25,8 @@ val decompose_Llam_Llet : lambda -> (Names.name * lambda option) array * lambda val is_lazy : prefix -> constr -> bool val mk_lazy : lambda -> lambda +val get_mind_prefix : env -> mutual_inductive -> string + val get_allias : env -> constant -> constant val lambda_of_constr : env -> evars -> Constr.constr -> lambda diff --git a/kernel/nativevalues.ml b/kernel/nativevalues.ml index 043f06e26..d88d5d25d 100644 --- a/kernel/nativevalues.ml +++ b/kernel/nativevalues.ml @@ -60,6 +60,7 @@ type atom = | Aprod of name * t * (t -> t) | Ameta of metavariable * t | Aevar of existential * t + | Aproj of constant * accumulator let accumulate_tag = 0 @@ -128,6 +129,9 @@ let mk_meta_accu mv ty = let mk_evar_accu ev ty = mk_accu (Aevar (ev,ty)) +let mk_proj_accu kn c = + mk_accu (Aproj (kn,c)) + let atom_of_accu (k:accumulator) = (Obj.magic (Obj.field (Obj.magic k) 2) : atom) diff --git a/kernel/nativevalues.mli b/kernel/nativevalues.mli index 4fbf493cc..32079c8d0 100644 --- a/kernel/nativevalues.mli +++ b/kernel/nativevalues.mli @@ -52,6 +52,7 @@ type atom = | Aprod of name * t * (t -> t) | Ameta of metavariable * t | Aevar of existential * t + | Aproj of constant * accumulator (* Constructors *) @@ -68,6 +69,7 @@ val mk_fix_accu : rec_pos -> int -> t array -> t array -> t val mk_cofix_accu : int -> t array -> t array -> t val mk_meta_accu : metavariable -> t val mk_evar_accu : existential -> t -> t +val mk_proj_accu : constant -> accumulator -> t val upd_cofix : t -> t -> unit val force_cofix : t -> t val mk_const : tag -> t diff --git a/kernel/opaqueproof.ml b/kernel/opaqueproof.ml index 102dcf99f..673b12b2c 100644 --- a/kernel/opaqueproof.ml +++ b/kernel/opaqueproof.ml @@ -7,11 +7,16 @@ (************************************************************************) open Names +open Univ open Term open Mod_subst -type work_list = Id.t array Cmap.t * Id.t array Mindmap.t -type cooking_info = { modlist : work_list; abstract : Context.named_context } +type work_list = (Instance.t * Id.t array) Cmap.t * + (Instance.t * Id.t array) Mindmap.t + +type cooking_info = { + modlist : work_list; + abstract : Context.named_context in_universe_context } type proofterm = (constr * Univ.constraints) Future.computation type opaque = | Indirect of substitution list * DirPath.t * int (* subst, lib, index *) @@ -94,7 +99,7 @@ let force_constraints = function | NoIndirect(_,cu) -> snd(Future.force cu) | Indirect (_,dp,i) -> match !get_univ dp i with - | None -> Univ.empty_constraint + | None -> Univ.Constraint.empty | Some u -> Future.force u let get_constraints = function diff --git a/kernel/opaqueproof.mli b/kernel/opaqueproof.mli index 957889aa9..71f491754 100644 --- a/kernel/opaqueproof.mli +++ b/kernel/opaqueproof.mli @@ -38,8 +38,12 @@ val get_constraints : opaque -> Univ.constraints Future.computation option val subst_opaque : substitution -> opaque -> opaque val iter_direct_opaque : (constr -> unit) -> opaque -> opaque -type work_list = Id.t array Cmap.t * Id.t array Mindmap.t -type cooking_info = { modlist : work_list; abstract : Context.named_context } +type work_list = (Univ.Instance.t * Id.t array) Cmap.t * + (Univ.Instance.t * Id.t array) Mindmap.t + +type cooking_info = { + modlist : work_list; + abstract : Context.named_context Univ.in_universe_context } (* The type has two caveats: 1) cook_constr is defined after diff --git a/kernel/pre_env.ml b/kernel/pre_env.ml index b655887d7..ba9f30233 100644 --- a/kernel/pre_env.ml +++ b/kernel/pre_env.ml @@ -124,7 +124,7 @@ let env_of_rel n env = let push_named_context_val d (ctxt,vals) = let id,_,_ = d in let rval = ref VKnone in - Context.add_named_decl d ctxt, (id,rval)::vals + add_named_decl d ctxt, (id,rval)::vals let push_named d env = (* if not (env.env_rel_context = []) then raise (ASSERT env.env_rel_context); diff --git a/kernel/pre_env.mli b/kernel/pre_env.mli index 964d709cf..74a5fb1ae 100644 --- a/kernel/pre_env.mli +++ b/kernel/pre_env.mli @@ -7,10 +7,10 @@ (************************************************************************) open Names -open Univ open Term open Context open Declarations +open Univ (** The type of environments. *) diff --git a/kernel/reduction.ml b/kernel/reduction.ml index 5397e42f9..63bd40681 100644 --- a/kernel/reduction.ml +++ b/kernel/reduction.ml @@ -26,11 +26,11 @@ open Environ open Closure open Esubst -let unfold_reference ((ids, csts), infos) k = +let conv_key k = match k with - | VarKey id when not (Id.Pred.mem id ids) -> None - | ConstKey cst when not (Cpred.mem cst csts) -> None - | _ -> unfold_reference infos k + | VarKey id -> VarKey id + | ConstKey (cst,_) -> ConstKey cst + | RelKey n -> RelKey n let rec is_empty_stack = function [] -> true @@ -58,6 +58,8 @@ let compare_stack_shape stk1 stk2 = | (_, (Zupdate _|Zshift _)::s2) -> compare_rec bal stk1 s2 | (Zapp l1::s1, _) -> compare_rec (bal+Array.length l1) s1 stk2 | (_, Zapp l2::s2) -> compare_rec (bal-Array.length l2) stk1 s2 + | (Zproj (n1,m1,p1)::s1, Zproj (n2,m2,p2)::s2) -> + Int.equal bal 0 && compare_rec 0 s1 s2 | (Zcase(c1,_,_)::s1, Zcase(c2,_,_)::s2) -> Int.equal bal 0 (* && c1.ci_ind = c2.ci_ind *) && compare_rec 0 s1 s2 | (Zfix(_,a1)::s1, Zfix(_,a2)::s2) -> @@ -67,6 +69,7 @@ let compare_stack_shape stk1 stk2 = type lft_constr_stack_elt = Zlapp of (lift * fconstr) array + | Zlproj of constant * lift | Zlfix of (lift * fconstr) * lft_constr_stack | Zlcase of case_info * lift * fconstr * fconstr array and lft_constr_stack = lft_constr_stack_elt list @@ -85,6 +88,8 @@ let pure_stack lfts stk = | (Zshift n,(l,pstk)) -> (el_shft n l, pstk) | (Zapp a, (l,pstk)) -> (l,zlapp (Array.map (fun t -> (l,t)) a) pstk) + | (Zproj (n,m,c), (l,pstk)) -> + (l, Zlproj (c,l)::pstk) | (Zfix(fx,a),(l,pstk)) -> let (lfx,pa) = pure_rec l a in (l, Zlfix((lfx,fx),pa)::pstk) @@ -96,17 +101,17 @@ let pure_stack lfts stk = (* Reduction Functions *) (****************************************************************************) -let whd_betaiota t = - whd_val (create_clos_infos betaiota empty_env) (inject t) +let whd_betaiota env t = + whd_val (create_clos_infos betaiota env) (inject t) -let nf_betaiota t = - norm_val (create_clos_infos betaiota empty_env) (inject t) +let nf_betaiota env t = + norm_val (create_clos_infos betaiota env) (inject t) -let whd_betaiotazeta x = +let whd_betaiotazeta env x = match kind_of_term x with | (Sort _|Var _|Meta _|Evar _|Const _|Ind _|Construct _| Prod _|Lambda _|Fix _|CoFix _) -> x - | _ -> whd_val (create_clos_infos betaiotazeta empty_env) (inject x) + | _ -> whd_val (create_clos_infos betaiotazeta env) (inject x) let whd_betadeltaiota env t = match kind_of_term t with @@ -143,12 +148,31 @@ let betazeta_appvect n c v = (********************************************************************) (* Conversion utility functions *) -type 'a conversion_function = env -> 'a -> 'a -> Univ.constraints -type 'a trans_conversion_function = transparent_state -> env -> 'a -> 'a -> Univ.constraints +type 'a conversion_function = env -> 'a -> 'a -> unit +type 'a trans_conversion_function = Names.transparent_state -> 'a conversion_function +type 'a universe_conversion_function = env -> Univ.universes -> 'a -> 'a -> unit +type 'a trans_universe_conversion_function = + Names.transparent_state -> 'a universe_conversion_function +type 'a infer_conversion_function = env -> Univ.universes -> 'a -> 'a -> Univ.constraints + +type conv_universes = Univ.universes * Univ.constraints option exception NotConvertible exception NotConvertibleVect of int +let convert_universes (univs,cstrs as cuniv) u u' = + if Univ.Instance.check_eq univs u u' then cuniv + else + (match cstrs with + | None -> raise NotConvertible + | Some cstrs -> (univs, Some (Univ.enforce_eq_instances u u' cstrs))) + +let conv_table_key k1 k2 cuniv = + match k1, k2 with + | ConstKey (cst, u), ConstKey (cst', u') when eq_constant_key cst cst' -> + convert_universes cuniv u u' + | _ -> raise NotConvertible + let compare_stacks f fmind lft1 stk1 lft2 stk2 cuniv = let rec cmp_rec pstk1 pstk2 cuniv = match (pstk1,pstk2) with @@ -156,6 +180,10 @@ let compare_stacks f fmind lft1 stk1 lft2 stk2 cuniv = let cu1 = cmp_rec s1 s2 cuniv in (match (z1,z2) with | (Zlapp a1,Zlapp a2) -> Array.fold_right2 f a1 a2 cu1 + | (Zlproj (c1,l1),Zlproj (c2,l2)) -> + if not (eq_constant c1 c2) then + raise NotConvertible + else cu1 | (Zlfix(fx1,a1),Zlfix(fx2,a2)) -> let cu2 = f fx1 fx2 cu1 in cmp_rec a1 a2 cu2 @@ -184,34 +212,64 @@ type conv_pb = | CUMUL let is_cumul = function CUMUL -> true | CONV -> false - -let sort_cmp pb s0 s1 cuniv = +let is_pos = function Pos -> true | Null -> false + +(* let sort_cmp env pb s0 s1 cuniv = *) +(* match (s0,s1) with *) +(* | (Prop c1, Prop c2) when is_cumul pb -> *) +(* begin match c1, c2 with *) +(* | Null, _ | _, Pos -> cuniv (\* Prop <= Set *\) *) +(* | _ -> raise NotConvertible *) +(* end *) +(* | (Prop c1, Prop c2) -> *) +(* if c1 == c2 then cuniv else raise NotConvertible *) +(* | (Prop c1, Type u) when is_cumul pb -> *) +(* enforce_leq (if is_pos c1 then Universe.type0 else Universe.type0m) u cuniv *) +(* | (Type u, Prop c) when is_cumul pb -> *) +(* enforce_leq u (if is_pos c then Universe.type0 else Universe.type0m) cuniv *) +(* | (Type u1, Type u2) -> *) +(* (match pb with *) +(* | CONV -> Univ.enforce_eq u1 u2 cuniv *) +(* | CUMUL -> enforce_leq u1 u2 cuniv) *) +(* | (_, _) -> raise NotConvertible *) + +(* let conv_sort env s0 s1 = sort_cmp CONV s0 s1 Constraint.empty *) +(* let conv_sort_leq env s0 s1 = sort_cmp CUMUL s0 s1 Constraint.empty *) + +let check_eq (univs, cstrs as cuniv) u u' = + match cstrs with + | None -> if check_eq univs u u' then cuniv else raise NotConvertible + | Some cstrs -> univs, Some (Univ.enforce_eq u u' cstrs) + +let check_leq (univs, cstrs as cuniv) u u' = + match cstrs with + | None -> if check_leq univs u u' then cuniv else raise NotConvertible + | Some cstrs -> univs, Some (Univ.enforce_leq u u' cstrs) + +let sort_cmp_universes pb s0 s1 univs = + let dir = if is_cumul pb then check_leq univs else check_eq univs in match (s0,s1) with | (Prop c1, Prop c2) when is_cumul pb -> begin match c1, c2 with - | Null, _ | _, Pos -> cuniv (* Prop <= Set *) + | Null, _ | _, Pos -> univs (* Prop <= Set *) | _ -> raise NotConvertible end - | (Prop c1, Prop c2) -> - if c1 == c2 then cuniv else raise NotConvertible - | (Prop c1, Type u) when is_cumul pb -> assert (is_univ_variable u); cuniv - | (Type u1, Type u2) -> - assert (is_univ_variable u2); - (match pb with - | CONV -> enforce_eq u1 u2 cuniv - | CUMUL -> enforce_leq u1 u2 cuniv) - | (_, _) -> raise NotConvertible + | (Prop c1, Prop c2) -> if c1 == c2 then univs else raise NotConvertible + | (Prop c1, Type u) -> dir (univ_of_sort s0) u + | (Type u, Prop c) -> dir u (univ_of_sort s1) + | (Type u1, Type u2) -> dir u1 u2 +(* let sort_cmp _ _ _ cuniv = cuniv *) -let conv_sort env s0 s1 = sort_cmp CONV s0 s1 empty_constraint - -let conv_sort_leq env s0 s1 = sort_cmp CUMUL s0 s1 empty_constraint +(* let conv_sort env s0 s1 = sort_cmp CONV s0 s1 empty_constraint *) +(* let conv_sort_leq env s0 s1 = sort_cmp CUMUL s0 s1 empty_constraint *) let rec no_arg_available = function | [] -> true | Zupdate _ :: stk -> no_arg_available stk | Zshift _ :: stk -> no_arg_available stk | Zapp v :: stk -> Int.equal (Array.length v) 0 && no_arg_available stk + | Zproj _ :: _ -> true | Zcase _ :: _ -> true | Zfix _ :: _ -> true @@ -223,6 +281,7 @@ let rec no_nth_arg_available n = function let k = Array.length v in if n >= k then no_nth_arg_available (n-k) stk else false + | Zproj _ :: _ -> true | Zcase _ :: _ -> true | Zfix _ :: _ -> true @@ -231,6 +290,7 @@ let rec no_case_available = function | Zupdate _ :: stk -> no_case_available stk | Zshift _ :: stk -> no_case_available stk | Zapp _ :: stk -> no_case_available stk + | Zproj (_,_,p) :: _ -> false | Zcase _ :: _ -> false | Zfix _ :: _ -> true @@ -241,7 +301,7 @@ let in_whnf (t,stk) = | FConstruct _ -> no_case_available stk | FCoFix _ -> no_case_available stk | FFix(((ri,n),(_,_,_)),_) -> no_nth_arg_available ri.(n) stk - | (FFlex _ | FProd _ | FEvar _ | FInd _ | FAtom _ | FRel _) -> true + | (FFlex _ | FProd _ | FEvar _ | FInd _ | FAtom _ | FRel _ | FProj _) -> true | FLOCKED -> assert false let steps = ref 0 @@ -253,6 +313,15 @@ let slave_process = | _ -> f := (fun () -> false); !f ()) in fun () -> !f () +let unfold_projection infos p c = + if RedFlags.red_set infos.i_flags (RedFlags.fCONST p) then + (match try Some (lookup_projection p (info_env infos)) with Not_found -> None with + | Some pb -> + let s = Zproj (pb.Declarations.proj_npars, pb.Declarations.proj_arg, p) in + Some (c, s) + | None -> None) + else None + (* Conversion between [lft1]term1 and [lft2]term2 *) let rec ccnv cv_pb l2r infos lft1 lft2 term1 term2 cuniv = eqappr cv_pb l2r infos (lft1, (term1,[])) (lft2, (term2,[])) cuniv @@ -266,9 +335,10 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = steps := 0; end; (* First head reduce both terms *) + let whd = whd_stack (infos_with_reds infos betaiotazeta) in let rec whd_both (t1,stk1) (t2,stk2) = - let st1' = whd_stack (snd infos) t1 stk1 in - let st2' = whd_stack (snd infos) t2 stk2 in + let st1' = whd t1 stk1 in + let st2' = whd t2 stk2 in (* Now, whd_stack on term2 might have modified st1 (due to sharing), and st1 might not be in whnf anymore. If so, we iterate ccnv. *) if in_whnf st1' then (st1',st2') else whd_both st1' st2' in @@ -284,7 +354,7 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = | (Sort s1, Sort s2) -> if not (is_empty_stack v1 && is_empty_stack v2) then anomaly (Pp.str "conversion was given ill-typed terms (Sort)"); - sort_cmp cv_pb s1 s2 cuniv + sort_cmp_universes cv_pb s1 s2 cuniv | (Meta n, Meta m) -> if Int.equal n m then convert_stacks l2r infos lft1 lft2 v1 v2 cuniv @@ -292,10 +362,10 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = | _ -> raise NotConvertible) | (FEvar ((ev1,args1),env1), FEvar ((ev2,args2),env2)) -> if Evar.equal ev1 ev2 then - let u1 = convert_stacks l2r infos lft1 lft2 v1 v2 cuniv in + let cuniv = convert_stacks l2r infos lft1 lft2 v1 v2 cuniv in convert_vect l2r infos el1 el2 (Array.map (mk_clos env1) args1) - (Array.map (mk_clos env2) args2) u1 + (Array.map (mk_clos env2) args2) cuniv else raise NotConvertible (* 2 index known to be bound to no constant *) @@ -307,28 +377,59 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = (* 2 constants, 2 local defined vars or 2 defined rels *) | (FFlex fl1, FFlex fl2) -> (try (* try first intensional equality *) - if eq_table_key fl1 fl2 - then convert_stacks l2r infos lft1 lft2 v1 v2 cuniv - else raise NotConvertible + if eq_table_key fl1 fl2 then convert_stacks l2r infos lft1 lft2 v1 v2 cuniv + else + (let cuniv = conv_table_key fl1 fl2 cuniv in + convert_stacks l2r infos lft1 lft2 v1 v2 cuniv) with NotConvertible -> (* else the oracle tells which constant is to be expanded *) let (app1,app2) = - if Conv_oracle.oracle_order (Closure.oracle_of_infos (snd infos)) l2r fl1 fl2 then + if Conv_oracle.oracle_order (Closure.oracle_of_infos infos) l2r (conv_key fl1) (conv_key fl2) then match unfold_reference infos fl1 with - | Some def1 -> ((lft1, whd_stack (snd infos) def1 v1), appr2) + | Some def1 -> ((lft1, whd def1 v1), appr2) | None -> (match unfold_reference infos fl2 with - | Some def2 -> (appr1, (lft2, whd_stack (snd infos) def2 v2)) + | Some def2 -> (appr1, (lft2, whd def2 v2)) | None -> raise NotConvertible) else match unfold_reference infos fl2 with - | Some def2 -> (appr1, (lft2, whd_stack (snd infos) def2 v2)) + | Some def2 -> (appr1, (lft2, whd def2 v2)) | None -> (match unfold_reference infos fl1 with - | Some def1 -> ((lft1, whd_stack (snd infos) def1 v1), appr2) + | Some def1 -> ((lft1, whd def1 v1), appr2) | None -> raise NotConvertible) in eqappr cv_pb l2r infos app1 app2 cuniv) + | (FProj (p1,c1), FProj (p2, c2)) -> + (* Projections: prefer unfolding to first-order unification, + which will happen naturally if the terms c1, c2 are not in constructor + form *) + (match unfold_projection infos p1 c1 with + | Some (def1,s1) -> + eqappr cv_pb l2r infos (lft1, whd def1 (s1 :: v1)) appr2 cuniv + | None -> + match unfold_projection infos p2 c2 with + | Some (def2,s2) -> + eqappr cv_pb l2r infos appr1 (lft2, whd def2 (s2 :: v2)) cuniv + | None -> + if eq_constant p1 p2 && compare_stack_shape v1 v2 then + let u1 = ccnv CONV l2r infos el1 el2 c1 c2 cuniv in + convert_stacks l2r infos lft1 lft2 v1 v2 u1 + else (* Two projections in WHNF: unfold *) + raise NotConvertible) + + | (FProj (p1,c1), t2) -> + (match unfold_projection infos p1 c1 with + | Some (def1,s1) -> + eqappr cv_pb l2r infos (lft1, whd def1 (s1 :: v1)) appr2 cuniv + | None -> raise NotConvertible) + + | (_, FProj (p2,c2)) -> + (match unfold_projection infos p2 c2 with + | Some (def2,s2) -> + eqappr cv_pb l2r infos appr1 (lft2, whd def2 (s2 :: v2)) cuniv + | None -> raise NotConvertible) + (* other constructors *) | (FLambda _, FLambda _) -> (* Inconsistency: we tolerate that v1, v2 contain shift and update but @@ -337,15 +438,15 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = anomaly (Pp.str "conversion was given ill-typed terms (FLambda)"); let (_,ty1,bd1) = destFLambda mk_clos hd1 in let (_,ty2,bd2) = destFLambda mk_clos hd2 in - let u1 = ccnv CONV l2r infos el1 el2 ty1 ty2 cuniv in - ccnv CONV l2r infos (el_lift el1) (el_lift el2) bd1 bd2 u1 + let cuniv = ccnv CONV l2r infos el1 el2 ty1 ty2 cuniv in + ccnv CONV l2r infos (el_lift el1) (el_lift el2) bd1 bd2 cuniv | (FProd (_,c1,c2), FProd (_,c'1,c'2)) -> if not (is_empty_stack v1 && is_empty_stack v2) then anomaly (Pp.str "conversion was given ill-typed terms (FProd)"); (* Luo's system *) - let u1 = ccnv CONV l2r infos el1 el2 c1 c'1 cuniv in - ccnv cv_pb l2r infos (el_lift el1) (el_lift el2) c2 c'2 u1 + let cuniv = ccnv CONV l2r infos el1 el2 c1 c'1 cuniv in + ccnv cv_pb l2r infos (el_lift el1) (el_lift el2) c2 c'2 cuniv (* Eta-expansion on the fly *) | (FLambda _, _) -> @@ -368,30 +469,63 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = (el_lift lft1, (hd1, eta_expand_stack v1)) (el_lift lft2, (bd2, [])) cuniv (* only one constant, defined var or defined rel *) - | (FFlex fl1, _) -> + | (FFlex fl1, c2) -> (match unfold_reference infos fl1 with | Some def1 -> - eqappr cv_pb l2r infos (lft1, whd_stack (snd infos) def1 v1) appr2 cuniv - | None -> raise NotConvertible) - | (_, FFlex fl2) -> + eqappr cv_pb l2r infos (lft1, whd def1 v1) appr2 cuniv + | None -> + match c2 with + | FConstruct ((ind2,j2),u2) -> + (try + let v2, v1 = + eta_expand_ind_stacks (info_env infos) ind2 hd2 v2 (snd appr1) + in convert_stacks l2r infos lft1 lft2 v1 v2 cuniv + with Not_found -> raise NotConvertible) + | _ -> raise NotConvertible) + + | (c1, FFlex fl2) -> (match unfold_reference infos fl2 with | Some def2 -> - eqappr cv_pb l2r infos appr1 (lft2, whd_stack (snd infos) def2 v2) cuniv - | None -> raise NotConvertible) - + eqappr cv_pb l2r infos appr1 (lft2, whd def2 v2) cuniv + | None -> + match c1 with + | FConstruct ((ind1,j1),u1) -> + (try let v1, v2 = + eta_expand_ind_stacks (info_env infos) ind1 hd1 v1 (snd appr2) + in convert_stacks l2r infos lft1 lft2 v1 v2 cuniv + with Not_found -> raise NotConvertible) + | _ -> raise NotConvertible) + (* Inductive types: MutInd MutConstruct Fix Cofix *) - | (FInd ind1, FInd ind2) -> + | (FInd (ind1,u1), FInd (ind2,u2)) -> if eq_ind ind1 ind2 then - convert_stacks l2r infos lft1 lft2 v1 v2 cuniv + (let cuniv = convert_universes cuniv u1 u2 in + convert_stacks l2r infos lft1 lft2 v1 v2 cuniv) else raise NotConvertible - | (FConstruct (ind1,j1), FConstruct (ind2,j2)) -> + | (FConstruct ((ind1,j1),u1), FConstruct ((ind2,j2),u2)) -> if Int.equal j1 j2 && eq_ind ind1 ind2 then - convert_stacks l2r infos lft1 lft2 v1 v2 cuniv + (let cuniv = convert_universes cuniv u1 u2 in + convert_stacks l2r infos lft1 lft2 v1 v2 cuniv) else raise NotConvertible + + (* Eta expansion of records *) + | (FConstruct ((ind1,j1),u1), _) -> + (try + let v1, v2 = + eta_expand_ind_stacks (info_env infos) ind1 hd1 v1 (snd appr2) + in convert_stacks l2r infos lft1 lft2 v1 v2 cuniv + with Not_found -> raise NotConvertible) + + | (_, FConstruct ((ind2,j2),u2)) -> + (try + let v2, v1 = + eta_expand_ind_stacks (info_env infos) ind2 hd2 v2 (snd appr1) + in convert_stacks l2r infos lft1 lft2 v1 v2 cuniv + with Not_found -> raise NotConvertible) | (FFix (((op1, i1),(_,tys1,cl1)),e1), FFix(((op2, i2),(_,tys2,cl2)),e2)) -> if Int.equal i1 i2 && Array.equal Int.equal op1 op2 @@ -401,11 +535,11 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = let fty2 = Array.map (mk_clos e2) tys2 in let fcl1 = Array.map (mk_clos (subs_liftn n e1)) cl1 in let fcl2 = Array.map (mk_clos (subs_liftn n e2)) cl2 in - let u1 = convert_vect l2r infos el1 el2 fty1 fty2 cuniv in - let u2 = + let cuniv = convert_vect l2r infos el1 el2 fty1 fty2 cuniv in + let cuniv = convert_vect l2r infos - (el_liftn n el1) (el_liftn n el2) fcl1 fcl2 u1 in - convert_stacks l2r infos lft1 lft2 v1 v2 u2 + (el_liftn n el1) (el_liftn n el2) fcl1 fcl2 cuniv in + convert_stacks l2r infos lft1 lft2 v1 v2 cuniv else raise NotConvertible | (FCoFix ((op1,(_,tys1,cl1)),e1), FCoFix((op2,(_,tys2,cl2)),e2)) -> @@ -416,11 +550,11 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = let fty2 = Array.map (mk_clos e2) tys2 in let fcl1 = Array.map (mk_clos (subs_liftn n e1)) cl1 in let fcl2 = Array.map (mk_clos (subs_liftn n e2)) cl2 in - let u1 = convert_vect l2r infos el1 el2 fty1 fty2 cuniv in - let u2 = + let cuniv = convert_vect l2r infos el1 el2 fty1 fty2 cuniv in + let cuniv = convert_vect l2r infos - (el_liftn n el1) (el_liftn n el2) fcl1 fcl2 u1 in - convert_stacks l2r infos lft1 lft2 v1 v2 u2 + (el_liftn n el1) (el_liftn n el2) fcl1 fcl2 cuniv in + convert_stacks l2r infos lft1 lft2 v1 v2 cuniv else raise NotConvertible (* Should not happen because both (hd1,v1) and (hd2,v2) are in whnf *) @@ -433,7 +567,7 @@ and eqappr cv_pb l2r infos (lft1,st1) (lft2,st2) cuniv = and convert_stacks l2r infos lft1 lft2 stk1 stk2 cuniv = compare_stacks - (fun (l1,t1) (l2,t2) c -> ccnv CONV l2r infos l1 l2 t1 t2 c) + (fun (l1,t1) (l2,t2) c -> ccnv CONV l2r infos l1 l2 t1 t2 cuniv) (eq_ind) lft1 stk1 lft2 stk2 cuniv @@ -442,26 +576,45 @@ and convert_vect l2r infos lft1 lft2 v1 v2 cuniv = let lv2 = Array.length v2 in if Int.equal lv1 lv2 then - let rec fold n univ = - if n >= lv1 then univ + let rec fold n cuniv = + if n >= lv1 then cuniv else - let u1 = ccnv CONV l2r infos lft1 lft2 v1.(n) v2.(n) univ in - fold (n+1) u1 in + let cuniv = ccnv CONV l2r infos lft1 lft2 v1.(n) v2.(n) cuniv in + fold (n+1) cuniv in fold 0 cuniv else raise NotConvertible -let clos_fconv trans cv_pb l2r evars env t1 t2 = - let infos = trans, create_clos_infos ~evars betaiotazeta env in - ccnv cv_pb l2r infos el_id el_id (inject t1) (inject t2) empty_constraint +let clos_fconv trans cv_pb l2r evars env univs t1 t2 = + let reds = Closure.RedFlags.red_add_transparent betaiotazeta trans in + let infos = create_clos_infos ~evars reds env in + ccnv cv_pb l2r infos el_id el_id (inject t1) (inject t2) univs -let trans_fconv reds cv_pb l2r evars env t1 t2 = - if eq_constr t1 t2 then empty_constraint - else clos_fconv reds cv_pb l2r evars env t1 t2 +let trans_fconv_universes reds cv_pb l2r evars env univs t1 t2 = + let b = + if cv_pb = CUMUL then leq_constr_univs univs t1 t2 + else eq_constr_univs univs t1 t2 + in + if b then () + else + let _ = clos_fconv reds cv_pb l2r evars env (univs, None) t1 t2 in + () + +(* Profiling *) +(* let trans_fconv_universes_key = Profile.declare_profile "trans_fconv_universes" *) +(* let trans_fconv_universes = Profile.profile8 trans_fconv_universes_key trans_fconv_universes *) + +let trans_fconv reds cv_pb l2r evars env = + trans_fconv_universes reds cv_pb l2r evars env (universes env) let trans_conv_cmp ?(l2r=false) conv reds = trans_fconv reds conv l2r (fun _->None) let trans_conv ?(l2r=false) ?(evars=fun _->None) reds = trans_fconv reds CONV l2r evars let trans_conv_leq ?(l2r=false) ?(evars=fun _->None) reds = trans_fconv reds CUMUL l2r evars +let trans_conv_universes ?(l2r=false) ?(evars=fun _->None) reds = + trans_fconv_universes reds CONV l2r evars +let trans_conv_leq_universes ?(l2r=false) ?(evars=fun _->None) reds = + trans_fconv_universes reds CUMUL l2r evars + let fconv = trans_fconv (Id.Pred.full, Cpred.full) let conv_cmp ?(l2r=false) cv_pb = fconv cv_pb l2r (fun _->None) @@ -470,22 +623,43 @@ let conv_leq ?(l2r=false) ?(evars=fun _->None) = fconv CUMUL l2r evars let conv_leq_vecti ?(l2r=false) ?(evars=fun _->None) env v1 v2 = Array.fold_left2_i - (fun i c t1 t2 -> - let c' = - try conv_leq ~l2r ~evars env t1 t2 - with NotConvertible -> raise (NotConvertibleVect i) in - union_constraints c c') - empty_constraint + (fun i _ t1 t2 -> + try conv_leq ~l2r ~evars env t1 t2 + with NotConvertible -> raise (NotConvertibleVect i)) + () v1 v2 +let infer_conv_universes cv_pb l2r evars reds env univs t1 t2 = + let b = + if cv_pb = CUMUL then leq_constr_univs univs t1 t2 + else eq_constr_univs univs t1 t2 + in + if b then Constraint.empty + else + let (u, cstrs) = + clos_fconv reds cv_pb l2r evars env (univs, Some Constraint.empty) t1 t2 + in Option.get cstrs + +(* Profiling *) +(* let infer_conv_universes_key = Profile.declare_profile "infer_conv_universes" *) +(* let infer_conv_universes = Profile.profile8 infer_conv_universes_key infer_conv_universes *) + +let infer_conv ?(l2r=false) ?(evars=fun _ -> None) ?(ts=full_transparent_state) + env univs t1 t2 = + infer_conv_universes CONV l2r evars ts env univs t1 t2 + +let infer_conv_leq ?(l2r=false) ?(evars=fun _ -> None) ?(ts=full_transparent_state) + env univs t1 t2 = + infer_conv_universes CUMUL l2r evars ts env univs t1 t2 + (* option for conversion *) let nat_conv = ref (fun cv_pb sigma -> fconv cv_pb false (sigma.Nativelambda.evars_val)) let set_nat_conv f = nat_conv := f let native_conv cv_pb sigma env t1 t2 = - if eq_constr t1 t2 then empty_constraint + if eq_constr t1 t2 then () else begin let t1 = (it_mkLambda_or_LetIn t1 (rel_context env)) in let t2 = (it_mkLambda_or_LetIn t2 (rel_context env)) in diff --git a/kernel/reduction.mli b/kernel/reduction.mli index 7c0607cc4..b9bd41f28 100644 --- a/kernel/reduction.mli +++ b/kernel/reduction.mli @@ -13,28 +13,39 @@ open Environ (*********************************************************************** s Reduction functions *) -val whd_betaiotazeta : constr -> constr +val whd_betaiotazeta : env -> constr -> constr val whd_betadeltaiota : env -> constr -> constr val whd_betadeltaiota_nolet : env -> constr -> constr -val whd_betaiota : constr -> constr -val nf_betaiota : constr -> constr +val whd_betaiota : env -> constr -> constr +val nf_betaiota : env -> constr -> constr (*********************************************************************** s conversion functions *) exception NotConvertible exception NotConvertibleVect of int -type 'a conversion_function = env -> 'a -> 'a -> Univ.constraints -type 'a trans_conversion_function = Names.transparent_state -> env -> 'a -> 'a -> Univ.constraints + +type conv_universes = Univ.universes * Univ.constraints option + +type 'a conversion_function = env -> 'a -> 'a -> unit +type 'a trans_conversion_function = Names.transparent_state -> 'a conversion_function +type 'a universe_conversion_function = env -> Univ.universes -> 'a -> 'a -> unit +type 'a trans_universe_conversion_function = + Names.transparent_state -> 'a universe_conversion_function + +type 'a infer_conversion_function = env -> Univ.universes -> 'a -> 'a -> Univ.constraints type conv_pb = CONV | CUMUL -val sort_cmp : - conv_pb -> sorts -> sorts -> Univ.constraints -> Univ.constraints +val sort_cmp_universes : + conv_pb -> sorts -> sorts -> conv_universes -> conv_universes -val conv_sort : sorts conversion_function -val conv_sort_leq : sorts conversion_function +(* val sort_cmp : *) +(* conv_pb -> sorts -> sorts -> Univ.constraints -> Univ.constraints *) + +(* val conv_sort : sorts conversion_function *) +(* val conv_sort_leq : sorts conversion_function *) val trans_conv_cmp : ?l2r:bool -> conv_pb -> constr trans_conversion_function val trans_conv : @@ -42,6 +53,11 @@ val trans_conv : val trans_conv_leq : ?l2r:bool -> ?evars:(existential->constr option) -> types trans_conversion_function +val trans_conv_universes : + ?l2r:bool -> ?evars:(existential->constr option) -> constr trans_universe_conversion_function +val trans_conv_leq_universes : + ?l2r:bool -> ?evars:(existential->constr option) -> types trans_universe_conversion_function + val conv_cmp : ?l2r:bool -> conv_pb -> constr conversion_function val conv : ?l2r:bool -> ?evars:(existential->constr option) -> constr conversion_function @@ -50,6 +66,11 @@ val conv_leq : val conv_leq_vecti : ?l2r:bool -> ?evars:(existential->constr option) -> types array conversion_function +val infer_conv : ?l2r:bool -> ?evars:(existential->constr option) -> + ?ts:Names.transparent_state -> constr infer_conversion_function +val infer_conv_leq : ?l2r:bool -> ?evars:(existential->constr option) -> + ?ts:Names.transparent_state -> types infer_conversion_function + (** option for conversion *) val set_vm_conv : (conv_pb -> types conversion_function) -> unit val vm_conv : conv_pb -> types conversion_function diff --git a/kernel/safe_typing.ml b/kernel/safe_typing.ml index c89766fb9..093797fc0 100644 --- a/kernel/safe_typing.ml +++ b/kernel/safe_typing.ml @@ -139,7 +139,7 @@ let empty_environment = modlabels = Label.Set.empty; objlabels = Label.Set.empty; future_cst = []; - univ = Univ.empty_constraint; + univ = Univ.Constraint.empty; engagement = None; imports = []; loads = []; @@ -197,7 +197,10 @@ let add_constraints cst senv = | Now cst -> { senv with env = Environ.add_constraints cst senv.env; - univ = Univ.union_constraints cst senv.univ } + univ = Univ.Constraint.union cst senv.univ } + +let push_context_set ctx = add_constraints (Now (Univ.ContextSet.constraints ctx)) +let push_context ctx = add_constraints (Now (Univ.UContext.constraints ctx)) let is_curmod_library senv = match senv.modvariant with LIBRARY -> true | _ -> false @@ -291,22 +294,22 @@ let safe_push_named (id,_,_ as d) env = with Not_found -> () in Environ.push_named d env + let push_named_def (id,de) senv = - let (c,typ,cst) = Term_typing.translate_local_def senv.env id de in - let c,cst' = match c with - | Def c -> Mod_subst.force_constr c, Univ.empty_constraint - | OpaqueDef o -> Opaqueproof.force_proof o, Opaqueproof.force_constraints o + let c,typ,univs = Term_typing.translate_local_def senv.env id de in + let c = match c with + | Def c -> Mod_subst.force_constr c + | OpaqueDef o -> Opaqueproof.force_proof o | _ -> assert false in - let senv = add_constraints (Now cst') senv in - let senv' = add_constraints (Now cst) senv in + let senv' = push_context de.Entries.const_entry_universes senv in let env'' = safe_push_named (id,Some c,typ) senv'.env in - (Univ.union_constraints cst cst', {senv' with env=env''}) + {senv' with env=env''} -let push_named_assum (id,t) senv = - let (t,cst) = Term_typing.translate_local_assum senv.env t in - let senv' = add_constraints (Now cst) senv in +let push_named_assum ((id,t),ctx) senv = + let senv' = push_context_set ctx senv in + let t = Term_typing.translate_local_assum senv'.env t in let env'' = safe_push_named (id,None,t) senv'.env in - (cst, {senv' with env=env''}) + {senv' with env=env''} (** {6 Insertion of new declarations to current environment } *) @@ -324,20 +327,35 @@ let labels_of_mib mib = Array.iter visit_mip mib.mind_packets; get () -let constraints_of_sfb = function - | SFBmind mib -> [Now mib.mind_constraints] - | SFBmodtype mtb -> [Now mtb.typ_constraints] - | SFBmodule mb -> [Now mb.mod_constraints] - | SFBconst cb -> [Now cb.const_constraints] @ - match cb.const_body with - | (Undef _ | Def _) -> [] - | OpaqueDef lc -> - match Opaqueproof.get_constraints lc with - | None -> [] - | Some fc -> - match Future.peek_val fc with - | None -> [Later fc] - | Some c -> [Now c] +let globalize_constant_universes cb = + if cb.const_polymorphic then + Now Univ.Constraint.empty + else + (match Future.peek_val cb.const_universes with + | Some c -> Now (Univ.UContext.constraints c) + | None -> Later (Future.chain ~pure:true cb.const_universes Univ.UContext.constraints)) + +let globalize_mind_universes mb = + if mb.mind_polymorphic then + Now Univ.Constraint.empty + else + Now (Univ.UContext.constraints mb.mind_universes) + +let constraints_of_sfb sfb = + match sfb with + | SFBconst cb -> globalize_constant_universes cb + | SFBmind mib -> globalize_mind_universes mib + | SFBmodtype mtb -> Now mtb.typ_constraints + | SFBmodule mb -> Now mb.mod_constraints + +(* let add_constraints cst senv = *) +(* { senv with *) +(* env = Environ.add_constraints cst senv.env; *) +(* univ = Univ.Constraint.union cst senv.univ } *) + +(* let next_universe senv = *) +(* let univ = senv.max_univ in *) +(* univ + 1, { senv with max_univ = univ + 1 } *) (** A generic function for adding a new field in a same environment. It also performs the corresponding [add_constraints]. *) @@ -358,7 +376,8 @@ let add_field ((l,sfb) as field) gn senv = | SFBmodule _ | SFBmodtype _ -> check_modlabel l senv; (Label.Set.singleton l, Label.Set.empty) in - let senv = List.fold_right add_constraints (constraints_of_sfb sfb) senv in + let cst = constraints_of_sfb sfb in + let senv = add_constraints cst senv in let env' = match sfb, gn with | SFBconst cb, C con -> Environ.add_constant con cb senv.env | SFBmind mib, I mind -> Environ.add_mind mind mib senv.env @@ -377,7 +396,6 @@ let add_field ((l,sfb) as field) gn senv = let update_resolver f senv = { senv with modresolver = f senv.modresolver } (** Insertion of constants and parameters in environment *) - type global_declaration = | ConstantEntry of Entries.constant_entry | GlobalRecipe of Cooking.recipe @@ -548,8 +566,8 @@ let propagate_senv newdef newenv newresolver senv oldsenv = modlabels = Label.Set.add (fst newdef) oldsenv.modlabels; univ = List.fold_left (fun acc cst -> - Univ.union_constraints acc (Future.force cst)) - (Univ.union_constraints senv.univ oldsenv.univ) + Univ.Constraint.union acc (Future.force cst)) + (Univ.Constraint.union senv.univ oldsenv.univ) now_cst; future_cst = later_cst @ oldsenv.future_cst; (* engagement is propagated to the upper level *) @@ -571,7 +589,7 @@ let end_module l restype senv = let senv'= propagate_loads { senv with env = newenv; - univ = Univ.union_constraints senv.univ mb.mod_constraints} in + univ = Univ.Constraint.union senv.univ mb.mod_constraints} in let newenv = Environ.add_constraints mb.mod_constraints senv'.env in let newenv = Modops.add_module mb newenv in let newresolver = @@ -637,7 +655,7 @@ let add_include me is_module inl senv = { typ_mp = mp_sup; typ_expr = NoFunctor (List.rev senv.revstruct); typ_expr_alg = None; - typ_constraints = Univ.empty_constraint; + typ_constraints = Univ.Constraint.empty; typ_delta = senv.modresolver } in compute_sign sign mtb resolver senv in @@ -672,6 +690,10 @@ type compiled_library = { type native_library = Nativecode.global list +(** FIXME: MS: remove?*) +let current_modpath senv = senv.modpath +let current_dirpath senv = Names.ModPath.dp (current_modpath senv) + let start_library dir senv = check_initial senv; assert (not (DirPath.is_empty dir)); @@ -747,10 +769,7 @@ type judgment = Environ.unsafe_judgment let j_val j = j.Environ.uj_val let j_type j = j.Environ.uj_type -let safe_infer senv = Typeops.infer (env_of_senv senv) - -let typing senv = Typeops.typing (env_of_senv senv) - +let typing senv = Typeops.infer (env_of_senv senv) (** {6 Retroknowledge / native compiler } *) diff --git a/kernel/safe_typing.mli b/kernel/safe_typing.mli index d70d7d8be..ad2148ead 100644 --- a/kernel/safe_typing.mli +++ b/kernel/safe_typing.mli @@ -55,9 +55,9 @@ val join_safe_environment : safe_environment -> safe_environment (** Insertion of local declarations (Local or Variables) *) val push_named_assum : - Id.t * Term.types -> Univ.constraints safe_transformer + (Id.t * Term.types) Univ.in_universe_context_set -> safe_transformer0 val push_named_def : - Id.t * Entries.definition_entry -> Univ.constraints safe_transformer + Id.t * Entries.definition_entry -> safe_transformer0 (** Insertion of global axioms or definitions *) @@ -85,10 +85,19 @@ val add_modtype : (** Adding universe constraints *) -val add_constraints : Univ.constraints -> safe_transformer0 +val push_context_set : + Univ.universe_context_set -> safe_transformer0 -(** Setting the Set-impredicative engagement *) +val push_context : + Univ.universe_context -> safe_transformer0 +val add_constraints : + Univ.constraints -> safe_transformer0 + +(* (\** Generator of universes *\) *) +(* val next_universe : int safe_transformer *) + +(** Settin the strongly constructive or classical logical engagement *) val set_engagement : Declarations.engagement -> safe_transformer0 (** {6 Interactive module functions } *) @@ -113,6 +122,10 @@ val add_include : Entries.module_struct_entry -> bool -> Declarations.inline -> Mod_subst.delta_resolver safe_transformer +val current_modpath : safe_environment -> module_path + +val current_dirpath : safe_environment -> dir_path + (** {6 Libraries : loading and saving compilation units } *) type compiled_library @@ -137,12 +150,7 @@ type judgment val j_val : judgment -> Term.constr val j_type : judgment -> Term.constr -(** The safe typing of a term returns a typing judgment and some universe - constraints (to be added to the environment for the judgment to - hold). It is guaranteed that the constraints are satisfiable. - *) -val safe_infer : safe_environment -> Term.constr -> judgment * Univ.constraints - +(** The safe typing of a term returns a typing judgment. *) val typing : safe_environment -> Term.constr -> judgment (** {6 Queries } *) @@ -164,4 +172,4 @@ val register : val register_inline : constant -> safe_transformer0 val set_strategy : - safe_environment -> 'a Names.tableKey -> Conv_oracle.level -> safe_environment + safe_environment -> Names.constant Names.tableKey -> Conv_oracle.level -> safe_environment diff --git a/kernel/sorts.ml b/kernel/sorts.ml index 03f1cd265..3ebd06dd8 100644 --- a/kernel/sorts.ml +++ b/kernel/sorts.ml @@ -20,6 +20,16 @@ let prop = Prop Null let set = Prop Pos let type1 = Type type1_univ +let univ_of_sort = function + | Type u -> u + | Prop Pos -> Universe.type0 + | Prop Null -> Universe.type0m + +let sort_of_univ u = + if is_type0m_univ u then Prop Null + else if is_type0_univ u then Prop Pos + else Type u + let compare s1 s2 = if s1 == s2 then 0 else match s1, s2 with @@ -36,8 +46,16 @@ let compare s1 s2 = let equal s1 s2 = Int.equal (compare s1 s2) 0 let is_prop = function -| Prop Null -> true -| _ -> false + | Prop Null -> true + | _ -> false + +let is_set = function + | Prop Pos -> true + | _ -> false + +let is_small = function + | Prop _ -> true + | Type u -> is_small_univ u let family = function | Prop Null -> InProp @@ -56,7 +74,7 @@ let hash = function in combinesmall 1 h | Type u -> - let h = Universe.hash u in + let h = Hashtbl.hash u in (** FIXME *) combinesmall 2 h module List = struct @@ -70,14 +88,18 @@ module Hsorts = type _t = t type t = _t type u = universe -> universe + let hashcons huniv = function - | Type u -> Type (huniv u) + | Type u as c -> + let u' = huniv u in + if u' == u then c else Type u' | s -> s let equal s1 s2 = match (s1,s2) with | (Prop c1, Prop c2) -> c1 == c2 | (Type u1, Type u2) -> u1 == u2 |_ -> false - let hash = hash + + let hash = Hashtbl.hash (** FIXME *) end) let hcons = Hashcons.simple_hcons Hsorts.generate hcons_univ diff --git a/kernel/sorts.mli b/kernel/sorts.mli index 2750145f1..ff7d138d6 100644 --- a/kernel/sorts.mli +++ b/kernel/sorts.mli @@ -24,7 +24,9 @@ val equal : t -> t -> bool val compare : t -> t -> int val hash : t -> int +val is_set : t -> bool val is_prop : t -> bool +val is_small : t -> bool val family : t -> family val hcons : t -> t @@ -35,3 +37,6 @@ module List : sig val mem : family -> family list -> bool val intersect : family list -> family list -> family list end + +val univ_of_sort : t -> Univ.universe +val sort_of_univ : Univ.universe -> t diff --git a/kernel/subtyping.ml b/kernel/subtyping.ml index af4468981..2c093939a 100644 --- a/kernel/subtyping.ml +++ b/kernel/subtyping.ml @@ -80,10 +80,8 @@ let make_labmap mp list = let check_conv_error error why cst f env a1 a2 = - try - union_constraints cst (f env a1 a2) - with - NotConvertible -> error why + try Constraint.union cst (f env (Environ.universes env) a1 a2) + with NotConvertible -> error why (* for now we do not allow reorderings *) @@ -94,10 +92,15 @@ let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2 let check_conv why cst f = check_conv_error error why cst f in let mib1 = match info1 with - | IndType ((_,0), mib) -> Declareops.subst_mind subst1 mib + | IndType ((_,0), mib) -> Declareops.subst_mind_body subst1 mib | _ -> error (InductiveFieldExpected mib2) in - let mib2 = Declareops.subst_mind subst2 mib2 in + let u = + if mib1.mind_polymorphic then + UContext.instance mib1.mind_universes + else Instance.empty + in + let mib2 = Declareops.subst_mind_body subst2 mib2 in let check_inductive_type cst name env t1 t2 = (* Due to sort-polymorphism in inductive types, the conclusions of @@ -131,7 +134,7 @@ let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2 error (NotConvertibleInductiveField name) | _ -> (s1, s2) in check_conv (NotConvertibleInductiveField name) - cst conv_leq env (mkArity (ctx1,s1)) (mkArity (ctx2,s2)) + cst infer_conv_leq env (mkArity (ctx1,s1)) (mkArity (ctx2,s2)) in let check_packet cst p1 p2 = @@ -149,18 +152,20 @@ let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2 (* nparams done *) (* params_ctxt done because part of the inductive types *) (* Don't check the sort of the type if polymorphic *) - let cst = check_inductive_type cst p2.mind_typename env (type_of_inductive env (mib1,p1)) (type_of_inductive env (mib2,p2)) - in + let ty1, cst1 = constrained_type_of_inductive env ((mib1,p1),u) in + let ty2, cst2 = constrained_type_of_inductive env ((mib2,p2),u) in + let cst = Constraint.union cst1 (Constraint.union cst2 cst) in + let cst = check_inductive_type cst p2.mind_typename env ty1 ty2 in cst in let mind = mind_of_kn kn1 in let check_cons_types i cst p1 p2 = Array.fold_left3 - (fun cst id t1 t2 -> check_conv (NotConvertibleConstructorField id) cst conv env t1 t2) + (fun cst id t1 t2 -> check_conv (NotConvertibleConstructorField id) cst infer_conv env t1 t2) cst p2.mind_consnames - (arities_of_specif mind (mib1,p1)) - (arities_of_specif mind (mib2,p2)) + (arities_of_specif (mind,u) (mib1,p1)) + (arities_of_specif (mind,u) (mib2,p2)) in let check f test why = if not (test (f mib1) (f mib2)) then error (why (f mib2)) in check (fun mib -> mib.mind_finite) (==) (fun x -> FiniteInductiveFieldExpected x); @@ -180,13 +185,13 @@ let check_inductive cst env mp1 l info1 mp2 mib2 spec2 subst1 subst2 reso1 reso2 let kn2' = kn_of_delta reso2 kn2 in if KerName.equal kn2 kn2' || MutInd.equal (mind_of_delta_kn reso1 kn1) - (subst_ind subst2 (MutInd.make kn2 kn2')) + (subst_mind subst2 (MutInd.make kn2 kn2')) then () else error NotEqualInductiveAliases end; (* we check that records and their field names are preserved. *) - check (fun mib -> mib.mind_record) (==) (fun x -> RecordFieldExpected x); - if mib1.mind_record then begin + check (fun mib -> mib.mind_record <> None) (==) (fun x -> RecordFieldExpected x); + if mib1.mind_record <> None then begin let rec names_prod_letin t = match kind_of_term t with | Prod(n,_,t) -> n::(names_prod_letin t) | LetIn(n,_,_,t) -> n::(names_prod_letin t) @@ -264,17 +269,16 @@ let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 = t1,t2 else (t1,t2) in - check_conv err cst conv_leq env t1 t2 + check_conv err cst infer_conv_leq env t1 t2 in - match info1 with | Constant cb1 -> let () = assert (List.is_empty cb1.const_hyps && List.is_empty cb2.const_hyps) in let cb1 = Declareops.subst_const_body subst1 cb1 in let cb2 = Declareops.subst_const_body subst2 cb2 in (* Start by checking types*) - let typ1 = Typeops.type_of_constant_type env cb1.const_type in - let typ2 = Typeops.type_of_constant_type env cb2.const_type in + let typ1 = cb1.const_type in + let typ2 = cb2.const_type in let cst = check_type cst env typ1 typ2 in (* Now we check the bodies: - A transparent constant can only be implemented by a compatible @@ -292,7 +296,7 @@ let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 = Anyway [check_conv] will handle that afterwards. *) let c1 = Mod_subst.force_constr lc1 in let c2 = Mod_subst.force_constr lc2 in - check_conv NotConvertibleBodyField cst conv env c1 c2)) + check_conv NotConvertibleBodyField cst infer_conv env c1 c2)) | IndType ((kn,i),mind1) -> ignore (Errors.error ( "The kernel does not recognize yet that a parameter can be " ^ @@ -301,10 +305,14 @@ let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 = "name.")); let () = assert (List.is_empty mind1.mind_hyps && List.is_empty cb2.const_hyps) in if Declareops.constant_has_body cb2 then error DefinitionFieldExpected; - let arity1 = type_of_inductive env (mind1,mind1.mind_packets.(i)) in - let typ2 = Typeops.type_of_constant_type env cb2.const_type in + let u1 = inductive_instance mind1 in + let arity1,cst1 = constrained_type_of_inductive env + ((mind1,mind1.mind_packets.(i)),u1) in + let cst2 = UContext.constraints (Future.force cb2.const_universes) in + let typ2 = cb2.const_type in + let cst = Constraint.union cst (Constraint.union cst1 cst2) in let error = NotConvertibleTypeField (env, arity1, typ2) in - check_conv error cst conv_leq env arity1 typ2 + check_conv error cst infer_conv_leq env arity1 typ2 | IndConstr (((kn,i),j) as cstr,mind1) -> ignore (Errors.error ( "The kernel does not recognize yet that a parameter can be " ^ @@ -313,10 +321,13 @@ let check_constant cst env mp1 l info1 cb2 spec2 subst1 subst2 = "name.")); let () = assert (List.is_empty mind1.mind_hyps && List.is_empty cb2.const_hyps) in if Declareops.constant_has_body cb2 then error DefinitionFieldExpected; - let ty1 = type_of_constructor cstr (mind1,mind1.mind_packets.(i)) in - let ty2 = Typeops.type_of_constant_type env cb2.const_type in + let u1 = inductive_instance mind1 in + let ty1,cst1 = constrained_type_of_constructor (cstr,u1) (mind1,mind1.mind_packets.(i)) in + let cst2 = UContext.constraints (Future.force cb2.const_universes) in + let ty2 = cb2.const_type in + let cst = Constraint.union cst (Constraint.union cst1 cst2) in let error = NotConvertibleTypeField (env, ty1, ty2) in - check_conv error cst conv env ty1 ty2 + check_conv error cst infer_conv env ty1 ty2 let rec check_modules cst env msb1 msb2 subst1 subst2 = let mty1 = module_type_of_module msb1 in @@ -368,7 +379,7 @@ and check_modtypes cst env mtb1 mtb2 subst1 subst2 equiv = mtb2.typ_mp list2 mtb1.typ_mp list1 subst2 subst1 mtb2.typ_delta mtb1.typ_delta in - Univ.union_constraints cst1 cst2 + Univ.Constraint.union cst1 cst2 else check_signatures cst env mtb1.typ_mp list1 mtb2.typ_mp list2 subst1 subst2 @@ -398,7 +409,7 @@ and check_modtypes cst env mtb1 mtb2 subst1 subst2 equiv = let check_subtypes env sup super = let env = add_module_type sup.typ_mp sup env in - check_modtypes empty_constraint env + check_modtypes Univ.Constraint.empty env (strengthen sup sup.typ_mp) super empty_subst (map_mp super.typ_mp sup.typ_mp sup.typ_delta) false diff --git a/kernel/term.ml b/kernel/term.ml index 24fe6d962..b85c525d1 100644 --- a/kernel/term.ml +++ b/kernel/term.ml @@ -32,7 +32,6 @@ type types = Constr.t (** Same as [constr], for documentation purposes. *) type existential_key = Constr.existential_key - type existential = Constr.existential type metavariable = Constr.metavariable @@ -54,6 +53,10 @@ type case_info = Constr.case_info = type cast_kind = Constr.cast_kind = VMcast | NATIVEcast | DEFAULTcast | REVERTcast +(********************************************************************) +(* Constructions as implemented *) +(********************************************************************) + type rec_declaration = Constr.rec_declaration type fixpoint = Constr.fixpoint type cofixpoint = Constr.cofixpoint @@ -62,6 +65,12 @@ type ('constr, 'types) prec_declaration = ('constr, 'types) Constr.prec_declaration type ('constr, 'types) pfixpoint = ('constr, 'types) Constr.pfixpoint type ('constr, 'types) pcofixpoint = ('constr, 'types) Constr.pcofixpoint +type 'a puniverses = 'a Univ.puniverses + +(** Simply type aliases *) +type pconstant = constant puniverses +type pinductive = inductive puniverses +type pconstructor = constructor puniverses type ('constr, 'types) kind_of_term = ('constr, 'types) Constr.kind_of_term = | Rel of int @@ -74,12 +83,13 @@ type ('constr, 'types) kind_of_term = ('constr, 'types) Constr.kind_of_term = | Lambda of Name.t * 'types * 'constr | LetIn of Name.t * 'constr * 'types * 'constr | App of 'constr * 'constr array - | Const of constant - | Ind of inductive - | Construct of constructor + | Const of pconstant + | Ind of pinductive + | Construct of pconstructor | Case of case_info * 'constr * 'constr * 'constr array | Fix of ('constr, 'types) pfixpoint | CoFix of ('constr, 'types) pcofixpoint + | Proj of constant * 'constr type values = Constr.values @@ -93,6 +103,8 @@ let type1_sort = Sorts.type1 let sorts_ord = Sorts.compare let is_prop_sort = Sorts.is_prop let family_of_sort = Sorts.family +let univ_of_sort = Sorts.univ_of_sort +let sort_of_univ = Sorts.sort_of_univ (** {6 Term constructors. } *) @@ -110,8 +122,13 @@ let mkLambda = Constr.mkLambda let mkLetIn = Constr.mkLetIn let mkApp = Constr.mkApp let mkConst = Constr.mkConst +let mkProj = Constr.mkProj let mkInd = Constr.mkInd let mkConstruct = Constr.mkConstruct +let mkConstU = Constr.mkConstU +let mkIndU = Constr.mkIndU +let mkConstructU = Constr.mkConstructU +let mkConstructUi = Constr.mkConstructUi let mkCase = Constr.mkCase let mkFix = Constr.mkFix let mkCoFix = Constr.mkCoFix @@ -121,9 +138,16 @@ let mkCoFix = Constr.mkCoFix (**********************************************************************) let eq_constr = Constr.equal +let eq_constr_univs = Constr.eq_constr_univs +let leq_constr_univs = Constr.leq_constr_univs +let eq_constr_universes = Constr.eq_constr_universes +let leq_constr_universes = Constr.leq_constr_universes +let eq_constr_nounivs = Constr.eq_constr_nounivs + let kind_of_term = Constr.kind let constr_ord = Constr.compare let fold_constr = Constr.fold +let map_puniverses = Constr.map_puniverses let map_constr = Constr.map let map_constr_with_binders = Constr.map_with_binders let iter_constr = Constr.iter @@ -195,9 +219,7 @@ let rec is_Type c = match kind_of_term c with | Cast (c,_,_) -> is_Type c | _ -> false -let is_small = function - | Prop _ -> true - | _ -> false +let is_small = Sorts.is_small let iskind c = isprop c || is_Type c @@ -649,6 +671,7 @@ let kind_of_type t = match kind_of_term t with | Prod (na,t,c) -> ProdType (na, t, c) | LetIn (na,b,t,c) -> LetInType (na, b, t, c) | App (c,l) -> AtomicType (c, l) - | (Rel _ | Meta _ | Var _ | Evar _ | Const _ | Case _ | Fix _ | CoFix _ | Ind _) + | (Rel _ | Meta _ | Var _ | Evar _ | Const _ + | Proj _ | Case _ | Fix _ | CoFix _ | Ind _) -> AtomicType (t,[||]) | (Lambda _ | Construct _) -> failwith "Not a type" diff --git a/kernel/term.mli b/kernel/term.mli index f2f5e8495..2d3df6e1e 100644 --- a/kernel/term.mli +++ b/kernel/term.mli @@ -24,6 +24,13 @@ type sorts = Sorts.t = type sorts_family = Sorts.family = InProp | InSet | InType +type 'a puniverses = 'a Univ.puniverses + +(** Simply type aliases *) +type pconstant = constant puniverses +type pinductive = inductive puniverses +type pconstructor = constructor puniverses + type constr = Constr.constr (** Alias types, for compatibility. *) @@ -73,12 +80,13 @@ type ('constr, 'types) kind_of_term = ('constr, 'types) Constr.kind_of_term = | Lambda of Name.t * 'types * 'constr | LetIn of Name.t * 'constr * 'types * 'constr | App of 'constr * 'constr array - | Const of constant - | Ind of inductive - | Construct of constructor + | Const of constant puniverses + | Ind of inductive puniverses + | Construct of constructor puniverses | Case of case_info * 'constr * 'constr * 'constr array | Fix of ('constr, 'types) pfixpoint | CoFix of ('constr, 'types) pcofixpoint + | Proj of constant * 'constr type values = Constr.values @@ -157,16 +165,16 @@ val decompose_app : constr -> constr * constr list val decompose_appvect : constr -> constr * constr array (** Destructs a constant *) -val destConst : constr -> constant +val destConst : constr -> constant puniverses (** Destructs an existential variable *) val destEvar : constr -> existential (** Destructs a (co)inductive type *) -val destInd : constr -> inductive +val destInd : constr -> inductive puniverses (** Destructs a constructor *) -val destConstruct : constr -> constructor +val destConstruct : constr -> constructor puniverses (** Destructs a [match c as x in I args return P with ... | Ci(...yij...) => ti | ... end] (or [let (..y1i..) := c as x in I args @@ -397,8 +405,13 @@ val mkLambda : Name.t * types * constr -> constr val mkLetIn : Name.t * constr * types * constr -> constr val mkApp : constr * constr array -> constr val mkConst : constant -> constr +val mkProj : (constant * constr) -> constr val mkInd : inductive -> constr val mkConstruct : constructor -> constr +val mkConstU : constant puniverses -> constr +val mkIndU : inductive puniverses -> constr +val mkConstructU : constructor puniverses -> constr +val mkConstructUi : (pinductive * int) -> constr val mkCase : case_info * constr * constr * constr array -> constr val mkFix : fixpoint -> constr val mkCoFix : cofixpoint -> constr @@ -408,6 +421,26 @@ val mkCoFix : cofixpoint -> constr val eq_constr : constr -> constr -> bool (** Alias for [Constr.equal] *) +(** [eq_constr_univs a b] [true, c] if [a] equals [b] modulo alpha, casts, + application grouping and the universe equalities in [c]. *) +val eq_constr_univs : constr Univ.check_function + +(** [leq_constr_univs a b] [true, c] if [a] is convertible to [b] modulo + alpha, casts, application grouping and the universe inequalities in [c]. *) +val leq_constr_univs : constr Univ.check_function + +(** [eq_constr_universes a b] [true, c] if [a] equals [b] modulo alpha, casts, + application grouping and the universe equalities in [c]. *) +val eq_constr_universes : constr -> constr -> bool Univ.universe_constrained + +(** [leq_constr_universes a b] [true, c] if [a] is convertible to [b] modulo + alpha, casts, application grouping and the universe inequalities in [c]. *) +val leq_constr_universes : constr -> constr -> bool Univ.universe_constrained + +(** [eq_constr_univs a b] [true, c] if [a] equals [b] modulo alpha, casts, + application grouping and ignoring universe instances. *) +val eq_constr_nounivs : constr -> constr -> bool + val kind_of_term : constr -> (constr, types) kind_of_term (** Alias for [Constr.kind] *) @@ -424,6 +457,10 @@ val map_constr_with_binders : ('a -> 'a) -> ('a -> constr -> constr) -> 'a -> constr -> constr (** Alias for [Constr.map_with_binders] *) +val map_puniverses : ('a -> 'b) -> 'a puniverses -> 'b puniverses +val univ_of_sort : sorts -> Univ.universe +val sort_of_univ : Univ.universe -> sorts + val iter_constr : (constr -> unit) -> constr -> unit (** Alias for [Constr.iter] *) @@ -437,6 +474,8 @@ val compare_constr : (constr -> constr -> bool) -> constr -> constr -> bool val hash_constr : constr -> int (** Alias for [Constr.hash] *) +(*********************************************************************) + val hcons_sorts : sorts -> sorts (** Alias for [Constr.hashcons_sorts] *) diff --git a/kernel/term_typing.ml b/kernel/term_typing.ml index a084504dc..9aa688fc7 100644 --- a/kernel/term_typing.ml +++ b/kernel/term_typing.ml @@ -22,29 +22,35 @@ open Declarations open Environ open Entries open Typeops +open Fast_typeops -let constrain_type env j cst1 = function - | `None -> - make_polymorphic_if_constant_for_ind env j, cst1 +let debug = false +let prerr_endline = + if debug then prerr_endline else fun _ -> () + +let constrain_type env j poly = function + | `None -> j.uj_type | `Some t -> - let (tj,cst2) = infer_type env t in - let (_,cst3) = judge_of_cast env j DEFAULTcast tj in - assert (eq_constr t tj.utj_val); - let cstrs = union_constraints (union_constraints cst1 cst2) cst3 in - NonPolymorphicType t, cstrs - | `SomeWJ (t, tj, cst2) -> - let (_,cst3) = judge_of_cast env j DEFAULTcast tj in - assert (eq_constr t tj.utj_val); - let cstrs = union_constraints (union_constraints cst1 cst2) cst3 in - NonPolymorphicType t, cstrs + let tj = infer_type env t in + let _ = judge_of_cast env j DEFAULTcast tj in + assert (eq_constr t tj.utj_val); + t + | `SomeWJ (t, tj) -> + let tj = infer_type env t in + let _ = judge_of_cast env j DEFAULTcast tj in + assert (eq_constr t tj.utj_val); + t let map_option_typ = function None -> `None | Some x -> `Some x -let translate_local_assum env t = - let (j,cst) = infer env t in - let t = Typeops.assumption_of_judgment env j in - (t,cst) - +let local_constrain_type env j = function + | None -> + j.uj_type + | Some t -> + let tj = infer_type env t in + let _ = judge_of_cast env j DEFAULTcast tj in + assert (eq_constr t tj.utj_val); + t (* Insertion of constants and parameters in environment. *) @@ -59,19 +65,19 @@ let handle_side_effects env body side_eff = if name.[i] == '.' || name.[i] == '#' then name.[i] <- '_' done; Name (id_of_string name) in let rec sub c i x = match kind_of_term x with - | Const c' when eq_constant c c' -> mkRel i + | Const (c', _) when eq_constant c c' -> mkRel i | _ -> map_constr_with_binders ((+) 1) (fun i x -> sub c i x) i x in let fix_body (c,cb) t = match cb.const_body with | Undef _ -> assert false | Def b -> let b = Mod_subst.force_constr b in - let b_ty = Typeops.type_of_constant_type env cb.const_type in + let b_ty = cb.const_type in let t = sub c 1 (Vars.lift 1 t) in mkLetIn (cname c, b, b_ty, t) | OpaqueDef b -> let b = Opaqueproof.force_proof b in - let b_ty = Typeops.type_of_constant_type env cb.const_type in + let b_ty = cb.const_type in let t = sub c 1 (Vars.lift 1 t) in mkApp (mkLambda (cname c, b_ty, t), [|b|]) in List.fold_right fix_body cbl t @@ -86,46 +92,50 @@ let hcons_j j = let feedback_completion_typecheck = Option.iter (fun state_id -> Pp.feedback ~state_id Interface.Complete) -let infer_declaration env dcl = +let infer_declaration env kn dcl = match dcl with - | ParameterEntry (ctx,t,nl) -> - let j, cst = infer env t in + | ParameterEntry (ctx,poly,(t,uctx),nl) -> + let env = push_context uctx env in + let j = infer env t in let t = hcons_constr (Typeops.assumption_of_judgment env j) in - Undef nl, NonPolymorphicType t, cst, false, ctx + Undef nl, t, None, poly, Future.from_val uctx, false, ctx | DefinitionEntry ({ const_entry_type = Some typ; const_entry_opaque = true } as c) -> + let env = push_context c.const_entry_universes env in let { const_entry_body = body; const_entry_feedback = feedback_id } = c in - let tyj, tycst = infer_type env typ in + let tyj = infer_type env typ in let proofterm = Future.chain ~greedy:true ~pure:true body (fun (body, side_eff) -> let body = handle_side_effects env body side_eff in - let j, cst = infer env body in + let j = infer env body in let j = hcons_j j in - let _typ, cst = constrain_type env j cst (`SomeWJ (typ,tyj,tycst)) in + let _typ = constrain_type env j c.const_entry_polymorphic (`SomeWJ (typ,tyj)) in feedback_completion_typecheck feedback_id; - j.uj_val, cst) in + j.uj_val, Univ.empty_constraint) in let def = OpaqueDef (Opaqueproof.create proofterm) in - let typ = NonPolymorphicType typ in - def, typ, tycst, c.const_entry_inline_code, c.const_entry_secctx + def, typ, None, c.const_entry_polymorphic, Future.from_val c.const_entry_universes, + c.const_entry_inline_code, c.const_entry_secctx | DefinitionEntry c -> + let env = push_context c.const_entry_universes env in let { const_entry_type = typ; const_entry_opaque = opaque } = c in let { const_entry_body = body; const_entry_feedback = feedback_id } = c in let body, side_eff = Future.join body in let body = handle_side_effects env body side_eff in - let j, cst = infer env body in + let j = infer env body in let j = hcons_j j in - let typ, cst = constrain_type env j cst (map_option_typ typ) in + let typ = constrain_type env j c.const_entry_polymorphic (map_option_typ typ) in feedback_completion_typecheck feedback_id; let def = Def (Mod_subst.from_val j.uj_val) in - def, typ, cst, c.const_entry_inline_code, c.const_entry_secctx + def, typ, None, c.const_entry_polymorphic, + Future.from_val c.const_entry_universes, c.const_entry_inline_code, c.const_entry_secctx -let global_vars_set_constant_type env = function - | NonPolymorphicType t -> global_vars_set env t - | PolymorphicArity (ctx,_) -> - Context.fold_rel_context - (fold_rel_declaration - (fun t c -> Id.Set.union (global_vars_set env t) c)) - ctx ~init:Id.Set.empty +(* let global_vars_set_constant_type env = function *) +(* | NonPolymorphicType t -> global_vars_set env t *) +(* | PolymorphicArity (ctx,_) -> *) +(* Context.fold_rel_context *) +(* (fold_rel_declaration *) +(* (fun t c -> Id.Set.union (global_vars_set env t) c)) *) +(* ctx ~init:Id.Set.empty *) let record_aux env s1 s2 = let v = @@ -137,7 +147,7 @@ let record_aux env s1 s2 = let suggest_proof_using = ref (fun _ _ _ _ _ -> ()) let set_suggest_proof_using f = suggest_proof_using := f -let build_constant_declaration kn env (def,typ,cst,inline_code,ctx) = +let build_constant_declaration kn env (def,typ,proj,poly,univs,inline_code,ctx) = let check declared inferred = let mk_set l = List.fold_right Id.Set.add (List.map pi1 l) Id.Set.empty in let inferred_set, declared_set = mk_set inferred, mk_set declared in @@ -152,12 +162,14 @@ let build_constant_declaration kn env (def,typ,cst,inline_code,ctx) = | None when not (List.is_empty context_ids) -> (* No declared section vars, and non-empty section context: we must look at the body NOW, if any *) - let ids_typ = global_vars_set_constant_type env typ in + let ids_typ = global_vars_set env typ in let ids_def = match def with | Undef _ -> Idset.empty | Def cs -> global_vars_set env (Mod_subst.force_constr cs) | OpaqueDef lc -> let vars = global_vars_set env (Opaqueproof.force_proof lc) in + (* we force so that cst are added to the env immediately after *) + ignore(Future.join univs); !suggest_proof_using kn env vars ids_typ context_ids; if !Flags.compilation_mode = Flags.BuildVo then record_aux env ids_typ vars; @@ -174,38 +186,50 @@ let build_constant_declaration kn env (def,typ,cst,inline_code,ctx) = match def with | Undef _ as x -> x (* nothing to check *) | Def cs as x -> - let ids_typ = global_vars_set_constant_type env typ in + let ids_typ = global_vars_set env typ in let ids_def = global_vars_set env (Mod_subst.force_constr cs) in let inferred = keep_hyps env (Idset.union ids_typ ids_def) in check declared inferred; x | OpaqueDef lc -> (* In this case we can postpone the check *) OpaqueDef (Opaqueproof.iter_direct_opaque (fun c -> - let ids_typ = global_vars_set_constant_type env typ in + let ids_typ = global_vars_set env typ in let ids_def = global_vars_set env c in let inferred = keep_hyps env (Idset.union ids_typ ids_def) in check declared inferred) lc) in + let tps = + match proj with + | None -> Cemitcodes.from_val (compile_constant_body env def) + | Some pb -> + Cemitcodes.from_val (compile_constant_body env (Def (Mod_subst.from_val pb.proj_body))) + in { const_hyps = hyps; const_body = def; const_type = typ; - const_body_code = Cemitcodes.from_val (compile_constant_body env def); - const_constraints = cst; + const_proj = proj; + const_body_code = tps; + const_polymorphic = poly; + const_universes = univs; const_inline_code = inline_code } + (*s Global and local constant declaration. *) let translate_constant env kn ce = - build_constant_declaration kn env (infer_declaration env ce) + build_constant_declaration kn env (infer_declaration env (Some kn) ce) + +let translate_local_assum env t = + let j = infer env t in + let t = Typeops.assumption_of_judgment env j in + t let translate_recipe env kn r = - let def,typ,cst,inline_code,hyps = Cooking.cook_constant env r in - build_constant_declaration kn env (def,typ,cst,inline_code,hyps) + build_constant_declaration kn env (Cooking.cook_constant env r) let translate_local_def env id centry = - let def,typ,cst,inline_code,ctx = - infer_declaration env (DefinitionEntry centry) in - let typ = type_of_constant_type env typ in - def, typ, cst + let def,typ,proj,poly,univs,inline_code,ctx = + infer_declaration env None (DefinitionEntry centry) in + def, typ, univs (* Insertion of inductive types. *) diff --git a/kernel/term_typing.mli b/kernel/term_typing.mli index b1c336ad9..a2a35492e 100644 --- a/kernel/term_typing.mli +++ b/kernel/term_typing.mli @@ -14,9 +14,9 @@ open Declarations open Entries val translate_local_def : env -> Id.t -> definition_entry -> - constant_def * types * Univ.constraints + constant_def * types * constant_universes -val translate_local_assum : env -> types -> types * constraints +val translate_local_assum : env -> types -> types (* returns the same definition_entry but with side effects turned into * let-ins or beta redexes. it is meant to get a term out of a not yet @@ -32,7 +32,9 @@ val translate_recipe : env -> constant -> Cooking.recipe -> constant_body (** Internal functions, mentioned here for debug purpose only *) -val infer_declaration : env -> constant_entry -> Cooking.result +val infer_declaration : env -> constant option -> + constant_entry -> Cooking.result + val build_constant_declaration : constant -> env -> Cooking.result -> constant_body diff --git a/kernel/type_errors.ml b/kernel/type_errors.ml index 42b93dd37..30dcbafe6 100644 --- a/kernel/type_errors.ml +++ b/kernel/type_errors.ml @@ -42,12 +42,12 @@ type type_error = | NotAType of unsafe_judgment | BadAssumption of unsafe_judgment | ReferenceVariables of identifier * constr - | ElimArity of inductive * sorts_family list * constr * unsafe_judgment + | ElimArity of pinductive * sorts_family list * constr * unsafe_judgment * (sorts_family * sorts_family * arity_error) option | CaseNotInductive of unsafe_judgment - | WrongCaseInfo of inductive * case_info + | WrongCaseInfo of pinductive * case_info | NumberBranches of unsafe_judgment * int - | IllFormedBranch of constr * constructor * constr * constr + | IllFormedBranch of constr * pconstructor * constr * constr | Generalization of (Name.t * types) * unsafe_judgment | ActualType of unsafe_judgment * types | CantApplyBadType of @@ -56,11 +56,12 @@ type type_error = | IllFormedRecBody of guard_error * Name.t array * int * env * unsafe_judgment array | IllTypedRecBody of int * Name.t array * unsafe_judgment array * types array + | UnsatisfiedConstraints of Univ.constraints exception TypeError of env * type_error -let nfj {uj_val=c;uj_type=ct} = - {uj_val=c;uj_type=nf_betaiota ct} +let nfj env {uj_val=c;uj_type=ct} = + {uj_val=c;uj_type=nf_betaiota env ct} let error_unbound_rel env n = raise (TypeError (env, UnboundRel n)) @@ -84,11 +85,11 @@ let error_case_not_inductive env j = raise (TypeError (env, CaseNotInductive j)) let error_number_branches env cj expn = - raise (TypeError (env, NumberBranches (nfj cj,expn))) + raise (TypeError (env, NumberBranches (nfj env cj,expn))) let error_ill_formed_branch env c i actty expty = raise (TypeError (env, - IllFormedBranch (c,i,nf_betaiota actty, nf_betaiota expty))) + IllFormedBranch (c,i,nf_betaiota env actty, nf_betaiota env expty))) let error_generalization env nvar c = raise (TypeError (env, Generalization (nvar,c))) @@ -114,3 +115,5 @@ let error_elim_explain kp ki = | InType, InSet -> StrongEliminationOnNonSmallType (* if Set impredicative *) | _ -> WrongArity +let error_unsatisfied_constraints env c = + raise (TypeError (env, UnsatisfiedConstraints c)) diff --git a/kernel/type_errors.mli b/kernel/type_errors.mli index b9d8efbcd..09310b42b 100644 --- a/kernel/type_errors.mli +++ b/kernel/type_errors.mli @@ -43,12 +43,12 @@ type type_error = | NotAType of unsafe_judgment | BadAssumption of unsafe_judgment | ReferenceVariables of identifier * constr - | ElimArity of inductive * sorts_family list * constr * unsafe_judgment + | ElimArity of pinductive * sorts_family list * constr * unsafe_judgment * (sorts_family * sorts_family * arity_error) option | CaseNotInductive of unsafe_judgment - | WrongCaseInfo of inductive * case_info + | WrongCaseInfo of pinductive * case_info | NumberBranches of unsafe_judgment * int - | IllFormedBranch of constr * constructor * constr * constr + | IllFormedBranch of constr * pconstructor * constr * constr | Generalization of (Name.t * types) * unsafe_judgment | ActualType of unsafe_judgment * types | CantApplyBadType of @@ -57,6 +57,7 @@ type type_error = | IllFormedRecBody of guard_error * Name.t array * int * env * unsafe_judgment array | IllTypedRecBody of int * Name.t array * unsafe_judgment array * types array + | UnsatisfiedConstraints of Univ.constraints exception TypeError of env * type_error @@ -71,14 +72,14 @@ val error_assumption : env -> unsafe_judgment -> 'a val error_reference_variables : env -> identifier -> constr -> 'a val error_elim_arity : - env -> inductive -> sorts_family list -> constr -> unsafe_judgment -> + env -> pinductive -> sorts_family list -> constr -> unsafe_judgment -> (sorts_family * sorts_family * arity_error) option -> 'a val error_case_not_inductive : env -> unsafe_judgment -> 'a val error_number_branches : env -> unsafe_judgment -> int -> 'a -val error_ill_formed_branch : env -> constr -> constructor -> constr -> constr -> 'a +val error_ill_formed_branch : env -> constr -> pconstructor -> constr -> constr -> 'a val error_generalization : env -> Name.t * types -> unsafe_judgment -> 'a @@ -98,3 +99,5 @@ val error_ill_typed_rec_body : env -> int -> Name.t array -> unsafe_judgment array -> types array -> 'a val error_elim_explain : sorts_family -> sorts_family -> arity_error + +val error_unsatisfied_constraints : env -> Univ.constraints -> 'a diff --git a/kernel/typeops.ml b/kernel/typeops.ml index 3400d8ce6..09fd4cc7f 100644 --- a/kernel/typeops.ml +++ b/kernel/typeops.ml @@ -20,19 +20,21 @@ open Reduction open Inductive open Type_errors -let conv_leq l2r = default_conv CUMUL ~l2r +let conv_leq l2r env x y = default_conv CUMUL ~l2r env x y let conv_leq_vecti env v1 v2 = Array.fold_left2_i - (fun i c t1 t2 -> - let c' = - try default_conv CUMUL env t1 t2 - with NotConvertible -> raise (NotConvertibleVect i) in - union_constraints c c') - empty_constraint + (fun i _ t1 t2 -> + try conv_leq false env t1 t2 + with NotConvertible -> raise (NotConvertibleVect i)) + () v1 v2 +let check_constraints cst env = + if Environ.check_constraints cst env then () + else error_unsatisfied_constraints env cst + (* This should be a type (a priori without intension to be an assumption) *) let type_judgment env j = match kind_of_term(whd_betadeltaiota env j.uj_type) with @@ -69,9 +71,9 @@ let judge_of_prop_contents = function (* Type of Type(i). *) let judge_of_type u = - let uu = super u in - { uj_val = mkType u; - uj_type = mkType uu } + let uu = Universe.super u in + { uj_val = mkType u; + uj_type = mkType uu } (*s Type of a de Bruijn index. *) @@ -111,53 +113,32 @@ let check_hyps_inclusion env c sign = (* Make a type polymorphic if an arity *) -let extract_level env p = - let _,c = dest_prod_assum env p in - match kind_of_term c with Sort (Type u) -> Some u | _ -> None - -let extract_context_levels env l = - let fold l (_, b, p) = match b with - | None -> extract_level env p :: l - | _ -> l - in - List.fold_left fold [] l - -let make_polymorphic_if_constant_for_ind env {uj_val = c; uj_type = t} = - let params, ccl = dest_prod_assum env t in - match kind_of_term ccl with - | Sort (Type u) when isInd (fst (decompose_app (whd_betadeltaiota env c))) -> - let param_ccls = extract_context_levels env params in - let s = { poly_param_levels = param_ccls; poly_level = u} in - PolymorphicArity (params,s) - | _ -> - NonPolymorphicType t - (* Type of constants *) -let type_of_constant_knowing_parameters env t paramtyps = - match t with - | NonPolymorphicType t -> t - | PolymorphicArity (sign,ar) -> - let ctx = List.rev sign in - let ctx,s = instantiate_universes env ctx ar paramtyps in - mkArity (List.rev ctx,s) - -let type_of_constant_type env t = - type_of_constant_knowing_parameters env t [||] +let type_of_constant env cst = constant_type env cst +let type_of_constant_in env cst = constant_type_in env cst +let type_of_constant_knowing_parameters env t _ = t +let type_of_constant_type env cst = cst -let type_of_constant env cst = - type_of_constant_type env (constant_type env cst) +let judge_of_constant env (kn,u as cst) = + let c = mkConstU cst in + let cb = lookup_constant kn env in + let _ = check_hyps_inclusion env c cb.const_hyps in + let ty, cu = type_of_constant env cst in + let _ = Environ.check_constraints cu env in + (make_judge c ty) -let judge_of_constant_knowing_parameters env cst jl = - let c = mkConst cst in +let type_of_projection env (cst,u) = let cb = lookup_constant cst env in - let _ = check_hyps_inclusion env c cb.const_hyps in - let paramstyp = Array.map (fun j -> lazy j.uj_type) jl in - let t = type_of_constant_knowing_parameters env cb.const_type paramstyp in - make_judge c t + match cb.const_proj with + | Some pb -> + if cb.const_polymorphic then + let mib,_ = lookup_mind_specif env (pb.proj_ind,0) in + let subst = make_inductive_subst mib u in + Vars.subst_univs_constr subst pb.proj_type + else pb.proj_type + | None -> raise (Invalid_argument "type_of_projection: not a projection") -let judge_of_constant env cst = - judge_of_constant_knowing_parameters env cst [||] (* Type of a lambda-abstraction. *) @@ -184,26 +165,27 @@ let judge_of_letin env name defj typj j = (* Type of an application. *) let judge_of_apply env funj argjv = - let len = Array.length argjv in - let rec apply_rec n typ cst = - if len <= n then - { uj_val = mkApp (j_val funj, Array.map j_val argjv); uj_type = typ }, - cst - else - let hj = Array.unsafe_get argjv n in - match kind_of_term (whd_betadeltaiota env typ) with - | Prod (_,c1,c2) -> - let c = - try conv_leq false env hj.uj_type c1 - with NotConvertible -> - error_cant_apply_bad_type env (n + 1, c1, hj.uj_type) funj argjv - in - let cst' = union_constraints cst c in - apply_rec (n+1) (subst1 hj.uj_val c2) cst' - | _ -> - error_cant_apply_not_functional env funj argjv + let rec apply_rec n typ = function + | [] -> + { uj_val = mkApp (j_val funj, Array.map j_val argjv); + uj_type = typ } + | hj::restjl -> + (match kind_of_term (whd_betadeltaiota env typ) with + | Prod (_,c1,c2) -> + (try + let () = conv_leq false env hj.uj_type c1 in + apply_rec (n+1) (subst1 hj.uj_val c2) restjl + with NotConvertible -> + error_cant_apply_bad_type env + (n,c1, hj.uj_type) + funj argjv) + + | _ -> + error_cant_apply_not_functional env funj argjv) in - apply_rec 0 funj.uj_type empty_constraint + apply_rec 1 + funj.uj_type + (Array.to_list argjv) (* Type of product *) @@ -221,14 +203,14 @@ let sort_of_product env domsort rangsort = rangsort | _ -> (* Rule is (Type_i,Set,Type_i) in the Set-predicative calculus *) - Type (sup u1 type0_univ) + Type (Universe.sup Universe.type0 u1) end (* Product rule (Prop,Type_i,Type_i) *) - | (Prop Pos, Type u2) -> Type (sup type0_univ u2) + | (Prop Pos, Type u2) -> Type (Universe.sup Universe.type0 u2) (* Product rule (Prop,Type_i,Type_i) *) | (Prop Null, Type _) -> rangsort (* Product rule (Type_i,Type_i,Type_i) *) - | (Type u1, Type u2) -> Type (sup u1 u2) + | (Type u1, Type u2) -> Type (Universe.sup u1 u2) (* [judge_of_product env name (typ1,s1) (typ2,s2)] implements the rule @@ -262,18 +244,17 @@ let judge_of_cast env cj k tj = vm_conv CUMUL env cj.uj_type expected_type | DEFAULTcast -> mkCast (cj.uj_val, k, expected_type), - conv_leq false env cj.uj_type expected_type + default_conv ~l2r:false CUMUL env cj.uj_type expected_type | REVERTcast -> cj.uj_val, - conv_leq true env cj.uj_type expected_type + default_conv ~l2r:true CUMUL env cj.uj_type expected_type | NATIVEcast -> let sigma = Nativelambda.empty_evars in mkCast (cj.uj_val, k, expected_type), native_conv CUMUL sigma env cj.uj_type expected_type in - { uj_val = c; - uj_type = expected_type }, - cst + { uj_val = c; + uj_type = expected_type } with NotConvertible -> error_actual_type env cj expected_type @@ -291,50 +272,70 @@ let judge_of_cast env cj k tj = the App case of execute; from this constraints, the expected dynamic constraints of the form u<=v are enforced *) -let judge_of_inductive_knowing_parameters env ind jl = - let c = mkInd ind in +(* let judge_of_inductive_knowing_parameters env ind jl = *) +(* let c = mkInd ind in *) +(* let (mib,mip) = lookup_mind_specif env ind in *) +(* check_args env c mib.mind_hyps; *) +(* let paramstyp = Array.map (fun j -> j.uj_type) jl in *) +(* let t = in *) +(* make_judge c t *) + +let judge_of_inductive env (ind,u as indu) = + let c = mkIndU indu in let (mib,mip) = lookup_mind_specif env ind in check_hyps_inclusion env c mib.mind_hyps; - let paramstyp = Array.map (fun j -> lazy j.uj_type) jl in - let t = Inductive.type_of_inductive_knowing_parameters env mip paramstyp in - make_judge c t - -let judge_of_inductive env ind = - judge_of_inductive_knowing_parameters env ind [||] + let t,cst = Inductive.constrained_type_of_inductive env ((mib,mip),u) in + check_constraints cst env; + (make_judge c t) (* Constructors. *) -let judge_of_constructor env c = - let constr = mkConstruct c in +let judge_of_constructor env (c,u as cu) = + let constr = mkConstructU cu in let _ = let ((kn,_),_) = c in let mib = lookup_mind kn env in check_hyps_inclusion env constr mib.mind_hyps in let specif = lookup_mind_specif env (inductive_of_constructor c) in - make_judge constr (type_of_constructor c specif) + let t,cst = constrained_type_of_constructor cu specif in + let () = check_constraints cst env in + (make_judge constr t) (* Case. *) -let check_branch_types env ind cj (lfj,explft) = +let check_branch_types env (ind,u) cj (lfj,explft) = try conv_leq_vecti env (Array.map j_type lfj) explft with NotConvertibleVect i -> - 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) | Invalid_argument _ -> error_number_branches env cj (Array.length explft) let judge_of_case env ci pj cj lfj = - let indspec = + let (pind, _ as indspec) = try find_rectype env cj.uj_type with Not_found -> error_case_not_inductive env cj in - let _ = check_case_info env (fst indspec) ci in - let (bty,rslty,univ) = + let _ = check_case_info env pind ci in + let (bty,rslty) = type_case_branches env indspec pj cj.uj_val in - let univ' = check_branch_types env (fst indspec) cj (lfj,bty) in + let () = check_branch_types env pind cj (lfj,bty) in ({ uj_val = mkCase (ci, (*nf_betaiota*) pj.uj_val, cj.uj_val, Array.map j_val lfj); - uj_type = rslty }, - union_constraints univ univ') + uj_type = rslty }) + +let judge_of_projection env p cj = + let pb = lookup_projection p env in + let (ind,u), args = + try find_rectype env cj.uj_type + with Not_found -> error_case_not_inductive env cj + in + assert(eq_mind pb.proj_ind (fst ind)); + let usubst = make_inductive_subst (fst (lookup_mind_specif env ind)) u in + let ty = Vars.subst_univs_constr usubst pb.Declarations.proj_type in + let ty = substl (cj.uj_val :: List.rev args) ty in + (* TODO: Universe polymorphism for projections *) + {uj_val = mkProj (p,cj.uj_val); + uj_type = ty} (* Fixpoints. *) @@ -352,104 +353,88 @@ let type_fixpoint env lna lar vdefj = (************************************************************************) (************************************************************************) -(* This combinator adds the universe constraints both in the local - graph and in the universes of the environment. This is to ensure - that the infered local graph is satisfiable. *) -let univ_combinator (cst,univ) (j,c') = - (j,(union_constraints cst c', merge_constraints c' univ)) - (* The typing machine. *) (* ATTENTION : faudra faire le typage du contexte des Const, Ind et Constructsi un jour cela devient des constructions arbitraires et non plus des variables *) -let rec execute env cstr cu = +let rec execute env cstr = match kind_of_term cstr with (* Atomic terms *) | Sort (Prop c) -> - (judge_of_prop_contents c, cu) - + judge_of_prop_contents c + | Sort (Type u) -> - (judge_of_type u, cu) + judge_of_type u | Rel n -> - (judge_of_relative env n, cu) + judge_of_relative env n | Var id -> - (judge_of_variable env id, cu) + judge_of_variable env id | Const c -> - (judge_of_constant env c, cu) + judge_of_constant env c + + | Proj (p, c) -> + let cj = execute env c in + judge_of_projection env p cj (* Lambda calculus operators *) | App (f,args) -> - let (jl,cu1) = execute_array env args cu in - let (j,cu2) = - match kind_of_term f with - | Ind ind -> - (* Sort-polymorphism of inductive types *) - judge_of_inductive_knowing_parameters env ind jl, cu1 - | Const cst -> - (* Sort-polymorphism of constant *) - judge_of_constant_knowing_parameters env cst jl, cu1 - | _ -> - (* No sort-polymorphism *) - execute env f cu1 - in - univ_combinator cu2 (judge_of_apply env j jl) + let jl = execute_array env args in + let j = execute env f in + judge_of_apply env j jl | Lambda (name,c1,c2) -> - let (varj,cu1) = execute_type env c1 cu in - let env1 = push_rel (name,None,varj.utj_val) env in - let (j',cu2) = execute env1 c2 cu1 in - (judge_of_abstraction env name varj j', cu2) + let varj = execute_type env c1 in + let env1 = push_rel (name,None,varj.utj_val) env in + let j' = execute env1 c2 in + judge_of_abstraction env name varj j' | Prod (name,c1,c2) -> - let (varj,cu1) = execute_type env c1 cu in - let env1 = push_rel (name,None,varj.utj_val) env in - let (varj',cu2) = execute_type env1 c2 cu1 in - (judge_of_product env name varj varj', cu2) + let varj = execute_type env c1 in + let env1 = push_rel (name,None,varj.utj_val) env in + let varj' = execute_type env1 c2 in + judge_of_product env name varj varj' | LetIn (name,c1,c2,c3) -> - let (j1,cu1) = execute env c1 cu in - let (j2,cu2) = execute_type env c2 cu1 in - let (_,cu3) = - univ_combinator cu2 (judge_of_cast env j1 DEFAULTcast j2) in - let env1 = push_rel (name,Some j1.uj_val,j2.utj_val) env in - let (j',cu4) = execute env1 c3 cu3 in - (judge_of_letin env name j1 j2 j', cu4) + let j1 = execute env c1 in + let j2 = execute_type env c2 in + let _ = judge_of_cast env j1 DEFAULTcast j2 in + let env1 = push_rel (name,Some j1.uj_val,j2.utj_val) env in + let j' = execute env1 c3 in + judge_of_letin env name j1 j2 j' | Cast (c,k, t) -> - let (cj,cu1) = execute env c cu in - let (tj,cu2) = execute_type env t cu1 in - univ_combinator cu2 - (judge_of_cast env cj k tj) + let cj = execute env c in + let tj = execute_type env t in + judge_of_cast env cj k tj (* Inductive types *) | Ind ind -> - (judge_of_inductive env ind, cu) + judge_of_inductive env ind | Construct c -> - (judge_of_constructor env c, cu) + judge_of_constructor env c | Case (ci,p,c,lf) -> - let (cj,cu1) = execute env c cu in - let (pj,cu2) = execute env p cu1 in - let (lfj,cu3) = execute_array env lf cu2 in - univ_combinator cu3 - (judge_of_case env ci pj cj lfj) + let cj = execute env c in + let pj = execute env p in + let lfj = execute_array env lf in + judge_of_case env ci pj cj lfj | Fix ((vn,i as vni),recdef) -> - let ((fix_ty,recdef'),cu1) = execute_recdef env recdef i cu in - let fix = (vni,recdef') in + let (fix_ty,recdef') = execute_recdef env recdef i in + let fix = (vni,recdef') in check_fix env fix; - (make_judge (mkFix fix) fix_ty, cu1) - + make_judge (mkFix fix) fix_ty + | CoFix (i,recdef) -> - let ((fix_ty,recdef'),cu1) = execute_recdef env recdef i cu in - let cofix = (i,recdef') in + let (fix_ty,recdef') = execute_recdef env recdef i in + let cofix = (i,recdef') in check_cofix env cofix; - (make_judge (mkCoFix cofix) fix_ty, cu1) - + (make_judge (mkCoFix cofix) fix_ty) + (* Partial proofs: unsupported by the kernel *) | Meta _ -> anomaly (Pp.str "the kernel does not support metavariables") @@ -457,61 +442,53 @@ let rec execute env cstr cu = | Evar _ -> anomaly (Pp.str "the kernel does not support existential variables") -and execute_type env constr cu = - let (j,cu1) = execute env constr cu in - (type_judgment env j, cu1) +and execute_type env constr = + let j = execute env constr in + type_judgment env j -and execute_recdef env (names,lar,vdef) i cu = - let (larj,cu1) = execute_array env lar cu in +and execute_recdef env (names,lar,vdef) i = + let larj = execute_array env lar in let lara = Array.map (assumption_of_judgment env) larj in let env1 = push_rec_types (names,lara,vdef) env in - let (vdefj,cu2) = execute_array env1 vdef cu1 in + let vdefj = execute_array env1 vdef in let vdefv = Array.map j_val vdefj in - let cst = type_fixpoint env1 names lara vdefj in - univ_combinator cu2 - ((lara.(i),(names,lara,vdefv)),cst) + let () = type_fixpoint env1 names lara vdefj in + (lara.(i),(names,lara,vdefv)) -and execute_array env = Array.fold_map' (execute env) +and execute_array env = Array.map (execute env) (* Derived functions *) let infer env constr = - let (j,(cst,_)) = - execute env constr (empty_constraint, universes env) in - assert (eq_constr j.uj_val constr); - (j, cst) + let j = execute env constr in + assert (eq_constr j.uj_val constr); + j + +(* let infer_key = Profile.declare_profile "infer" *) +(* let infer = Profile.profile2 infer_key infer *) let infer_type env constr = - let (j,(cst,_)) = - execute_type env constr (empty_constraint, universes env) in - (j, cst) + let j = execute_type env constr in + j let infer_v env cv = - let (jv,(cst,_)) = - execute_array env cv (empty_constraint, universes env) in - (jv, cst) + let jv = execute_array env cv in + jv (* Typing of several terms. *) let infer_local_decl env id = function | LocalDef c -> - let (j,cst) = infer env c in - (Name id, Some j.uj_val, j.uj_type), cst + let j = infer env c in + (Name id, Some j.uj_val, j.uj_type) | LocalAssum c -> - let (j,cst) = infer env c in - (Name id, None, assumption_of_judgment env j), cst + let j = infer env c in + (Name id, None, assumption_of_judgment env j) let infer_local_decls env decls = let rec inferec env = function | (id, d) :: l -> - let env, l, cst1 = inferec env l in - let d, cst2 = infer_local_decl env id d in - push_rel d env, add_rel_decl d l, union_constraints cst1 cst2 - | [] -> env, empty_rel_context, empty_constraint in + let (env, l) = inferec env l in + let d = infer_local_decl env id d in + (push_rel d env, add_rel_decl d l) + | [] -> (env, empty_rel_context) in inferec env decls - -(* Exported typing functions *) - -let typing env c = - let (j,cst) = infer env c in - let _ = add_constraints cst env in - j diff --git a/kernel/typeops.mli b/kernel/typeops.mli index d6484e823..6bc1ce496 100644 --- a/kernel/typeops.mli +++ b/kernel/typeops.mli @@ -14,15 +14,21 @@ open Environ open Entries open Declarations -(** {6 Typing functions (not yet tagged as safe) } *) +(** {6 Typing functions (not yet tagged as safe) } -val infer : env -> constr -> unsafe_judgment * constraints -val infer_v : env -> constr array -> unsafe_judgment array * constraints -val infer_type : env -> types -> unsafe_type_judgment * constraints + They return unsafe judgments that are "in context" of a set of + (local) universe variables (the ones that appear in the term) + and associated constraints. In case of polymorphic definitions, + these variables and constraints will be generalized. + *) + + +val infer : env -> constr -> unsafe_judgment +val infer_v : env -> constr array -> unsafe_judgment array +val infer_type : env -> types -> unsafe_type_judgment val infer_local_decls : - env -> (Id.t * local_entry) list - -> env * rel_context * constraints + env -> (Id.t * local_entry) list -> (env * rel_context) (** {6 Basic operations of the typing machine. } *) @@ -45,21 +51,25 @@ val judge_of_relative : env -> int -> unsafe_judgment val judge_of_variable : env -> variable -> unsafe_judgment (** {6 type of a constant } *) -val judge_of_constant : env -> constant -> unsafe_judgment +val judge_of_constant : env -> constant puniverses -> unsafe_judgment + +(* val judge_of_constant_knowing_parameters : *) +(* env -> constant -> unsafe_judgment array -> unsafe_judgment *) -val judge_of_constant_knowing_parameters : - env -> constant -> unsafe_judgment array -> unsafe_judgment +val judge_of_projection : env -> Names.projection -> unsafe_judgment -> unsafe_judgment (** {6 Type of application. } *) val judge_of_apply : env -> unsafe_judgment -> unsafe_judgment array - -> unsafe_judgment * constraints + -> unsafe_judgment (** {6 Type of an abstraction. } *) val judge_of_abstraction : env -> Name.t -> unsafe_type_judgment -> unsafe_judgment -> unsafe_judgment +val sort_of_product : env -> sorts -> sorts -> sorts + (** {6 Type of a product. } *) val judge_of_product : env -> Name.t -> unsafe_type_judgment -> unsafe_type_judgment @@ -73,37 +83,35 @@ val judge_of_letin : (** {6 Type of a cast. } *) val judge_of_cast : env -> unsafe_judgment -> cast_kind -> unsafe_type_judgment -> - unsafe_judgment * constraints + unsafe_judgment (** {6 Inductive types. } *) -val judge_of_inductive : env -> inductive -> unsafe_judgment +val judge_of_inductive : env -> inductive puniverses -> unsafe_judgment -val judge_of_inductive_knowing_parameters : - env -> inductive -> unsafe_judgment array -> unsafe_judgment +(* val judge_of_inductive_knowing_parameters : *) +(* env -> inductive -> unsafe_judgment array -> unsafe_judgment *) -val judge_of_constructor : env -> constructor -> unsafe_judgment +val judge_of_constructor : env -> constructor puniverses -> unsafe_judgment (** {6 Type of Cases. } *) val judge_of_case : env -> case_info -> unsafe_judgment -> unsafe_judgment -> unsafe_judgment array - -> unsafe_judgment * constraints + -> unsafe_judgment (** Typecheck general fixpoint (not checking guard conditions) *) val type_fixpoint : env -> Name.t array -> types array - -> unsafe_judgment array -> constraints - -(** Kernel safe typing but applicable to partial proofs *) -val typing : env -> constr -> unsafe_judgment + -> unsafe_judgment array -> unit -val type_of_constant : env -> constant -> types +val type_of_constant : env -> constant puniverses -> types constrained val type_of_constant_type : env -> constant_type -> types +val type_of_projection : env -> Names.projection puniverses -> types + +val type_of_constant_in : env -> constant puniverses -> types + val type_of_constant_knowing_parameters : env -> constant_type -> types Lazy.t array -> types -(** Make a type polymorphic if an arity *) -val make_polymorphic_if_constant_for_ind : env -> unsafe_judgment -> - constant_type diff --git a/kernel/univ.ml b/kernel/univ.ml index 551d74043..8322a7e96 100644 --- a/kernel/univ.ml +++ b/kernel/univ.ml @@ -29,13 +29,56 @@ open Util union-find algorithm. The assertions $<$ and $\le$ are represented by adjacency lists *) -module UniverseLevel = struct +module Level = struct open Names type t = + | Prop | Set - | Level of int * DirPath.t + | Level of int * Names.DirPath.t + type _t = t + + (* Hash-consing *) + + module Hunivlevel = + Hashcons.Make( + struct + type t = _t + type u = Names.DirPath.t -> Names.DirPath.t + let hashcons hdir = function + | Prop as x -> x + | Set as x -> x + | Level (n,d) -> Level (n,hdir d) + let equal l1 l2 = + l1 == l2 || + match l1,l2 with + | Prop, Prop -> true + | Set, Set -> true + | Level (n,d), Level (n',d') -> + n == n' && d == d' + | _ -> false + let hash = Hashtbl.hash + end) + + let hcons = Hashcons.simple_hcons Hunivlevel.generate Names.DirPath.hcons + + let make m n = hcons (Level (n, m)) + + let set = hcons Set + let prop = hcons Prop + + let is_small = function + | Level _ -> false + | _ -> true + + let is_prop = function + | Prop -> true + | _ -> false + + let is_set = function + | Set -> true + | _ -> false (* A specialized comparison function: we compare the [int] part first. This way, most of the time, the [DirPath.t] part is not considered. @@ -49,6 +92,9 @@ module UniverseLevel = struct if u == v then 0 else (match u,v with + | Prop,Prop -> 0 + | Prop, _ -> -1 + | _, Prop -> 1 | Set, Set -> 0 | Set, _ -> -1 | _, Set -> 1 @@ -63,27 +109,385 @@ module UniverseLevel = struct Int.equal i1 i2 && DirPath.equal dp1 dp2 | _ -> false - let hash = function - | Set -> 0 - | Level (i, dp) -> - Hashset.Combine.combine (Int.hash i) (DirPath.hash dp) - - let make m n = Level (n, m) + let eq u v = u == v + let leq u v = compare u v <= 0 let to_string = function + | Prop -> "Prop" | Set -> "Set" - | Level (n,d) -> DirPath.to_string d^"."^string_of_int n + | Level (n,d) -> Names.DirPath.to_string d^"."^string_of_int n + + let pr u = str (to_string u) + + let apart u v = + match u, v with + | Prop, Set | Set, Prop -> true + | _ -> false + end -module UniverseLMap = Map.Make (UniverseLevel) -module UniverseLSet = Set.Make (UniverseLevel) +let pr_universe_level_list l = + prlist_with_sep spc Level.pr l + +module LSet = struct + module M = Set.Make (Level) + include M + + let pr s = + str"{" ++ pr_universe_level_list (elements s) ++ str"}" -type universe_level = UniverseLevel.t + let of_list l = + List.fold_left (fun acc x -> add x acc) empty l -let compare_levels = UniverseLevel.compare + let of_array l = + Array.fold_left (fun acc x -> add x acc) empty l +end + +module LMap = struct + module M = Map.Make (Level) + include M + + let union l r = + merge (fun k l r -> + match l, r with + | Some _, _ -> l + | _, _ -> r) l r + + let subst_union l r = + merge (fun k l r -> + match l, r with + | Some (Some _), _ -> l + | Some None, None -> l + | _, _ -> r) l r + + let diff ext orig = + fold (fun u v acc -> + if mem u orig then acc + else add u v acc) + ext empty + + let elements = bindings + let of_set s d = + LSet.fold (fun u -> add u d) s + empty + + let of_list l = + List.fold_left (fun m (u, v) -> add u v m) empty l + + let universes m = + fold (fun u _ acc -> LSet.add u acc) m LSet.empty + + let pr f m = + h 0 (prlist_with_sep fnl (fun (u, v) -> + Level.pr u ++ f v) (elements m)) + + let find_opt t m = + try Some (find t m) + with Not_found -> None +end + +type universe_level = Level.t + +module LList = struct + type t = Level.t list + type _t = t + module Huniverse_level_list = + Hashcons.Make( + struct + type t = _t + type u = universe_level -> universe_level + let hashcons huc s = + List.fold_right (fun x a -> huc x :: a) s [] + let equal s s' = List.for_all2eq (==) s s' + let hash = Hashtbl.hash + end) + + let hcons = + Hashcons.simple_hcons Huniverse_level_list.generate Level.hcons + + let empty = hcons [] + let eq l l' = l == l' || + (try List.for_all2 Level.eq l l' + with Invalid_argument _ -> false) + + let levels = + List.fold_left (fun s x -> LSet.add x s) LSet.empty + +end + +type universe_level_list = universe_level list + +type universe_level_subst_fn = universe_level -> universe_level + +type universe_set = LSet.t +type 'a universe_map = 'a LMap.t + +let compare_levels = Level.compare +let eq_levels = Level.eq + +module Hashconsing = struct + module Uid = struct + type t = int + + let make_maker () = + let _id = ref ~-1 in + ((fun () -> incr _id;!_id), + (fun () -> !_id), + (fun i -> _id := i)) + + let dummy = -1 + + external to_int : t -> int = "%identity" + + + external of_int : int -> t= "%identity" + end + + module Hcons = struct + + module type SA = + sig + type data + type t + val make : data -> t + val node : t -> data + val hash : t -> int + val uid : t -> Uid.t + val equal : t -> t -> bool + val stats : unit -> unit + val init : unit -> unit + end + + module type S = + sig + + type data + type t = private { id : Uid.t; + key : int; + node : data } + val make : data -> t + val node : t -> data + val hash : t -> int + val uid : t -> Uid.t + val equal : t -> t -> bool + val stats : unit -> unit + val init : unit -> unit + end + + module Make (H : Hashtbl.HashedType) : S with type data = H.t = + struct + let uid_make,uid_current,uid_set = Uid.make_maker() + type data = H.t + type t = { id : Uid.t; + key : int; + node : data } + let node t = t.node + let uid t = t.id + let hash t = t.key + let equal t1 t2 = t1 == t2 + module WH = Weak.Make( struct + type _t = t + type t = _t + let hash = hash + let equal a b = a == b || H.equal a.node b.node + end) + let pool = WH.create 491 + + exception Found of Uid.t + let total_count = ref 0 + let miss_count = ref 0 + let init () = + total_count := 0; + miss_count := 0 + + let make x = + incr total_count; + let cell = { id = Uid.dummy; key = H.hash x; node = x } in + try + WH.find pool cell + with + | Not_found -> + let cell = { cell with id = uid_make(); } in + incr miss_count; + WH.add pool cell; + cell + + exception Found of t + + let stats () = () + end + end + module HList = struct + + module type S = sig + type elt + type 'a node = Nil | Cons of elt * 'a + + module rec Node : + sig + include Hcons.S with type data = Data.t + end + and Data : sig + include Hashtbl.HashedType with type t = Node.t node + end + type data = Data.t + type t = Node.t + val hash : t -> int + val uid : t -> Uid.t + val make : data -> t + val equal : t -> t -> bool + val nil : t + val is_nil : t -> bool + val tip : elt -> t + val node : t -> t node + val cons : (* ?sorted:bool -> *) elt -> t -> t + val hd : t -> elt + val tl : t -> t + val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a + val map : (elt -> elt) -> t -> t + val iter : (elt -> 'a) -> t -> unit + val exists : (elt -> bool) -> t -> bool + val for_all : (elt -> bool) -> t -> bool + val rev : t -> t + val rev_map : (elt -> elt) -> t -> t + val length : t -> int + val mem : elt -> t -> bool + val remove : elt -> t -> t + val stats : unit -> unit + val init : unit -> unit + val to_list : t -> elt list + val compare : (elt -> elt -> int) -> t -> t -> int + end + + module Make (H : Hcons.SA) : S with type elt = H.t = + struct + type elt = H.t + type 'a node = Nil | Cons of elt * 'a + module rec Node : Hcons.S with type data = Data.t = Hcons.Make (Data) + and Data : Hashtbl.HashedType with type t = Node.t node = + struct + type t = Node.t node + let equal x y = + match x,y with + | _,_ when x==y -> true + | Cons (a,aa), Cons(b,bb) -> (aa==bb) && (H.equal a b) + | _ -> false + let hash = function + | Nil -> 0 + | Cons(a,aa) -> 17 + 65599 * (Uid.to_int (H.uid a)) + 491 * (Uid.to_int aa.Node.id) + end + + type data = Data.t + type t = Node.t + let make = Node.make + let node x = x.Node.node + let hash x = x.Node.key + let equal = Node.equal + let uid x= x.Node.id + let nil = Node.make Nil + let stats = Node.stats + let init = Node.init + + let is_nil = + function { Node.node = Nil } -> true | _ -> false + + (* doing sorted insertion allows to make + better use of hash consing *) + let rec sorted_cons e l = + match l.Node.node with + | Nil -> Node.make (Cons(e, l)) + | Cons (x, ll) -> + if H.uid e < H.uid x + then Node.make (Cons(e, l)) + else Node.make (Cons(x, sorted_cons e ll)) + + let cons e l = + Node.make(Cons(e, l)) + + let tip e = Node.make (Cons(e, nil)) + + (* let cons ?(sorted=true) e l = *) + (* if sorted then sorted_cons e l else cons e l *) + + let hd = function { Node.node = Cons(a,_) } -> a | _ -> failwith "hd" + let tl = function { Node.node = Cons(_,a) } -> a | _ -> failwith "tl" + + let fold f l acc = + let rec loop acc l = match l.Node.node with + | Nil -> acc + | Cons (a, aa) -> loop (f a acc) aa + in + loop acc l + + let map f l = + let rec loop l = match l.Node.node with + | Nil -> nil + | Cons(a, aa) -> cons (f a) (loop aa) + in + loop l + + let iter f l = + let rec loop l = match l.Node.node with + | Nil -> () + | Cons(a,aa) -> (f a);(loop aa) + in + loop l + + let exists f l = + let rec loop l = match l.Node.node with + | Nil -> false + | Cons(a,aa) -> f a || loop aa + in + loop l + + let for_all f l = + let rec loop l = match l.Node.node with + | Nil -> true + | Cons(a,aa) -> f a && loop aa + in + loop l + + let to_list l = + let rec loop l = match l.Node.node with + | Nil -> [] + | Cons(a,aa) -> a :: loop aa + in + loop l + + let remove x l = + let rec loop l = match l.Node.node with + | Nil -> l + | Cons(a,aa) -> + if H.equal a x then aa + else cons a (loop aa) + in + loop l + + let rev l = fold cons l nil + let rev_map f l = fold (fun x acc -> cons (f x) acc) l nil + let length l = fold (fun _ c -> c+1) l 0 + let rec mem e l = + match l.Node.node with + | Nil -> false + | Cons (x, ll) -> x == e || mem e ll + + let rec compare cmp l1 l2 = + if l1 == l2 then 0 else + match node l1, node l2 with + | Nil, Nil -> 0 + | _, Nil -> 1 + | Nil, _ -> -1 + | Cons (x1,l1), Cons(x2,l2) -> + (match cmp x1 x2 with + | 0 -> compare cmp l1 l2 + | c -> c) + + end + end +end (* An algebraic universe [universe] is either a universe variable - [UniverseLevel.t] or a formal universe known to be greater than some + [Level.t] or a formal universe known to be greater than some universe variables and strictly greater than some (other) universe variables @@ -96,158 +500,346 @@ let compare_levels = UniverseLevel.compare module Universe = struct - type t = - | Atom of UniverseLevel.t - | Max of UniverseLevel.t list * UniverseLevel.t list + (* Invariants: non empty, sorted and without duplicates *) + + module Expr = + struct + type t = Level.t * int + type _t = t + + (* Hashing of expressions *) + module ExprHash = + struct + type t = _t + type u = Level.t -> Level.t + let hashcons hdir (b,n as x) = + let b' = hdir b in + if b' == b then x else (b',n) + let equal l1 l2 = + l1 == l2 || + match l1,l2 with + | (b,n), (b',n') -> b == b' && n == n' + let hash = Hashtbl.hash + + end + + module HExpr = + struct + + include Hashcons.Make(ExprHash) + + type data = t + type node = t + + let make = + Hashcons.simple_hcons generate Level.hcons + external node : node -> data = "%identity" + let hash = ExprHash.hash + let uid = hash + let equal x y = x == y + let stats _ = () + let init _ = () + end + + let hcons = HExpr.make + + let make l = hcons (l, 0) + + let compare u v = + if u == v then 0 + else + let (x, n) = u and (x', n') = v in + if Int.equal n n' then Level.compare x x' + else n - n' + + let prop = make Level.prop + let set = make Level.set + let type1 = hcons (Level.set, 1) + + let is_prop = function + | (l,0) -> Level.is_prop l + | _ -> false + + let is_set = function + | (l,0) -> Level.is_set l + | _ -> false + + let is_type1 = function + | (l,1) -> Level.is_set l + | _ -> false + + let is_small = function + | (l, 0) -> Level.is_small l + | _ -> false + + (* let eq (u,n) (v,n') = *) + (* Int.equal n n' && Level.eq u v *) + let eq x y = x == y + + let leq (u,n) (v,n') = + let cmp = Level.compare u v in + if Int.equal cmp 0 then n <= n' + else if n <= n' then + (Level.is_prop u && Level.is_small v) + else false + + let successor (u,n) = + if Level.is_prop u then type1 + else hcons (u, n + 1) + + let addn k (u,n as x) = + if k = 0 then x + else if Level.is_prop u then + hcons (Level.set,n+k) + else hcons (u,n+k) + + let super (u,n as x) (v,n' as y) = + let cmp = Level.compare u v in + if Int.equal cmp 0 then + if n < n' then Inl true + else Inl false + else if is_prop x then Inl true + else if is_prop y then Inl false + else Inr cmp + + let to_string (v, n) = + if Int.equal n 0 then Level.to_string v + else Level.to_string v ^ "+" ^ string_of_int n + + let pr x = str(to_string x) + + let level = function + | (v,0) -> Some v + | _ -> None + + let get_level (v,n) = v + + let map f (v, n as x) = + let v' = f v in + if v' == v then x + else if Level.is_prop v' && n != 0 then + hcons (Level.set, n) + else hcons (v', n) + + end + + module Hunivelt = struct + let node x = x + let make x = x + end + + (* module Hunivelt = Hashconsing.Hcons.Make( *) + (* struct *) + (* type t = Expr.t *) + (* let equal l1 l2 = *) + (* l1 == l2 || *) + (* match l1,l2 with *) + (* | (b,n), (b',n') -> b == b' && n == n' *) + (* let hash = Hashtbl.hash *) + (* end) *) + + let compare_expr n m = Expr.compare (Hunivelt.node n) (Hunivelt.node m) + let pr_expr n = Expr.pr (Hunivelt.node n) + + module Huniv = Hashconsing.HList.Make(Expr.HExpr) + type t = Huniv.t + open Huniv + + let eq x y = x == y (* Huniv.equal *) let compare u1 u2 = - if u1 == u2 then 0 else - match u1, u2 with - | Atom l1, Atom l2 -> UniverseLevel.compare l1 l2 - | Max (lt1, le1), Max (lt2, le2) -> - let c = List.compare UniverseLevel.compare lt1 lt2 in - if Int.equal c 0 then - List.compare UniverseLevel.compare le1 le2 - else c - | Atom _, Max _ -> -1 - | Max _, Atom _ -> 1 - - let equal u1 u2 = Int.equal (compare u1 u2) 0 - - let make l = Atom l - - open Hashset.Combine - - let rec hash_list accu = function - | [] -> 0 - | u :: us -> - let accu = combine (UniverseLevel.hash u) accu in - hash_list accu us - - let hash = function - | Atom u -> combinesmall 1 (UniverseLevel.hash u) - | Max (lt, le) -> - let hlt = hash_list 0 lt in - let hle = hash_list 0 le in - combinesmall 2 (combine hlt hle) + if eq u1 u2 then 0 else + Huniv.compare compare_expr u1 u2 + + let hcons_unique = Huniv.make + let normalize x = x + (* let hcons_unique x = x *) + let hcons x = hcons_unique (normalize x) + + let make l = Huniv.tip (Hunivelt.make (Expr.make l)) + let tip x = Huniv.tip (Hunivelt.make x) + + let equal_universes x y = + x == y +(* then true *) +(* else *) +(* (\* Consider lists as sets, i.e. up to reordering, *) +(* they are already without duplicates thanks to normalization. *\) *) +(* CList.eq_set x' y' *) + + let pr l = match node l with + | Cons (u, n) when is_nil n -> Expr.pr (Hunivelt.node u) + | _ -> + str "max(" ++ hov 0 + (prlist_with_sep pr_comma Expr.pr (List.map Hunivelt.node (to_list l))) ++ + str ")" + + let atom l = match node l with + | Cons (l, n) when is_nil n -> Some l + | _ -> None + + let level l = match node l with + | Cons (l, n) when is_nil n -> Expr.level (Hunivelt.node l) + | _ -> None + + let levels l = + fold (fun x acc -> LSet.add (Expr.get_level (Hunivelt.node x)) acc) l LSet.empty + + let is_small u = + match level (normalize u) with + | Some l -> Level.is_small l + | _ -> false -end + (* The lower predicative level of the hierarchy that contains (impredicative) + Prop and singleton inductive types *) + let type0m = tip Expr.prop -open Universe + (* The level of sets *) + let type0 = tip Expr.set + + (* When typing [Prop] and [Set], there is no constraint on the level, + hence the definition of [type1_univ], the type of [Prop] *) + let type1 = tip (Expr.successor Expr.set) + + let is_type0m u = + match level u with + | Some l -> Level.is_prop l + | _ -> false + + let is_type0 u = + match level u with + | Some l -> Level.is_set l + | _ -> false + + let is_type1 u = + match node u with + | Cons (l, n) when is_nil n -> Expr.is_type1 (Hunivelt.node l) + | _ -> false + + (* Returns the formal universe that lies juste above the universe variable u. + Used to type the sort u. *) + let super l = + Huniv.map (fun x -> Hunivelt.make (Expr.successor (Hunivelt.node x))) l + + let addn n l = + Huniv.map (fun x -> Hunivelt.make (Expr.addn n (Hunivelt.node x))) l + + let rec merge_univs l1 l2 = + match node l1, node l2 with + | Nil, _ -> l2 + | _, Nil -> l1 + | Cons (h1, t1), Cons (h2, t2) -> + (match Expr.super (Hunivelt.node h1) (Hunivelt.node h2) with + | Inl true (* h1 < h2 *) -> merge_univs t1 l2 + | Inl false -> merge_univs l1 t2 + | Inr c -> + if c <= 0 (* h1 < h2 is name order *) + then cons h1 (merge_univs t1 l2) + else cons h2 (merge_univs l1 t2)) + + let sort u = + let rec aux a l = + match node l with + | Cons (b, l') -> + (match Expr.super (Hunivelt.node a) (Hunivelt.node b) with + | Inl false -> aux a l' + | Inl true -> l + | Inr c -> + if c <= 0 then cons a l + else cons b (aux a l')) + | Nil -> cons a l + in + fold (fun a acc -> aux a acc) u nil + + (* Returns the formal universe that is greater than the universes u and v. + Used to type the products. *) + let sup x y = merge_univs x y + + let of_list l = + List.fold_right + (fun x acc -> cons (Hunivelt.make x) acc) + l nil + + let empty = nil + let is_empty n = is_nil n + + let exists f l = + Huniv.exists (fun x -> f (Hunivelt.node x)) l + + let for_all f l = + Huniv.for_all (fun x -> f (Hunivelt.node x)) l + + let smartmap f l = + Huniv.map (fun x -> + let n = Hunivelt.node x in + let x' = f n in + if x' == n then x else Hunivelt.make x') + l + +end type universe = Universe.t -let universe_level = function - | Atom l -> Some l - | Max _ -> None +open Universe -let pr_uni_level u = str (UniverseLevel.to_string u) +(* type universe_list = UList.t *) +(* let pr_universe_list = UList.pr *) -let pr_uni = function - | Atom u -> - pr_uni_level u - | Max ([],[u]) -> - str "(" ++ pr_uni_level u ++ str ")+1" - | Max (gel,gtl) -> - let opt_sep = match gel, gtl with - | [], _ | _, [] -> mt () - | _ -> pr_comma () - in - str "max(" ++ hov 0 - (prlist_with_sep pr_comma pr_uni_level gel ++ opt_sep ++ - prlist_with_sep pr_comma - (fun x -> str "(" ++ pr_uni_level x ++ str ")+1") gtl) ++ - str ")" - -(* Returns the formal universe that lies juste above the universe variable u. - Used to type the sort u. *) -let super = function - | Atom u -> - Max ([],[u]) - | Max _ -> - anomaly (str "Cannot take the successor of a non variable universe" ++ spc () ++ - str "(maybe a bugged tactic)") - -(* Returns the formal universe that is greater than the universes u and v. - Used to type the products. *) -let sup u v = - match u,v with - | Atom u, Atom v -> - if UniverseLevel.equal u v then Atom u else Max ([u;v],[]) - | u, Max ([],[]) -> u - | Max ([],[]), v -> v - | Atom u, Max (gel,gtl) -> Max (List.add_set UniverseLevel.equal u gel,gtl) - | Max (gel,gtl), Atom v -> Max (List.add_set UniverseLevel.equal v gel,gtl) - | Max (gel,gtl), Max (gel',gtl') -> - let gel'' = List.union UniverseLevel.equal gel gel' in - let gtl'' = List.union UniverseLevel.equal gtl gtl' in - Max (List.subtract UniverseLevel.equal gel'' gtl'',gtl'') +let pr_uni = Universe.pr +let is_small_univ = Universe.is_small + +let universe_level = Universe.level (* Comparison on this type is pointer equality *) type canonical_arc = - { univ: UniverseLevel.t; - lt: UniverseLevel.t list; - le: UniverseLevel.t list; - rank: int } + { univ: Level.t; + lt: Level.t list; + le: Level.t list; + rank : int} let terminal u = {univ=u; lt=[]; le=[]; rank=0} -(* A UniverseLevel.t is either an alias for another one, or a canonical one, +(* A Level.t is either an alias for another one, or a canonical one, for which we know the universes that are above *) type univ_entry = Canonical of canonical_arc - | Equiv of UniverseLevel.t + | Equiv of Level.t -type universes = univ_entry UniverseLMap.t +type universes = univ_entry LMap.t let enter_equiv_arc u v g = - UniverseLMap.add u (Equiv v) g + LMap.add u (Equiv v) g let enter_arc ca g = - UniverseLMap.add ca.univ (Canonical ca) g - -(* The lower predicative level of the hierarchy that contains (impredicative) - Prop and singleton inductive types *) -let type0m_univ = Max ([],[]) + LMap.add ca.univ (Canonical ca) g -let is_type0m_univ = function - | Max ([],[]) -> true - | _ -> false +let is_type0m_univ = Universe.is_type0m (* The level of predicative Set *) -let type0_univ = Atom UniverseLevel.Set +let type0m_univ = Universe.type0m +let type0_univ = Universe.type0 +let type1_univ = Universe.type1 -let is_type0_univ = function - | Atom UniverseLevel.Set -> true - | Max ([UniverseLevel.Set], []) -> msg_warning (str "Non canonical Set"); true - | u -> false +let sup = Universe.sup +let super = Universe.super -let is_univ_variable = function - | Atom UniverseLevel.Set -> false - | Atom _ -> true - | _ -> false +let is_type0_univ = Universe.is_type0 -(* When typing [Prop] and [Set], there is no constraint on the level, - hence the definition of [type1_univ], the type of [Prop] *) +let is_univ_variable l = Universe.level l != None -let type1_univ = Max ([], [UniverseLevel.Set]) +(* Every Level.t has a unique canonical arc representative *) -let initial_universes = UniverseLMap.empty -let is_initial_universes = UniverseLMap.is_empty - -(* Every UniverseLevel.t has a unique canonical arc representative *) - -(* repr : universes -> UniverseLevel.t -> canonical_arc *) +(* repr : universes -> Level.t -> canonical_arc *) (* canonical representative : we follow the Equiv links *) let repr g u = let rec repr_rec u = let a = - try UniverseLMap.find u g + try LMap.find u g with Not_found -> anomaly ~label:"Univ.repr" - (str "Universe" ++ spc () ++ pr_uni_level u ++ spc () ++ str "undefined") + (str"Universe " ++ Level.pr u ++ str" undefined") in match a with | Equiv v -> repr_rec v @@ -262,7 +854,7 @@ let can g = List.map (repr g) let safe_repr g u = let rec safe_repr_rec u = - match UniverseLMap.find u g with + match LMap.find u g with | Equiv v -> safe_repr_rec v | Canonical arc -> arc in @@ -286,7 +878,7 @@ let reprleq g arcu = searchrec [] arcu.le -(* between : UniverseLevel.t -> canonical_arc -> canonical_arc list *) +(* between : Level.t -> canonical_arc -> canonical_arc list *) (* between u v = { w | u<=w<=v, w canonical } *) (* between is the most costly operation *) @@ -320,6 +912,7 @@ let between g arcu arcv = *) type constraint_type = Lt | Le | Eq + type explanation = (constraint_type * universe) list let constraint_type_ord c1 c2 = match c1, c2 with @@ -335,10 +928,10 @@ let constraint_type_ord c1 c2 = match c1, c2 with correspond to the universes in (direct) relation [rel] with it, make a list of canonical universe, updating the relation with the starting point (path stored in reverse order). *) -let canp g (p:explanation) rel l : (canonical_arc * explanation) list = - List.map (fun u -> (repr g u, (rel,Atom u)::p)) l +let canp g (p:explanation Lazy.t) rel l : (canonical_arc * explanation Lazy.t) list = + List.map (fun u -> (repr g u, lazy ((rel,Universe.make u):: Lazy.force p))) l -type order = EQ | LT of explanation | LE of explanation | NLE +type order = EQ | LT of explanation Lazy.t | LE of explanation Lazy.t | NLE (** [compare_neq] : is [arcv] in the transitive upward closure of [arcu] ? @@ -375,14 +968,14 @@ let compare_neq strict g arcu arcv = | [] -> cmp c (arc :: lt_done) le_done lt_todo le_todo | u :: lt -> let arc = repr g u in - let p = (Lt, Atom u) :: p in + let p = lazy ((Lt, make u) :: Lazy.force p) in if arc == arcv then if strict then LT p else LE p else find ((arc, p) :: lt_todo) lt le end | u :: le -> let arc = repr g u in - let p = (Le, Atom u) :: p in + let p = lazy ((Le, make u) :: Lazy.force p) in if arc == arcv then if strict then LT p else LE p else find ((arc, p) :: lt_todo) lt le @@ -402,21 +995,22 @@ let compare_neq strict g arcu arcv = let rec find lt_todo lt = match lt with | [] -> let fold accu u = - let node = (repr g u, (Le, Atom u) :: p) in + let p = lazy ((Le, make u) :: Lazy.force p) in + let node = (repr g u, p) in node :: accu in let le_new = List.fold_left fold le_todo arc.le in cmp c lt_done (arc :: le_done) lt_todo le_new | u :: lt -> let arc = repr g u in - let p = (Lt, Atom u) :: p in + let p = lazy ((Lt, make u) :: Lazy.force p) in if arc == arcv then if strict then LT p else LE p else find ((arc, p) :: lt_todo) lt in find [] arc.lt in - cmp NLE [] [] [] [arcu, []] + cmp NLE [] [] [] [arcu, Lazy.lazy_from_val []] let compare g arcu arcv = if arcu == arcv then EQ else compare_neq true g arcu arcv @@ -456,50 +1050,80 @@ let check_smaller g strict u v = if strict then is_lt g arcu arcv else - arcu == snd (safe_repr g UniverseLevel.Set) || is_leq g arcu arcv + arcu == snd (safe_repr g Level.prop) || is_leq g arcu arcv (** Then, checks on universes *) -type check_function = universes -> universe -> universe -> bool +type 'a check_function = universes -> 'a -> 'a -> bool + +(* let equiv_list cmp l1 l2 = *) +(* let rec aux l1 l2 = *) +(* match l1 with *) +(* | [] -> l2 = [] *) +(* | hd :: tl1 -> *) +(* let rec aux' acc = function *) +(* | hd' :: tl2 -> *) +(* if cmp hd hd' then aux tl1 (acc @ tl2) *) +(* else aux' (hd' :: acc) tl2 *) +(* | [] -> false *) +(* in aux' [] l2 *) +(* in aux l1 l2 *) let incl_list cmp l1 l2 = - List.for_all (fun x1 -> List.exists (fun x2 -> cmp x1 x2) l2) l1 + Huniv.for_all (fun x1 -> Huniv.exists (fun x2 -> cmp x1 x2) l2) l1 let compare_list cmp l1 l2 = - (l1 == l2) - || (incl_list cmp l1 l2 && incl_list cmp l2 l1) + (l1 == l2) || (* (equiv_list cmp l1 l2) *) + (incl_list cmp l1 l2 && incl_list cmp l2 l1) + +let check_equal_expr g x y = + x == y || (let (u, n) = Hunivelt.node x and (v, m) = Hunivelt.node y in + n = m && check_equal g u v) (** [check_eq] is also used in [Evd.set_eq_sort], hence [Evarconv] and [Unification]. In this case, it seems that the Atom/Max case may occur, hence a relaxed version. *) -let gen_check_eq strict g u v = - match u,v with - | Atom ul, Atom vl -> check_equal g ul vl - | Max(ule,ult), Max(vle,vlt) -> - (* TODO: remove elements of lt in le! *) - compare_list (check_equal g) ule vle && - compare_list (check_equal g) ult vlt - | _ -> - (* not complete! (Atom(u) = Max([u],[]) *) - if strict then anomaly (str "check_eq") - else false (* in non-strict mode, under-approximation *) - -let check_eq = gen_check_eq true -let lax_check_eq = gen_check_eq false +(* let gen_check_eq strict g u v = *) +(* match u,v with *) +(* | Atom ul, Atom vl -> check_equal g ul vl *) +(* | Max(ule,ult), Max(vle,vlt) -> *) +(* (\* TODO: remove elements of lt in le! *\) *) +(* compare_list (check_equal g) ule vle && *) +(* compare_list (check_equal g) ult vlt *) +(* | _ -> *) +(* (\* not complete! (Atom(u) = Max([u],[]) *\) *) +(* if strict then anomaly (str "check_eq") *) +(* else false (\* in non-strict mode, under-approximation *\) *) + +(* let check_eq = gen_check_eq true *) +(* let lax_check_eq = gen_check_eq false *) +let check_eq g u v = + compare_list (check_equal_expr g) u v +let check_eq_level g u v = u == v || check_equal g u v +let lax_check_eq = check_eq + +let check_smaller_expr g (u,n) (v,m) = + if n <= m then + check_smaller g false u v + else if n - m = 1 then + check_smaller g true u v + else false + +let exists_bigger g ul l = + Huniv.exists (fun ul' -> + check_smaller_expr g (Hunivelt.node ul) (Hunivelt.node ul')) l let check_leq g u v = - match u,v with - | Atom ul, Atom vl -> check_smaller g false ul vl - | Max(le,lt), Atom vl -> - List.for_all (fun ul -> check_smaller g false ul vl) le && - List.for_all (fun ul -> check_smaller g true ul vl) lt - | _ -> anomaly (str "check_leq") + u == v || + match Universe.level u with + | Some l when Level.is_prop l -> true + | _ -> Huniv.for_all (fun ul -> exists_bigger g ul v) u (** Enforcing new constraints : [setlt], [setleq], [merge], [merge_disc] *) -(* setlt : UniverseLevel.t -> UniverseLevel.t -> reason -> unit *) +(* setlt : Level.t -> Level.t -> reason -> unit *) (* forces u > v *) (* this is normally an update of u in g rather than a creation. *) let setlt g arcu arcv = @@ -512,7 +1136,7 @@ let setlt_if (g,arcu) v = if is_lt g arcu arcv then g, arcu else setlt g arcu arcv -(* setleq : UniverseLevel.t -> UniverseLevel.t -> unit *) +(* setleq : Level.t -> Level.t -> unit *) (* forces u >= v *) (* this is normally an update of u in g rather than a creation. *) let setleq g arcu arcv = @@ -526,7 +1150,7 @@ let setleq_if (g,arcu) v = if is_leq g arcu arcv then g, arcu else setleq g arcu arcv -(* merge : UniverseLevel.t -> UniverseLevel.t -> unit *) +(* merge : Level.t -> Level.t -> unit *) (* we assume compare(u,v) = LE *) (* merge u v forces u ~ v with repr u as canonical repr *) let merge g arcu arcv = @@ -559,7 +1183,7 @@ let merge g arcu arcv = let g_arcu = List.fold_left setleq_if g_arcu w' in fst g_arcu -(* merge_disc : UniverseLevel.t -> UniverseLevel.t -> unit *) +(* merge_disc : Level.t -> Level.t -> unit *) (* we assume compare(u,v) = compare(v,u) = NLE *) (* merge_disc u v forces u ~ v with repr u as canonical repr *) let merge_disc g arc1 arc2 = @@ -579,36 +1203,37 @@ let merge_disc g arc1 arc2 = (* Universe inconsistency: error raised when trying to enforce a relation that would create a cycle in the graph of universes. *) -exception UniverseInconsistency of - constraint_type * universe * universe * explanation +type univ_inconsistency = constraint_type * universe * universe * explanation + +exception UniverseInconsistency of univ_inconsistency let error_inconsistency o u v (p:explanation) = - raise (UniverseInconsistency (o,Atom u,Atom v,p)) + raise (UniverseInconsistency (o,make u,make v,p)) -(* enforce_univ_leq : UniverseLevel.t -> UniverseLevel.t -> unit *) +(* enforce_univ_leq : Level.t -> Level.t -> unit *) (* enforce_univ_leq u v will force u<=v if possible, will fail otherwise *) let enforce_univ_leq u v g = let g,arcu = safe_repr g u in let g,arcv = safe_repr g v in if is_leq g arcu arcv then g else match compare g arcv arcu with - | LT p -> error_inconsistency Le u v (List.rev p) + | LT p -> error_inconsistency Le u v (List.rev (Lazy.force p)) | LE _ -> merge g arcv arcu | NLE -> fst (setleq g arcu arcv) | EQ -> anomaly (Pp.str "Univ.compare") -(* enforc_univ_eq : UniverseLevel.t -> UniverseLevel.t -> unit *) +(* enforc_univ_eq : Level.t -> Level.t -> unit *) (* enforc_univ_eq u v will force u=v if possible, will fail otherwise *) let enforce_univ_eq u v g = let g,arcu = safe_repr g u in let g,arcv = safe_repr g v in match compare g arcu arcv with | EQ -> g - | LT p -> error_inconsistency Eq u v (List.rev p) + | LT p -> error_inconsistency Eq v u (List.rev (Lazy.force p)) | LE _ -> merge g arcu arcv | NLE -> (match compare g arcv arcu with - | LT p -> error_inconsistency Eq u v (List.rev p) + | LT p -> error_inconsistency Eq u v (List.rev (Lazy.force p)) | LE _ -> merge g arcv arcu | NLE -> merge_disc g arcu arcv | EQ -> anomaly (Pp.str "Univ.compare")) @@ -620,16 +1245,20 @@ let enforce_univ_lt u v g = match compare g arcu arcv with | LT _ -> g | LE _ -> fst (setlt g arcu arcv) - | EQ -> error_inconsistency Lt u v [(Eq,Atom v)] + | EQ -> error_inconsistency Lt u v [(Eq,make v)] | NLE -> (match compare_neq false g arcv arcu with NLE -> fst (setlt g arcu arcv) | EQ -> anomaly (Pp.str "Univ.compare") - | (LE p|LT p) -> error_inconsistency Lt u v (List.rev p)) + | (LE p|LT p) -> error_inconsistency Lt u v (List.rev (Lazy.force p))) -(* Constraints and sets of consrtaints. *) +let empty_universes = LMap.empty +let initial_universes = enforce_univ_lt Level.prop Level.set LMap.empty +let is_initial_universes g = LMap.equal (==) g initial_universes -type univ_constraint = UniverseLevel.t * constraint_type * UniverseLevel.t +(* Constraints and sets of constraints. *) + +type univ_constraint = Level.t * constraint_type * Level.t let enforce_constraint cst g = match cst with @@ -637,6 +1266,14 @@ let enforce_constraint cst g = | (u,Le,v) -> enforce_univ_leq u v g | (u,Eq,v) -> enforce_univ_eq u v g +let pr_constraint_type op = + let op_str = match op with + | Lt -> " < " + | Le -> " <= " + | Eq -> " = " + in str op_str + + module UConstraintOrd = struct type t = univ_constraint @@ -644,51 +1281,566 @@ struct let i = constraint_type_ord c c' in if not (Int.equal i 0) then i else - let i' = UniverseLevel.compare u u' in + let i' = Level.compare u u' in if not (Int.equal i' 0) then i' - else UniverseLevel.compare v v' + else Level.compare v v' end -module Constraint = Set.Make(UConstraintOrd) +module Constraint = +struct + module S = Set.Make(UConstraintOrd) + include S -type constraints = Constraint.t + let pr c = + fold (fun (u1,op,u2) pp_std -> + pp_std ++ Level.pr u1 ++ pr_constraint_type op ++ + Level.pr u2 ++ fnl () ) c (str "") + +end let empty_constraint = Constraint.empty let is_empty_constraint = Constraint.is_empty +let union_constraint = Constraint.union let eq_constraint = Constraint.equal -let union_constraints = Constraint.union +type constraints = Constraint.t + +module Hconstraint = + Hashcons.Make( + struct + type t = univ_constraint + type u = universe_level -> universe_level + let hashcons hul (l1,k,l2) = (hul l1, k, hul l2) + let equal (l1,k,l2) (l1',k',l2') = + l1 == l1' && k == k' && l2 == l2' + let hash = Hashtbl.hash + end) + +module Hconstraints = + Hashcons.Make( + struct + type t = constraints + type u = univ_constraint -> univ_constraint + let hashcons huc s = + Constraint.fold (fun x -> Constraint.add (huc x)) s Constraint.empty + let equal s s' = + List.for_all2eq (==) + (Constraint.elements s) + (Constraint.elements s') + let hash = Hashtbl.hash + end) + +let hcons_constraint = Hashcons.simple_hcons Hconstraint.generate Level.hcons +let hcons_constraints = Hashcons.simple_hcons Hconstraints.generate hcons_constraint + +type universe_constraint_type = ULe | UEq | ULub + +type universe_constraint = universe * universe_constraint_type * universe +module UniverseConstraints = struct + module S = Set.Make( + struct + type t = universe_constraint + + let compare_type c c' = + match c, c' with + | ULe, ULe -> 0 + | ULe, _ -> -1 + | _, ULe -> 1 + | UEq, UEq -> 0 + | UEq, _ -> -1 + | ULub, ULub -> 0 + | ULub, _ -> 1 + + let compare (u,c,v) (u',c',v') = + let i = compare_type c c' in + if Int.equal i 0 then + let i' = Universe.compare u u' in + if Int.equal i' 0 then Universe.compare v v' + else + if c != ULe && Universe.compare u v' = 0 && Universe.compare v u' = 0 then 0 + else i' + else i + end) + + include S + + let add (l,d,r as cst) s = + if Universe.eq l r then s + else add cst s + + let tr_dir = function + | ULe -> Le + | UEq -> Eq + | ULub -> Eq + + let op_str = function ULe -> " <= " | UEq -> " = " | ULub -> " /\\ " + + let pr c = + fold (fun (u1,op,u2) pp_std -> + pp_std ++ Universe.pr u1 ++ str (op_str op) ++ + Universe.pr u2 ++ fnl ()) c (str "") + + let equal x y = + x == y || equal x y -type constraint_function = - universe -> universe -> constraints -> constraints +end + +type universe_constraints = UniverseConstraints.t +type 'a universe_constrained = 'a * universe_constraints + +(** A value with universe constraints. *) +type 'a constrained = 'a * constraints + +let level_subst_of f = + fun l -> + try let u = f l in + match Universe.level u with + | None -> l + | Some l -> l + with Not_found -> l + +module Instance = struct + type t = Level.t array + + module HInstance = + Hashcons.Make( + struct + type _t = t + type t = _t + type u = Level.t -> Level.t + let hashcons huniv a = + CArray.smartmap huniv a + + let equal t1 t2 = + t1 == t2 || + (Int.equal (Array.length t1) (Array.length t2) && + let rec aux i = + (Int.equal i (Array.length t1)) || (t1.(i) == t2.(i) && aux (i + 1)) + in aux 0) + + let hash = Hashtbl.hash + end) + + let hcons_instance = Hashcons.simple_hcons HInstance.generate Level.hcons + + let hcons = hcons_instance + let empty = [||] + let is_empty x = Int.equal (Array.length x) 0 + + let eq t u = t == u || CArray.for_all2 Level.eq t u + + let of_array a = a + let to_array a = a + + let eqeq t1 t2 = + t1 == t2 || + (Int.equal (Array.length t1) (Array.length t2) && + let rec aux i = + (Int.equal i (Array.length t1)) || (t1.(i) == t2.(i) && aux (i + 1)) + in aux 0) + + let subst_fn fn t = CArray.smartmap fn t + let subst s t = CArray.smartmap (fun x -> try LMap.find x s with Not_found -> x) t + + let levels x = LSet.of_array x + + let pr = + prvect_with_sep spc Level.pr + + let append x y = + if Array.length x = 0 then y + else if Array.length y = 0 then x + else Array.append x y + + let max_level i = + if Array.is_empty i then 0 + else + let l = CArray.last i in + match l with + | Level.Level (i,_) -> i + | _ -> assert false + + let check_eq g t1 t2 = + t1 == t2 || + (Int.equal (Array.length t1) (Array.length t2) && + let rec aux i = + (Int.equal i (Array.length t1)) || (check_eq_level g t1.(i) t2.(i) && aux (i + 1)) + in aux 0) + +end + +type universe_instance = Instance.t + +type 'a puniverses = 'a * Instance.t +let out_punivs (x, y) = x +let in_punivs x = (x, Instance.empty) + +(** A context of universe levels with universe constraints, + representiong local universe variables and constraints *) + +module UContext = +struct + type t = Instance.t constrained + + let make x = x + + (** Universe contexts (variables as a list) *) + let empty = (Instance.empty, Constraint.empty) + let is_empty (univs, cst) = Instance.is_empty univs && Constraint.is_empty cst + + let pr (univs, cst as ctx) = + if is_empty ctx then mt() else + Instance.pr univs ++ str " |= " ++ v 1 (Constraint.pr cst) + + let hcons (univs, cst) = + (Instance.hcons univs, hcons_constraints cst) + + let instance (univs, cst) = univs + let constraints (univs, cst) = cst + + let union (univs, cst) (univs', cst') = + Instance.append univs univs', Constraint.union cst cst' +end + +type universe_context = UContext.t +let hcons_universe_context = UContext.hcons + +(** A set of universes with universe constraints. + We linearize the set to a list after typechecking. + Beware, representation could change. +*) + +module ContextSet = +struct + type t = universe_set constrained + + let empty = (LSet.empty, Constraint.empty) + let is_empty (univs, cst) = LSet.is_empty univs && Constraint.is_empty cst + + let of_context (ctx,cst) = + (Instance.levels ctx, cst) + + let of_set s = (s, Constraint.empty) + let singleton l = of_set (LSet.singleton l) + let of_instance i = of_set (Instance.levels i) + + let union (univs, cst) (univs', cst') = + LSet.union univs univs', Constraint.union cst cst' + + let diff (univs, cst) (univs', cst') = + LSet.diff univs univs', Constraint.diff cst cst' + + let add_constraints (univs, cst) cst' = + univs, Constraint.union cst cst' + + let add_universes univs ctx = + union (of_instance univs) ctx + + let to_context (ctx, cst) = + (Array.of_list (LSet.elements ctx), cst) + + let of_context (ctx, cst) = + (Instance.levels ctx, cst) + + let pr (univs, cst as ctx) = + if is_empty ctx then mt() else + LSet.pr univs ++ str " |= " ++ v 1 (Constraint.pr cst) + + let constraints (univs, cst) = cst + let levels (univs, cst) = univs + +end + +type universe_context_set = ContextSet.t + +(** A value in a universe context (resp. context set). *) +type 'a in_universe_context = 'a * universe_context +type 'a in_universe_context_set = 'a * universe_context_set + +(** A universe level substitution, note that no algebraic universes are + involved *) +type universe_level_subst = universe_level universe_map + +(** A full substitution might involve algebraic universes *) +type universe_subst = universe universe_map + +(** Pretty-printing *) +let pr_constraints = Constraint.pr + +let pr_universe_context = UContext.pr + +let pr_universe_context_set = ContextSet.pr + +let pr_universe_subst = + LMap.pr (fun u -> str" := " ++ Universe.pr u ++ spc ()) + +let pr_universe_level_subst = + LMap.pr (fun u -> str" := " ++ Level.pr u ++ spc ()) + +let constraints_of (_, cst) = cst + +let constraint_depend (l,d,r) u = + Level.eq l u || Level.eq l r + +let constraint_depend_list (l,d,r) us = + List.mem l us || List.mem r us + +let constraints_depend cstr us = + Constraint.exists (fun c -> constraint_depend_list c us) cstr + +let remove_dangling_constraints dangling cst = + Constraint.fold (fun (l,d,r as cstr) cst' -> + if List.mem l dangling || List.mem r dangling then cst' + else + (** Unnecessary constraints Prop <= u *) + if Level.eq l Level.prop && d == Le then cst' + else Constraint.add cstr cst') cst Constraint.empty + +let check_context_subset (univs, cst) (univs', cst') = + let newunivs, dangling = List.partition (fun u -> LSet.mem u univs) (Array.to_list univs') in + (* Some universe variables that don't appear in the term + are still mentionned in the constraints. This is the + case for "fake" universe variables that correspond to +1s. *) + (* if not (CList.is_empty dangling) then *) + (* todo ("A non-empty set of inferred universes do not appear in the term or type"); *) + (* (not (constraints_depend cst' dangling));*) + (* TODO: check implication *) + (** Remove local universes that do not appear in any constraint, they + are really entirely parametric. *) + (* let newunivs, dangling' = List.partition (fun u -> constraints_depend cst [u]) newunivs in *) + let cst' = remove_dangling_constraints dangling cst in + Array.of_list newunivs, cst' + +(** Substitutions. *) + +let make_universe_subst inst (ctx, csts) = + try Array.fold_left2 (fun acc c i -> LMap.add c (Universe.make i) acc) + LMap.empty ctx inst + with Invalid_argument _ -> + anomaly (Pp.str "Mismatched instance and context when building universe substitution") + +let empty_subst = LMap.empty +let is_empty_subst = LMap.is_empty + +let empty_level_subst = LMap.empty +let is_empty_level_subst = LMap.is_empty + +(** Substitution functions *) + +(** With level to level substitutions. *) +let subst_univs_level_level subst l = + try LMap.find l subst + with Not_found -> l + +let rec normalize_univs_level_level subst l = + try + let l' = LMap.find l subst in + normalize_univs_level_level subst l' + with Not_found -> l + +let subst_univs_level_fail subst l = + try match Universe.level (subst l) with + | Some l' -> l' + | None -> l + with Not_found -> l + +let rec subst_univs_level_universe subst u = + let u' = Universe.smartmap (Universe.Expr.map (subst_univs_level_level subst)) u in + if u == u' then u + else Universe.sort u' + +let subst_univs_level_constraint subst (u,d,v) = + let u' = subst_univs_level_level subst u + and v' = subst_univs_level_level subst v in + if d != Lt && Level.eq u' v' then None + else Some (u',d,v') + +let subst_univs_level_constraints subst csts = + Constraint.fold + (fun c -> Option.fold_right Constraint.add (subst_univs_level_constraint subst c)) + csts Constraint.empty + +(* let subst_univs_level_constraint_key = Profile.declare_profile "subst_univs_level_constraint";; *) +(* let subst_univs_level_constraint = *) +(* Profile.profile2 subst_univs_level_constraint_key subst_univs_level_constraint *) + +(** With level to universe substitutions. *) +type universe_subst_fn = universe_level -> universe + +let make_subst subst = fun l -> LMap.find l subst + +let subst_univs_level fn l = + try fn l + with Not_found -> make l + +let subst_univs_expr_opt fn (l,n) = + try Some (Universe.addn n (fn l)) + with Not_found -> None + +let subst_univs_universe fn ul = + let subst, nosubst = + Universe.Huniv.fold (fun u (subst,nosubst) -> + match subst_univs_expr_opt fn (Hunivelt.node u) with + | Some a' -> (a' :: subst, nosubst) + | None -> (subst, u :: nosubst)) + ul ([], []) + in + if CList.is_empty subst then ul + else + let substs = + List.fold_left Universe.merge_univs Universe.empty subst + in + List.fold_left (fun acc u -> Universe.merge_univs acc (Universe.Huniv.tip u)) + substs nosubst + +let subst_univs_constraint fn (u,d,v) = + let u' = subst_univs_level fn u and v' = subst_univs_level fn v in + if d != Lt && Universe.eq u' v' then None + else Some (u',d,v') + +let subst_univs_universe_constraint fn (u,d,v) = + let u' = subst_univs_universe fn u and v' = subst_univs_universe fn v in + if Universe.eq u' v' then None + else Some (u',d,v') + +(** Constraint functions. *) + +type 'a constraint_function = 'a -> 'a -> constraints -> constraints let constraint_add_leq v u c = - (* We just discard trivial constraints like Set<=u or u<=u *) - if UniverseLevel.equal v UniverseLevel.Set || UniverseLevel.equal v u then c - else Constraint.add (v,Le,u) c + (* We just discard trivial constraints like u<=u *) + if Expr.eq v u then c + else + match v, u with + | (x,n), (y,m) -> + let j = m - n in + if j = -1 (* n = m+1, v+1 <= u <-> v < u *) then + Constraint.add (x,Lt,y) c + else if j <= -1 (* n = m+k, v+k <= u <-> v+(k-1) < u *) then + if Level.eq x y then (* u+(k+1) <= u *) + raise (UniverseInconsistency (Le, Universe.tip v, Universe.tip u, [])) + else anomaly (Pp.str"Unable to handle arbitrary u+k <= v constraints") + else if j = 0 then + Constraint.add (x,Le,y) c + else (* j >= 1 *) (* m = n + k, u <= v+k *) + if Level.eq x y then c (* u <= u+k, trivial *) + else if Level.is_small x then c (* Prop,Set <= u+S k, trivial *) + else anomaly (Pp.str"Unable to handle arbitrary u <= v+k constraints") + +let check_univ_eq u v = Universe.eq u v + +let check_univ_leq_one u v = Universe.exists (Expr.leq u) v + +let check_univ_leq u v = + Universe.for_all (fun u -> check_univ_leq_one u v) u let enforce_leq u v c = - match u, v with - | Atom u, Atom v -> constraint_add_leq u v c - | Max (gel,gtl), Atom v -> - let d = List.fold_right (fun u -> constraint_add_leq u v) gel c in - List.fold_right (fun u -> Constraint.add (u,Lt,v)) gtl d - | _ -> anomaly (Pp.str "A universe bound can only be a variable") + match Huniv.node v with + | Universe.Huniv.Cons (v, n) when Universe.is_empty n -> + Universe.Huniv.fold (fun u -> constraint_add_leq (Hunivelt.node u) (Hunivelt.node v)) u c + | _ -> anomaly (Pp.str"A universe bound can only be a variable") + +let enforce_leq u v c = + if check_univ_leq u v then c + else enforce_leq u v c + +let enforce_eq_level u v c = + (* We discard trivial constraints like u=u *) + if Level.eq u v then c + else if Level.apart u v then + error_inconsistency Eq u v [] + else Constraint.add (u,Eq,v) c let enforce_eq u v c = - match (u,v) with - | Atom u, Atom v -> - (* We discard trivial constraints like u=u *) - if UniverseLevel.equal u v then c else Constraint.add (u,Eq,v) c + match Universe.level u, Universe.level v with + | Some u, Some v -> enforce_eq_level u v c | _ -> anomaly (Pp.str "A universe comparison can only happen between variables") +let enforce_eq u v c = + if check_univ_eq u v then c + else enforce_eq u v c + +let enforce_leq_level u v c = + if Level.eq u v then c else Constraint.add (u,Le,v) c + +let enforce_eq_instances = CArray.fold_right2 enforce_eq_level + +type 'a universe_constraint_function = 'a -> 'a -> universe_constraints -> universe_constraints + +let enforce_eq_instances_univs strict t1 t2 c = + let d = if strict then ULub else UEq in + CArray.fold_right2 (fun x y -> UniverseConstraints.add (Universe.make x, d, Universe.make y)) + t1 t2 c + let merge_constraints c g = Constraint.fold enforce_constraint c g +(* let merge_constraints_key = Profile.declare_profile "merge_constraints";; *) +(* let merge_constraints = Profile.profile2 merge_constraints_key merge_constraints *) + +let check_constraint g (l,d,r) = + match d with + | Eq -> check_equal g l r + | Le -> check_smaller g false l r + | Lt -> check_smaller g true l r + +let check_constraints c g = + Constraint.for_all (check_constraint g) c + +(* let check_constraints_key = Profile.declare_profile "check_constraints";; *) +(* let check_constraints = *) +(* Profile.profile2 check_constraints_key check_constraints *) + +let enforce_univ_constraint (u,d,v) = + match d with + | Eq -> enforce_eq u v + | Le -> enforce_leq u v + | Lt -> enforce_leq (super u) v + +let subst_univs_constraints subst csts = + Constraint.fold + (fun c -> Option.fold_right enforce_univ_constraint (subst_univs_constraint subst c)) + csts Constraint.empty + +(* let subst_univs_constraints_key = Profile.declare_profile "subst_univs_constraints";; *) +(* let subst_univs_constraints = *) +(* Profile.profile2 subst_univs_constraints_key subst_univs_constraints *) + +let subst_univs_universe_constraints subst csts = + UniverseConstraints.fold + (fun c -> Option.fold_right UniverseConstraints.add (subst_univs_universe_constraint subst c)) + csts UniverseConstraints.empty + +(* let subst_univs_universe_constraints_key = Profile.declare_profile "subst_univs_universe_constraints";; *) +(* let subst_univs_universe_constraints = *) +(* Profile.profile2 subst_univs_universe_constraints_key subst_univs_universe_constraints *) + +(** Substitute instance inst for ctx in csts *) +let instantiate_univ_context subst (_, csts) = + subst_univs_constraints (make_subst subst) csts + +let check_consistent_constraints (ctx,cstrs) cstrs' = + (* TODO *) () + +let to_constraints g s = + let rec tr (x,d,y) acc = + let add l d l' acc = Constraint.add (l,UniverseConstraints.tr_dir d,l') acc in + match Universe.level x, d, Universe.level y with + | Some l, (ULe | UEq | ULub), Some l' -> add l d l' acc + | _, ULe, Some l' -> enforce_leq x y acc + | _, ULub, _ -> acc + | _, d, _ -> + let f = if d == ULe then check_leq else check_eq in + if f g x y then acc else + raise (Invalid_argument + "to_constraints: non-trivial algebraic constraint between universes") + in UniverseConstraints.fold tr s Constraint.empty + + (* Normalization *) let lookup_level u g = - try Some (UniverseLMap.find u g) with Not_found -> None + try Some (LMap.find u g) with Not_found -> None (** [normalize_universes g] returns a graph where all edges point directly to the canonical representent of their target. The output @@ -702,20 +1854,20 @@ let normalize_universes g = | Some x -> x, cache | None -> match Lazy.force arc with | None -> - u, UniverseLMap.add u u cache + u, LMap.add u u cache | Some (Canonical {univ=v; lt=_; le=_}) -> - v, UniverseLMap.add u v cache + v, LMap.add u v cache | Some (Equiv v) -> let v, cache = visit v (lazy (lookup_level v g)) cache in - v, UniverseLMap.add u v cache + v, LMap.add u v cache in - let cache = UniverseLMap.fold + let cache = LMap.fold (fun u arc cache -> snd (visit u (Lazy.lazy_from_val (Some arc)) cache)) - g UniverseLMap.empty + g LMap.empty in - let repr x = UniverseLMap.find x cache in + let repr x = LMap.find x cache in let lrepr us = List.fold_left - (fun e x -> UniverseLSet.add (repr x) e) UniverseLSet.empty us + (fun e x -> LSet.add (repr x) e) LSet.empty us in let canonicalize u = function | Equiv _ -> Equiv (repr u) @@ -723,24 +1875,24 @@ let normalize_universes g = assert (u == v); (* avoid duplicates and self-loops *) let lt = lrepr lt and le = lrepr le in - let le = UniverseLSet.filter - (fun x -> x != u && not (UniverseLSet.mem x lt)) le + let le = LSet.filter + (fun x -> x != u && not (LSet.mem x lt)) le in - UniverseLSet.iter (fun x -> assert (x != u)) lt; + LSet.iter (fun x -> assert (x != u)) lt; Canonical { univ = v; - lt = UniverseLSet.elements lt; - le = UniverseLSet.elements le; + lt = LSet.elements lt; + le = LSet.elements le; rank = rank } in - UniverseLMap.mapi canonicalize g + LMap.mapi canonicalize g (** [check_sorted g sorted]: [g] being a universe graph, [sorted] being a map to levels, checks that all constraints in [g] are satisfied in [sorted]. *) let check_sorted g sorted = - let get u = try UniverseLMap.find u sorted with + let get u = try LMap.find u sorted with | Not_found -> assert false in let iter u arc = @@ -751,7 +1903,7 @@ let check_sorted g sorted = List.iter (fun v -> assert (lu <= get v)) le; List.iter (fun v -> assert (lu < get v)) lt in - UniverseLMap.iter iter g + LMap.iter iter g (** Bellman-Ford algorithm with a few customizations: @@ -765,7 +1917,7 @@ let bellman_ford bottom g = | None -> () | Some _ -> assert false in - let ( << ) a b = match a, b with + let ( <? ) a b = match a, b with | _, None -> true | None, _ -> false | Some x, Some y -> (x : int) < y @@ -774,38 +1926,38 @@ let bellman_ford bottom g = | Some x -> Some (x-y) and push u x m = match x with | None -> m - | Some y -> UniverseLMap.add u y m + | Some y -> LMap.add u y m in let relax u v uv distances = let x = lookup_level u distances ++ uv in - if x << lookup_level v distances then push v x distances + if x <? lookup_level v distances then push v x distances else distances in - let init = UniverseLMap.add bottom 0 UniverseLMap.empty in - let vertices = UniverseLMap.fold (fun u arc res -> - let res = UniverseLSet.add u res in + let init = LMap.add bottom 0 LMap.empty in + let vertices = LMap.fold (fun u arc res -> + let res = LSet.add u res in match arc with - | Equiv e -> UniverseLSet.add e res + | Equiv e -> LSet.add e res | Canonical {univ=univ; lt=lt; le=le} -> assert (u == univ); - let add res v = UniverseLSet.add v res in + let add res v = LSet.add v res in let res = List.fold_left add res le in let res = List.fold_left add res lt in - res) g UniverseLSet.empty + res) g LSet.empty in let g = let node = Canonical { univ = bottom; lt = []; - le = UniverseLSet.elements vertices; + le = LSet.elements vertices; rank = 0 - } in UniverseLMap.add bottom node g + } in LMap.add bottom node g in let rec iter count accu = if count <= 0 then accu else - let accu = UniverseLMap.fold (fun u arc res -> match arc with + let accu = LMap.fold (fun u arc res -> match arc with | Equiv e -> relax e u 0 (relax u e 0 res) | Canonical {univ=univ; lt=lt; le=le} -> assert (u == univ); @@ -814,16 +1966,16 @@ let bellman_ford bottom g = res) g accu in iter (count-1) accu in - let distances = iter (UniverseLSet.cardinal vertices) init in - let () = UniverseLMap.iter (fun u arc -> + let distances = iter (LSet.cardinal vertices) init in + let () = LMap.iter (fun u arc -> let lu = lookup_level u distances in match arc with | Equiv v -> let lv = lookup_level v distances in - assert (not (lu << lv) && not (lv << lu)) + assert (not (lu <? lv) && not (lv <? lu)) | Canonical {univ=univ; lt=lt; le=le} -> assert (u == univ); - List.iter (fun v -> assert (not (lu ++ 0 << lookup_level v distances))) le; - List.iter (fun v -> assert (not (lu ++ 1 << lookup_level v distances))) lt) g + List.iter (fun v -> assert (not (lu ++ 0 <? lookup_level v distances))) le; + List.iter (fun v -> assert (not (lu ++ 1 <? lookup_level v distances))) lt) g in distances (** [sort_universes g] builds a map from universes in [g] to natural @@ -837,23 +1989,23 @@ let bellman_ford bottom g = let sort_universes orig = let mp = Names.DirPath.make [Names.Id.of_string "Type"] in let rec make_level accu g i = - let type0 = UniverseLevel.Level (i, mp) in + let type0 = Level.make mp i in let distances = bellman_ford type0 g in - let accu, continue = UniverseLMap.fold (fun u x (accu, continue) -> + let accu, continue = LMap.fold (fun u x (accu, continue) -> let continue = continue || x < 0 in let accu = - if Int.equal x 0 && u != type0 then UniverseLMap.add u i accu + if Int.equal x 0 && u != type0 then LMap.add u i accu else accu in accu, continue) distances (accu, false) in - let filter x = not (UniverseLMap.mem x accu) in + let filter x = not (LMap.mem x accu) in let push g u = - if UniverseLMap.mem u g then g else UniverseLMap.add u (Equiv u) g + if LMap.mem u g then g else LMap.add u (Equiv u) g in - let g = UniverseLMap.fold (fun u arc res -> match arc with + let g = LMap.fold (fun u arc res -> match arc with | Equiv v as x -> begin match filter u, filter v with - | true, true -> UniverseLMap.add u x res + | true, true -> LMap.add u x res | true, false -> push res u | false, true -> push res v | false, false -> res @@ -863,24 +2015,24 @@ let sort_universes orig = if filter u then let lt = List.filter filter lt in let le = List.filter filter le in - UniverseLMap.add u (Canonical {univ=u; lt=lt; le=le; rank=r}) res + LMap.add u (Canonical {univ=u; lt=lt; le=le; rank=r}) res else let res = List.fold_left (fun g u -> if filter u then push g u else g) res lt in let res = List.fold_left (fun g u -> if filter u then push g u else g) res le in - res) g UniverseLMap.empty + res) g LMap.empty in if continue then make_level accu g (i+1) else i, accu in - let max, levels = make_level UniverseLMap.empty orig 0 in + let max, levels = make_level LMap.empty orig 0 in (* defensively check that the result makes sense *) check_sorted orig levels; - let types = Array.init (max+1) (fun x -> UniverseLevel.Level (x, mp)) in - let g = UniverseLMap.map (fun x -> Equiv types.(x)) levels in + let types = Array.init (max+1) (fun x -> Level.make mp x) in + let g = LMap.map (fun x -> Equiv types.(x)) levels in let g = let rec aux i g = if i < max then let u = types.(i) in - let g = UniverseLMap.add u (Canonical { + let g = LMap.add u (Canonical { univ = u; le = []; lt = [types.(i+1)]; @@ -893,26 +2045,19 @@ let sort_universes orig = (**********************************************************************) (* Tools for sort-polymorphic inductive types *) -(* Temporary inductive type levels *) - -let fresh_local_univ, set_remote_fresh_local_univ = - RemoteCounter.new_counter ~name:"local_univ" 0 ~incr:((+) 1) - ~build:(fun n -> Atom (UniverseLevel.Level (n, Names.DirPath.empty))) - (* Miscellaneous functions to remove or test local univ assumed to occur only in the le constraints *) -let make_max = function - | ([u],[]) -> Atom u - | (le,lt) -> Max (le,lt) - -let remove_large_constraint u = function - | Atom u' as x -> if UniverseLevel.equal u u' then Max ([],[]) else x - | Max (le,lt) -> make_max (List.remove UniverseLevel.equal u le,lt) +let remove_large_constraint u v min = + match Universe.level v with + | Some u' -> if Level.eq u u' then min else v + | None -> Huniv.remove (Hunivelt.make (Universe.Expr.make u)) v -let is_direct_constraint u = function - | Atom u' -> UniverseLevel.equal u u' - | Max (le,lt) -> List.mem_f UniverseLevel.equal u le +(* [is_direct_constraint u v] if level [u] is a member of universe [v] *) +let is_direct_constraint u v = + match Universe.level v with + | Some u' -> Level.eq u u' + | None -> Huniv.mem (Hunivelt.make (Universe.Expr.make u)) v (* Solve a system of universe constraint of the form @@ -932,29 +2077,31 @@ let is_direct_sort_constraint s v = match s with | Some u -> is_direct_constraint u v | None -> false -let solve_constraints_system levels level_bounds = +let solve_constraints_system levels level_bounds level_min = let levels = - Array.map (Option.map (function Atom u -> u | _ -> anomaly (Pp.str "expects Atom"))) + Array.map (Option.map (fun u -> match level u with Some u -> u | _ -> anomaly (Pp.str"expects Atom"))) levels in let v = Array.copy level_bounds in let nind = Array.length v in for i=0 to nind-1 do for j=0 to nind-1 do if not (Int.equal i j) && is_direct_sort_constraint levels.(j) v.(i) then - v.(i) <- sup v.(i) level_bounds.(j) + (v.(i) <- Universe.sup v.(i) level_bounds.(j); + level_min.(i) <- Universe.sup level_min.(i) level_min.(j)) done; for j=0 to nind-1 do match levels.(j) with - | Some u -> v.(i) <- remove_large_constraint u v.(i) + | Some u -> v.(i) <- remove_large_constraint u v.(i) level_min.(i) | None -> () done done; v let subst_large_constraint u u' v = - match u with - | Atom u -> - if is_direct_constraint u v then sup u' (remove_large_constraint u v) + match level u with + | Some u -> + if is_direct_constraint u v then + Universe.sup u' (remove_large_constraint u v type0m_univ) else v | _ -> anomaly (Pp.str "expect a universe level") @@ -963,21 +2110,30 @@ let subst_large_constraints = List.fold_right (fun (u,u') -> subst_large_constraint u u') let no_upper_constraints u cst = - match u with - | Atom u -> - let test (u1, _, _) = not (UniverseLevel.equal u1 u) in + match level u with + | Some u -> + let test (u1, _, _) = + not (Int.equal (Level.compare u1 u) 0) in Constraint.for_all test cst - | Max _ -> anomaly (Pp.str "no_upper_constraints") + | _ -> anomaly (Pp.str "no_upper_constraints") (* Is u mentionned in v (or equals to v) ? *) -let level_list_mem u l = List.mem_f UniverseLevel.equal u l - let univ_depends u v = - match u, v with - | Atom u, Atom v -> UniverseLevel.equal u v - | Atom u, Max (gel,gtl) -> level_list_mem u gel || level_list_mem u gtl - | _ -> anomaly (Pp.str "univ_depends given a non-atomic 1st arg") + match atom u with + | Some u -> Huniv.mem u v + | _ -> anomaly (Pp.str"univ_depends given a non-atomic 1st arg") + +let constraints_of_universes g = + let constraints_of u v acc = + match v with + | Canonical {univ=u; lt=lt; le=le} -> + let acc = List.fold_left (fun acc v -> Constraint.add (u,Lt,v) acc) acc lt in + let acc = List.fold_left (fun acc v -> Constraint.add (u,Le,v) acc) acc le in + acc + | Equiv v -> Constraint.add (u,Eq,v) acc + in + LMap.fold constraints_of g Constraint.empty (* Pretty-printing *) @@ -989,101 +2145,67 @@ let pr_arc = function | [], _ | _, [] -> mt () | _ -> spc () in - pr_uni_level u ++ str " " ++ + Level.pr u ++ str " " ++ v 0 - (pr_sequence (fun v -> str "< " ++ pr_uni_level v) lt ++ + (pr_sequence (fun v -> str "< " ++ Level.pr v) lt ++ opt_sep ++ - pr_sequence (fun v -> str "<= " ++ pr_uni_level v) le) ++ + pr_sequence (fun v -> str "<= " ++ Level.pr v) le) ++ fnl () | u, Equiv v -> - pr_uni_level u ++ str " = " ++ pr_uni_level v ++ fnl () + Level.pr u ++ str " = " ++ Level.pr v ++ fnl () let pr_universes g = - let graph = UniverseLMap.fold (fun u a l -> (u,a)::l) g [] in + let graph = LMap.fold (fun u a l -> (u,a)::l) g [] in prlist pr_arc graph -let pr_constraints c = - Constraint.fold (fun (u1,op,u2) pp_std -> - let op_str = match op with - | Lt -> " < " - | Le -> " <= " - | Eq -> " = " - in pp_std ++ pr_uni_level u1 ++ str op_str ++ - pr_uni_level u2 ++ fnl () ) c (str "") - (* Dumping constraints to a file *) let dump_universes output g = let dump_arc u = function | Canonical {univ=u; lt=lt; le=le} -> - let u_str = UniverseLevel.to_string u in - List.iter (fun v -> output Lt u_str (UniverseLevel.to_string v)) lt; - List.iter (fun v -> output Le u_str (UniverseLevel.to_string v)) le + let u_str = Level.to_string u in + List.iter (fun v -> output Lt u_str (Level.to_string v)) lt; + List.iter (fun v -> output Le u_str (Level.to_string v)) le | Equiv v -> - output Eq (UniverseLevel.to_string u) (UniverseLevel.to_string v) + output Eq (Level.to_string u) (Level.to_string v) in - UniverseLMap.iter dump_arc g + LMap.iter dump_arc g -(* Hash-consing *) - -module Hunivlevel = +module Huniverse_set = Hashcons.Make( struct - type t = universe_level - type u = Names.DirPath.t -> Names.DirPath.t - let hashcons hdir = function - | UniverseLevel.Set -> UniverseLevel.Set - | UniverseLevel.Level (n,d) -> UniverseLevel.Level (n,hdir d) - let equal l1 l2 = - l1 == l2 || - match l1,l2 with - | UniverseLevel.Set, UniverseLevel.Set -> true - | UniverseLevel.Level (n,d), UniverseLevel.Level (n',d') -> - n == n' && d == d' - | _ -> false - let hash = UniverseLevel.hash - end) - -module Huniv = - Hashcons.Make( - struct - type t = universe + type t = universe_set type u = universe_level -> universe_level - let hashcons hdir = function - | Atom u -> Atom (hdir u) - | Max (gel,gtl) -> Max (List.map hdir gel, List.map hdir gtl) - let equal u v = - u == v || - match u, v with - | Atom u, Atom v -> u == v - | Max (gel,gtl), Max (gel',gtl') -> - (List.for_all2eq (==) gel gel') && - (List.for_all2eq (==) gtl gtl') - | _ -> false - let hash = Universe.hash + let hashcons huc s = + LSet.fold (fun x -> LSet.add (huc x)) s LSet.empty + let equal s s' = + LSet.equal s s' + let hash = Hashtbl.hash end) -let hcons_univlevel = Hashcons.simple_hcons Hunivlevel.generate Names.DirPath.hcons -let hcons_univ = Hashcons.simple_hcons Huniv.generate hcons_univlevel +let hcons_universe_set = + Hashcons.simple_hcons Huniverse_set.generate Level.hcons -module Hconstraint = - Hashcons.Make( - struct - type t = univ_constraint - type u = universe_level -> universe_level - let hashcons hul (l1,k,l2) = (hul l1, k, hul l2) - let equal (l1,k,l2) (l1',k',l2') = - l1 == l1' && k == k' && l2 == l2' - let hash = Hashtbl.hash - end) +let hcons_universe_context_set (v, c) = + (hcons_universe_set v, hcons_constraints c) -module UConstraintHash = -struct - type t = univ_constraint - let hash = Hashtbl.hash -end -module Hconstraints = Set.Hashcons(UConstraintOrd)(UConstraintHash) +let hcons_univlevel = Level.hcons +let hcons_univ x = x (* Universe.hcons (Huniv.node x) *) +let equal_universes = Universe.equal_universes -let hcons_constraint = Hashcons.simple_hcons Hconstraint.generate hcons_univlevel -let hcons_constraints = Hashcons.simple_hcons Hconstraints.generate hcons_constraint +let explain_universe_inconsistency (o,u,v,p) = + let pr_rel = function + | Eq -> str"=" | Lt -> str"<" | Le -> str"<=" + in + let reason = match p with + [] -> mt() + | _::_ -> + str " because" ++ spc() ++ pr_uni v ++ + prlist (fun (r,v) -> spc() ++ pr_rel r ++ str" " ++ pr_uni v) + p ++ + (if Universe.eq (snd (List.last p)) u then mt() else + (spc() ++ str "= " ++ pr_uni u)) + in + str "Cannot enforce" ++ spc() ++ pr_uni u ++ spc() ++ + pr_rel o ++ spc() ++ pr_uni v ++ reason ++ str")" diff --git a/kernel/univ.mli b/kernel/univ.mli index 04267de70..9e7cc18b4 100644 --- a/kernel/univ.mli +++ b/kernel/univ.mli @@ -8,30 +8,67 @@ (** Universes. *) -module UniverseLevel : +module Level : sig type t (** Type of universe levels. A universe level is essentially a unique name that will be associated to constraints later on. *) + val set : t + val prop : t + val is_small : t -> bool + val compare : t -> t -> int (** Comparison function *) - val equal : t -> t -> bool + val eq : t -> t -> bool (** Equality function *) - val hash : t -> int + (* val hash : t -> int *) (** Hash function *) val make : Names.DirPath.t -> int -> t (** Create a new universe level from a unique identifier and an associated module path. *) + val pr : t -> Pp.std_ppcmds end -type universe_level = UniverseLevel.t +type universe_level = Level.t (** Alias name. *) +module LSet : +sig + include Set.S with type elt = universe_level + + val pr : t -> Pp.std_ppcmds +end + +type universe_set = LSet.t + +module LMap : +sig + include Map.S with type key = universe_level + + (** Favorizes the bindings in the first map. *) + val union : 'a t -> 'a t -> 'a t + val diff : 'a t -> 'a t -> 'a t + + val subst_union : 'a option t -> 'a option t -> 'a option t + + val elements : 'a t -> (universe_level * 'a) list + val of_list : (universe_level * 'a) list -> 'a t + val of_set : universe_set -> 'a -> 'a t + val mem : universe_level -> 'a t -> bool + val universes : 'a t -> universe_set + + val find_opt : universe_level -> 'a t -> 'a option + + val pr : ('a -> Pp.std_ppcmds) -> 'a t -> Pp.std_ppcmds +end + +type 'a universe_map = 'a LMap.t + module Universe : sig type t @@ -41,68 +78,260 @@ sig val compare : t -> t -> int (** Comparison function *) - val equal : t -> t -> bool + val eq : t -> t -> bool (** Equality function *) - val hash : t -> int + (* val hash : t -> int *) (** Hash function *) - val make : UniverseLevel.t -> t + val make : Level.t -> t (** Create a constraint-free universe out of a given level. *) + val pr : t -> Pp.std_ppcmds + + val level : t -> Level.t option + + val levels : t -> LSet.t + + val normalize : t -> t + + (** The type of a universe *) + val super : t -> t + + (** The max of 2 universes *) + val sup : t -> t -> t + + val type0m : t (** image of Prop in the universes hierarchy *) + val type0 : t (** image of Set in the universes hierarchy *) + val type1 : t (** the universe of the type of Prop/Set *) end type universe = Universe.t -(** Alias name. *) -module UniverseLSet : Set.S with type elt = universe_level +(** Alias name. *) +val pr_uni : universe -> Pp.std_ppcmds + (** The universes hierarchy: Type 0- = Prop <= Type 0 = Set <= Type 1 <= ... Typing of universes: Type 0-, Type 0 : Type 1; Type i : Type (i+1) if i>0 *) - -val type0m_univ : universe (** image of Prop in the universes hierarchy *) -val type0_univ : universe (** image of Set in the universes hierarchy *) -val type1_univ : universe (** the universe of the type of Prop/Set *) +val type0m_univ : universe +val type0_univ : universe +val type1_univ : universe val is_type0_univ : universe -> bool val is_type0m_univ : universe -> bool val is_univ_variable : universe -> bool +val is_small_univ : universe -> bool -val universe_level : universe -> universe_level option - -(** The type of a universe *) +val sup : universe -> universe -> universe val super : universe -> universe -(** The max of 2 universes *) -val sup : universe -> universe -> universe +val universe_level : universe -> universe_level option +val compare_levels : universe_level -> universe_level -> int +val eq_levels : universe_level -> universe_level -> bool + +(** Equality of formal universe expressions. *) +val equal_universes : universe -> universe -> bool (** {6 Graphs of universes. } *) type universes -type check_function = universes -> universe -> universe -> bool -val check_leq : check_function -val check_eq : check_function -val lax_check_eq : check_function (* same, without anomaly *) +type 'a check_function = universes -> 'a -> 'a -> bool +val check_leq : universe check_function +val check_eq : universe check_function +val lax_check_eq : universe check_function (* same, without anomaly *) (** The empty graph of universes *) +val empty_universes : universes + +(** The initial graph of universes: Prop < Set *) val initial_universes : universes val is_initial_universes : universes -> bool (** {6 Constraints. } *) -type constraints +type constraint_type = Lt | Le | Eq +type univ_constraint = universe_level * constraint_type * universe_level + +module Constraint : sig + include Set.S with type elt = univ_constraint +end -val empty_constraint : constraints -val union_constraints : constraints -> constraints -> constraints +type constraints = Constraint.t -val is_empty_constraint : constraints -> bool +val empty_constraint : constraints +val union_constraint : constraints -> constraints -> constraints val eq_constraint : constraints -> constraints -> bool -type constraint_function = universe -> universe -> constraints -> constraints +type universe_constraint_type = ULe | UEq | ULub + +type universe_constraint = universe * universe_constraint_type * universe +module UniverseConstraints : sig + include Set.S with type elt = universe_constraint + + val pr : t -> Pp.std_ppcmds +end + +type universe_constraints = UniverseConstraints.t +type 'a universe_constrained = 'a * universe_constraints + +(** A value with universe constraints. *) +type 'a constrained = 'a * constraints + +type universe_subst_fn = universe_level -> universe +type universe_level_subst_fn = universe_level -> universe_level + +(** A full substitution, might involve algebraic universes *) +type universe_subst = universe universe_map +type universe_level_subst = universe_level universe_map + +val level_subst_of : universe_subst_fn -> universe_level_subst_fn + +module Instance : +sig + type t + + val hcons : t -> t + val empty : t + val is_empty : t -> bool + + val eq : t -> t -> bool + + val of_array : Level.t array -> t + val to_array : t -> Level.t array + + (** Rely on physical equality of subterms only *) + val eqeq : t -> t -> bool + + val subst_fn : universe_level_subst_fn -> t -> t + val subst : universe_level_subst -> t -> t + + val pr : t -> Pp.std_ppcmds + + val append : t -> t -> t -val enforce_leq : constraint_function -val enforce_eq : constraint_function + val levels : t -> LSet.t + + val max_level : t -> int + + val check_eq : t check_function + +end + +type universe_instance = Instance.t + +type 'a puniverses = 'a * universe_instance +val out_punivs : 'a puniverses -> 'a +val in_punivs : 'a -> 'a puniverses + +(** A list of universes with universe constraints, + representiong local universe variables and constraints *) + +module UContext : +sig + type t + + val make : Instance.t constrained -> t + val empty : t + val is_empty : t -> bool + + val instance : t -> Instance.t + val constraints : t -> constraints + + (** Keeps the order of the instances *) + val union : t -> t -> t + +end + +type universe_context = UContext.t + +(** Universe contexts (as sets) *) + +module ContextSet : +sig + type t = universe_set constrained + + val empty : t + val is_empty : t -> bool + + val singleton : universe_level -> t + val of_instance : Instance.t -> t + val of_set : universe_set -> t + + val union : t -> t -> t + val diff : t -> t -> t + val add_constraints : t -> constraints -> t + val add_universes : Instance.t -> t -> t + + (** Arbitrary choice of linear order of the variables + and normalization of the constraints *) + val to_context : t -> universe_context + val of_context : universe_context -> t + + val constraints : t -> constraints + val levels : t -> universe_set +end + +(** A set of universes with universe constraints. + We linearize the set to a list after typechecking. + Beware, representation could change. +*) +type universe_context_set = ContextSet.t + +(** A value in a universe context (resp. context set). *) +type 'a in_universe_context = 'a * universe_context +type 'a in_universe_context_set = 'a * universe_context_set + +(** Constrained *) +val constraints_of : 'a constrained -> constraints + + +(** [check_context_subset s s'] checks that [s] is implied by [s'] as a set of constraints, + and shrinks [s'] to the set of variables declared in [s]. +. *) +val check_context_subset : universe_context_set -> universe_context -> universe_context + +(** Make a universe level substitution: the list must match the context variables. *) +val make_universe_subst : Instance.t -> universe_context -> universe_subst +val empty_subst : universe_subst +val is_empty_subst : universe_subst -> bool + +val empty_level_subst : universe_level_subst +val is_empty_level_subst : universe_level_subst -> bool + +(** Get the instantiated graph. *) +val instantiate_univ_context : universe_subst -> universe_context -> constraints + +(** Substitution of universes. *) +val subst_univs_level_level : universe_level_subst -> universe_level -> universe_level +val subst_univs_level_universe : universe_level_subst -> universe -> universe +val subst_univs_level_constraints : universe_level_subst -> constraints -> constraints + +val normalize_univs_level_level : universe_level_subst -> universe_level -> universe_level + +val make_subst : universe_subst -> universe_subst_fn + +(* val subst_univs_level_fail : universe_subst_fn -> universe_level -> universe_level *) +val subst_univs_level : universe_subst_fn -> universe_level -> universe +val subst_univs_universe : universe_subst_fn -> universe -> universe +val subst_univs_constraints : universe_subst_fn -> constraints -> constraints +val subst_univs_universe_constraints : universe_subst_fn -> universe_constraints -> universe_constraints + +(** Raises universe inconsistency if not compatible. *) +val check_consistent_constraints : universe_context_set -> constraints -> unit + +type 'a constraint_function = 'a -> 'a -> constraints -> constraints + +val enforce_leq : universe constraint_function +val enforce_eq : universe constraint_function +val enforce_eq_level : universe_level constraint_function +val enforce_leq_level : universe_level constraint_function +val enforce_eq_instances : universe_instance constraint_function + +type 'a universe_constraint_function = 'a -> 'a -> universe_constraints -> universe_constraints + +val enforce_eq_instances_univs : bool -> universe_instance universe_constraint_function (** {6 ... } *) (** Merge of constraints in a universes graph. @@ -110,8 +339,6 @@ val enforce_eq : constraint_function universes graph. It raises the exception [UniverseInconsistency] if the constraints are not satisfiable. *) -type constraint_type = Lt | Le | Eq - (** Type explanation is used to decorate error messages to provide useful explanation why a given constraint is rejected. It is composed of a path of universes and relation kinds [(r1,u1);..;(rn,un)] means @@ -125,20 +352,26 @@ type constraint_type = Lt | Le | Eq constraints... *) type explanation = (constraint_type * universe) list +type univ_inconsistency = constraint_type * universe * universe * explanation -exception UniverseInconsistency of - constraint_type * universe * universe * explanation +exception UniverseInconsistency of univ_inconsistency +val enforce_constraint : univ_constraint -> universes -> universes val merge_constraints : constraints -> universes -> universes val normalize_universes : universes -> universes val sort_universes : universes -> universes -(** {6 Support for sort-polymorphic inductive types } *) +val constraints_of_universes : universes -> constraints + +val to_constraints : universes -> universe_constraints -> constraints + +val check_constraint : universes -> univ_constraint -> bool +val check_constraints : constraints -> universes -> bool -val fresh_local_univ : unit -> universe -val set_remote_fresh_local_univ : universe RemoteCounter.installer -val solve_constraints_system : universe option array -> universe array -> +(** {6 Support for sort-polymorphism } *) + +val solve_constraints_system : universe option array -> universe array -> universe array -> universe array val subst_large_constraint : universe -> universe -> universe -> universe @@ -154,10 +387,15 @@ val univ_depends : universe -> universe -> bool (** {6 Pretty-printing of universes. } *) -val pr_uni_level : universe_level -> Pp.std_ppcmds -val pr_uni : universe -> Pp.std_ppcmds val pr_universes : universes -> Pp.std_ppcmds +val pr_constraint_type : constraint_type -> Pp.std_ppcmds val pr_constraints : constraints -> Pp.std_ppcmds +(* val pr_universe_list : universe_list -> Pp.std_ppcmds *) +val pr_universe_context : universe_context -> Pp.std_ppcmds +val pr_universe_context_set : universe_context_set -> Pp.std_ppcmds +val pr_universe_level_subst : universe_level_subst -> Pp.std_ppcmds +val pr_universe_subst : universe_subst -> Pp.std_ppcmds +val explain_universe_inconsistency : univ_inconsistency -> Pp.std_ppcmds (** {6 Dumping to a file } *) @@ -170,3 +408,8 @@ val dump_universes : val hcons_univlevel : universe_level -> universe_level val hcons_univ : universe -> universe val hcons_constraints : constraints -> constraints +val hcons_universe_set : universe_set -> universe_set +val hcons_universe_context : universe_context -> universe_context +val hcons_universe_context_set : universe_context_set -> universe_context_set + +(******) diff --git a/kernel/vars.ml b/kernel/vars.ml index f23d5fc2c..3cff51ba6 100644 --- a/kernel/vars.ml +++ b/kernel/vars.ml @@ -212,3 +212,89 @@ let substn_vars p vars c = in replace_vars (List.rev subst) c let subst_vars subst c = substn_vars 1 subst c + +(** Universe substitutions *) +open Constr + +let subst_univs_puniverses subst = + if Univ.is_empty_level_subst subst then fun c -> c + else + let f = Univ.Instance.subst subst in + fun ((c, u) as x) -> let u' = f u in if u' == u then x else (c, u') + +let subst_univs_fn_puniverses fn = + let f = Univ.Instance.subst_fn fn in + fun ((c, u) as x) -> let u' = f u in if u' == u then x else (c, u') + +let subst_univs_fn_constr f c = + let changed = ref false in + let fu = Univ.subst_univs_universe f in + let fi = Univ.Instance.subst_fn (Univ.level_subst_of f) in + let rec aux t = + match kind t with + | Sort (Sorts.Type u) -> + let u' = fu u in + if u' == u then t else + (changed := true; mkSort (Sorts.sort_of_univ u')) + | Const (c, u) -> + let u' = fi u in + if u' == u then t + else (changed := true; mkConstU (c, u')) + | Ind (i, u) -> + let u' = fi u in + if u' == u then t + else (changed := true; mkIndU (i, u')) + | Construct (c, u) -> + let u' = fi u in + if u' == u then t + else (changed := true; mkConstructU (c, u')) + | _ -> map aux t + in + let c' = aux c in + if !changed then c' else c + +let subst_univs_constr subst c = + if Univ.is_empty_subst subst then c + else + let f = Univ.make_subst subst in + subst_univs_fn_constr f c + +(* let subst_univs_constr_key = Profile.declare_profile "subst_univs_constr" *) +(* let subst_univs_constr = Profile.profile2 subst_univs_constr_key subst_univs_constr *) + +let subst_univs_level_constr subst c = + if Univ.is_empty_level_subst subst then c + else + let f = Univ.Instance.subst_fn (Univ.subst_univs_level_level subst) in + let changed = ref false in + let rec aux t = + match kind t with + | Const (c, u) -> + if Univ.Instance.is_empty u then t + else + let u' = f u in + if u' == u then t + else (changed := true; mkConstU (c, u')) + | Ind (i, u) -> + if Univ.Instance.is_empty u then t + else + let u' = f u in + if u' == u then t + else (changed := true; mkIndU (i, u')) + | Construct (c, u) -> + if Univ.Instance.is_empty u then t + else + let u' = f u in + if u' == u then t + else (changed := true; mkConstructU (c, u')) + | Sort (Sorts.Type u) -> + let u' = Univ.subst_univs_level_universe subst u in + if u' == u then t else + (changed := true; mkSort (Sorts.sort_of_univ u')) + | _ -> Constr.map aux t + in + let c' = aux c in + if !changed then c' else c + +let subst_univs_context s = + map_rel_context (subst_univs_constr s) diff --git a/kernel/vars.mli b/kernel/vars.mli index ef3381ab5..9d5d16d0c 100644 --- a/kernel/vars.mli +++ b/kernel/vars.mli @@ -68,3 +68,17 @@ val subst_vars : Id.t list -> constr -> constr (** [substn_vars n [id1;...;idn] t] substitute [VAR idj] by [Rel j+n-1] in [t] if two names are identical, the one of least indice is kept *) val substn_vars : int -> Id.t list -> constr -> constr + +(** {3 Substitution of universes} *) + +open Univ + +val subst_univs_fn_constr : universe_subst_fn -> constr -> constr +val subst_univs_fn_puniverses : universe_level_subst_fn -> + 'a puniverses -> 'a puniverses + +val subst_univs_constr : universe_subst -> constr -> constr +val subst_univs_puniverses : universe_level_subst -> 'a puniverses -> 'a puniverses +val subst_univs_level_constr : universe_level_subst -> constr -> constr + +val subst_univs_context : Univ.universe_subst -> rel_context -> rel_context diff --git a/kernel/vconv.ml b/kernel/vconv.ml index 484ee2a50..62ddeb182 100644 --- a/kernel/vconv.ml +++ b/kernel/vconv.ml @@ -42,13 +42,15 @@ let conv_vect fconv vect1 vect2 cu = let infos = ref (create_clos_infos betaiotazeta Environ.empty_env) +let eq_table_key = Names.eq_table_key eq_constant + let rec conv_val pb k v1 v2 cu = if v1 == v2 then cu else conv_whd pb k (whd_val v1) (whd_val v2) cu and conv_whd pb k whd1 whd2 cu = match whd1, whd2 with - | Vsort s1, Vsort s2 -> sort_cmp pb s1 s2 cu + | Vsort s1, Vsort s2 -> ignore(sort_cmp_universes pb s1 s2 (cu,None)); cu | Vprod p1, Vprod p2 -> let cu = conv_val CONV k (dom p1) (dom p2) cu in conv_fun pb k (codom p1) (codom p2) cu @@ -169,6 +171,13 @@ and conv_arguments k args1 args2 cu = !rcu else raise NotConvertible +let rec eq_puniverses f (x,l1) (y,l2) cu = + if f x y then conv_universes l1 l2 cu + else raise NotConvertible + +and conv_universes l1 l2 cu = + if Univ.Instance.eq l1 l2 then cu else raise NotConvertible + let rec conv_eq pb t1 t2 cu = if t1 == t2 then cu else @@ -179,7 +188,7 @@ let rec conv_eq pb t1 t2 cu = if Int.equal m1 m2 then cu else raise NotConvertible | Var id1, Var id2 -> if Id.equal id1 id2 then cu else raise NotConvertible - | Sort s1, Sort s2 -> sort_cmp pb s1 s2 cu + | Sort s1, Sort s2 -> ignore(sort_cmp_universes pb s1 s2 (cu,None)); cu | Cast (c1,_,_), _ -> conv_eq pb c1 t2 cu | _, Cast (c2,_,_) -> conv_eq pb t1 c2 cu | Prod (_,t1,c1), Prod (_,t2,c2) -> @@ -192,12 +201,13 @@ let rec conv_eq pb t1 t2 cu = | Evar (e1,l1), Evar (e2,l2) -> if Evar.equal e1 e2 then conv_eq_vect l1 l2 cu else raise NotConvertible - | Const c1, Const c2 -> - if eq_constant c1 c2 then cu else raise NotConvertible + | Const c1, Const c2 -> eq_puniverses eq_constant c1 c2 cu + | Proj (p1,c1), Proj (p2,c2) -> + if eq_constant p1 p2 then conv_eq pb c1 c2 cu else raise NotConvertible | Ind c1, Ind c2 -> - if eq_ind c1 c2 then cu else raise NotConvertible + eq_puniverses eq_ind c1 c2 cu | Construct c1, Construct c2 -> - if eq_constructor c1 c2 then cu else raise NotConvertible + eq_puniverses eq_constructor c1 c2 cu | Case (_,p1,c1,bl1), Case (_,p2,c2,bl2) -> let pcu = conv_eq CONV p1 p2 cu in let ccu = conv_eq CONV c1 c2 pcu in @@ -221,14 +231,14 @@ and conv_eq_vect vt1 vt2 cu = let vconv pb env t1 t2 = infos := create_clos_infos betaiotazeta env; - let cu = - try conv_eq pb t1 t2 empty_constraint + let _cu = + try conv_eq pb t1 t2 (universes env) with NotConvertible -> let v1 = val_of_constr env t1 in let v2 = val_of_constr env t2 in - let cu = conv_val pb (nb_rel env) v1 v2 empty_constraint in + let cu = conv_val pb (nb_rel env) v1 v2 (universes env) in cu - in cu + in () let _ = Reduction.set_vm_conv vconv |