aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorXavier Leroy <xavier.leroy@inria.fr>2016-04-27 16:43:20 +0200
committerXavier Leroy <xavier.leroy@inria.fr>2016-04-27 16:43:20 +0200
commit5978342d71db7d1bca162962c70e6fcdd5c1e96c (patch)
tree3b13b56d9067558ab706c4e95cea1d036f2ceeef
parentcf3f9615d79e0cbe4eb146c08e2c0802e1e3f033 (diff)
downloadcompcert-kvx-5978342d71db7d1bca162962c70e6fcdd5c1e96c.tar.gz
compcert-kvx-5978342d71db7d1bca162962c70e6fcdd5c1e96c.zip
Revise the Stacking pass and its proof to make it easier to adapt to 64-bit architectures
The original Stacking pass and its proof hard-wire assumptions about the processor and the register allocation, namely that integer registers are 32 bit wide and that all stack slots have natural alignment 4, which precludes having stack slots of type Tlong. Those assumptions become false if the target processor has 64-bit integer registers. This commit makes minimal adjustments to the Stacking pass so as to lift these assumptions: - Stack slots of type Tlong (or more generally of natural alignment 8) are supported. For slots produced by register allocation, the alignment is validated a posteriori in Lineartyping. For slots produced by the calling conventions, alignment is proved as part of the "loc_argument_acceptable" property in Conventions1. - The code generated by Stacking to save and restore used callee-save registers no longer assumes 32-bit integer registers. Actually, it supports any combination of sizes for registers. - To support the new save/restore code, Bounds was changed to record the set of all callee-save registers used, rather than just the max index of callee-save registers used. On CompCert's current 32-bit target architectures, the new Stacking pass should generate pretty much the same code as the old one, modulo minor differences in the layout of the stack frame. (E.g. padding could be introduced at different places.) The bulk of this big commit is related to the proof of the Stacking phase. The old proof strategy was painful and not obviously adaptable to the new Stacking phase, so I rewrote Stackingproof entirely, using an approach inspired by separation logic. The new library common/Separation.v defines assertions about memory states that can be composed using a separating conjunction, just like pre- and post-conditions in separation logic. Those assertions are used in Stackingproof to describe the contents of the stack frames during the execution of the generated Mach code, and relate them with the Linear location maps. As a further simplification, the callee-save/caller-save distinction is now defined in Conventions1 by a function is_callee_save: mreg -> bool, instead of lists of registers of either kind as before. This eliminates many boring classification lemmas from Conventions1. LTL and Lineartyping were adapted accordingly. Finally, this commit introduces a new library called Decidableplus to prove some propositions by reflection as Boolean computations. It is used to further simplify the proofs in Conventions1.
-rw-r--r--.depend40
-rw-r--r--Makefile5
-rw-r--r--arm/Conventions1.v235
-rw-r--r--arm/Machregs.v23
-rw-r--r--arm/Stacklayout.v171
-rw-r--r--backend/Allocation.v5
-rw-r--r--backend/Allocproof.v22
-rw-r--r--backend/Bounds.v334
-rw-r--r--backend/IRC.ml4
-rw-r--r--backend/LTL.v5
-rw-r--r--backend/Lineartyping.v7
-rw-r--r--backend/Locations.v22
-rw-r--r--backend/Stacking.v113
-rw-r--r--backend/Stackingproof.v2806
-rw-r--r--common/Separation.v916
-rw-r--r--extraction/extraction.v2
-rw-r--r--ia32/Asmgenproof1.v2
-rw-r--r--ia32/Conventions1.v177
-rw-r--r--ia32/Machregs.v22
-rw-r--r--ia32/Machregsaux.ml5
-rw-r--r--ia32/Stacklayout.v174
-rw-r--r--lib/Decidableplus.v244
-rw-r--r--powerpc/Conventions1.v218
-rw-r--r--powerpc/Machregs.v31
-rw-r--r--powerpc/Stacklayout.v171
25 files changed, 2973 insertions, 2781 deletions
diff --git a/.depend b/.depend
index e62929bc..448c001d 100644
--- a/.depend
+++ b/.depend
@@ -16,6 +16,7 @@ lib/Wfsimpl.vo lib/Wfsimpl.glob lib/Wfsimpl.v.beautified: lib/Wfsimpl.v lib/Axio
lib/Postorder.vo lib/Postorder.glob lib/Postorder.v.beautified: lib/Postorder.v lib/Coqlib.vo lib/Maps.vo lib/Iteration.vo
lib/FSetAVLplus.vo lib/FSetAVLplus.glob lib/FSetAVLplus.v.beautified: lib/FSetAVLplus.v lib/Coqlib.vo
lib/IntvSets.vo lib/IntvSets.glob lib/IntvSets.v.beautified: lib/IntvSets.v lib/Coqlib.vo
+lib/Decidableplus.vo lib/Decidableplus.glob lib/Decidableplus.v.beautified: lib/Decidableplus.v lib/Coqlib.vo
common/Errors.vo common/Errors.glob common/Errors.v.beautified: common/Errors.v lib/Coqlib.vo
common/AST.vo common/AST.glob common/AST.v.beautified: common/AST.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo lib/Integers.vo lib/Floats.vo
common/Linking.vo common/Linking.glob common/Linking.v.beautified: common/Linking.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo common/AST.vo
@@ -30,6 +31,7 @@ common/Behaviors.vo common/Behaviors.glob common/Behaviors.v.beautified: common/
common/Switch.vo common/Switch.glob common/Switch.v.beautified: common/Switch.v lib/Coqlib.vo lib/Maps.vo lib/Integers.vo common/Values.vo
common/Determinism.vo common/Determinism.glob common/Determinism.v.beautified: common/Determinism.v lib/Coqlib.vo common/AST.vo lib/Integers.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo common/Behaviors.vo
common/Unityping.vo common/Unityping.glob common/Unityping.v.beautified: common/Unityping.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo
+common/Separation.vo common/Separation.glob common/Separation.v.beautified: common/Separation.v lib/Coqlib.vo lib/Decidableplus.vo common/AST.vo lib/Integers.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo
backend/Cminor.vo backend/Cminor.glob backend/Cminor.v.beautified: backend/Cminor.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Events.vo common/Values.vo common/Memory.vo common/Globalenvs.vo common/Smallstep.vo common/Switch.vo
$(ARCH)/Op.vo $(ARCH)/Op.glob $(ARCH)/Op.v.beautified: $(ARCH)/Op.v lib/Coqlib.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Globalenvs.vo common/Events.vo
backend/CminorSel.vo backend/CminorSel.glob backend/CminorSel.v.beautified: backend/CminorSel.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Events.vo common/Values.vo common/Memory.vo backend/Cminor.vo $(ARCH)/Op.vo common/Globalenvs.vo common/Smallstep.vo
@@ -52,7 +54,7 @@ backend/Inlining.vo backend/Inlining.glob backend/Inlining.v.beautified: backend
backend/Inliningspec.vo backend/Inliningspec.glob backend/Inliningspec.v.beautified: backend/Inliningspec.v lib/Coqlib.vo lib/Wfsimpl.vo lib/Maps.vo common/Errors.vo lib/Integers.vo common/AST.vo common/Linking.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo backend/Inlining.vo
backend/Inliningproof.vo backend/Inliningproof.glob backend/Inliningproof.v.beautified: backend/Inliningproof.v lib/Coqlib.vo lib/Wfsimpl.vo lib/Maps.vo common/Errors.vo lib/Integers.vo common/AST.vo common/Linking.vo common/Values.vo common/Memory.vo common/Globalenvs.vo common/Events.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo backend/Inlining.vo backend/Inliningspec.vo
backend/Renumber.vo backend/Renumber.glob backend/Renumber.v.beautified: backend/Renumber.v lib/Coqlib.vo lib/Maps.vo lib/Postorder.vo backend/RTL.vo
-backend/Renumberproof.vo backend/Renumberproof.glob backend/Renumberproof.v.beautified: backend/Renumberproof.v lib/Coqlib.vo lib/Maps.vo lib/Postorder.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo backend/Renumber.vo
+backend/Renumberproof.vo backend/Renumberproof.glob backend/Renumberproof.v.beautified: backend/Renumberproof.v lib/Coqlib.vo lib/Maps.vo lib/Postorder.vo common/AST.vo common/Linking.vo common/Values.vo common/Memory.vo common/Globalenvs.vo common/Events.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo backend/Renumber.vo
backend/RTLtyping.vo backend/RTLtyping.glob backend/RTLtyping.v.beautified: backend/RTLtyping.v lib/Coqlib.vo common/Errors.vo common/Unityping.vo lib/Maps.vo common/AST.vo $(ARCH)/Op.vo backend/Registers.vo common/Globalenvs.vo common/Values.vo lib/Integers.vo common/Memory.vo common/Events.vo backend/RTL.vo backend/Conventions.vo
backend/Kildall.vo backend/Kildall.glob backend/Kildall.v.beautified: backend/Kildall.v lib/Coqlib.vo lib/Iteration.vo lib/Maps.vo lib/Lattice.vo lib/Heaps.vo
backend/Liveness.vo backend/Liveness.glob backend/Liveness.v.beautified: backend/Liveness.v lib/Coqlib.vo lib/Maps.vo lib/Lattice.vo common/AST.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo backend/Kildall.vo
@@ -74,38 +76,38 @@ backend/Deadcode.vo backend/Deadcode.glob backend/Deadcode.v.beautified: backend
backend/Deadcodeproof.vo backend/Deadcodeproof.glob backend/Deadcodeproof.v.beautified: backend/Deadcodeproof.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo lib/Integers.vo lib/Floats.vo lib/Lattice.vo backend/Kildall.vo common/AST.vo common/Linking.vo common/Values.vo common/Memory.vo common/Globalenvs.vo common/Events.vo common/Smallstep.vo backend/Registers.vo $(ARCH)/Op.vo backend/RTL.vo backend/ValueDomain.vo backend/ValueAnalysis.vo backend/NeedDomain.vo $(ARCH)/NeedOp.vo backend/Deadcode.vo
backend/Unusedglob.vo backend/Unusedglob.glob backend/Unusedglob.v.beautified: backend/Unusedglob.v lib/Coqlib.vo lib/Maps.vo lib/Ordered.vo lib/Iteration.vo common/Errors.vo common/AST.vo common/Linking.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo
backend/Unusedglobproof.vo backend/Unusedglobproof.glob backend/Unusedglobproof.v.beautified: backend/Unusedglobproof.v lib/Coqlib.vo lib/Maps.vo lib/Ordered.vo lib/Iteration.vo common/Errors.vo common/AST.vo common/Linking.vo lib/Integers.vo common/Values.vo common/Memory.vo common/Globalenvs.vo common/Events.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo backend/Unusedglob.vo
-$(ARCH)/Machregs.vo $(ARCH)/Machregs.glob $(ARCH)/Machregs.v.beautified: $(ARCH)/Machregs.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo $(ARCH)/Op.vo
+$(ARCH)/Machregs.vo $(ARCH)/Machregs.glob $(ARCH)/Machregs.v.beautified: $(ARCH)/Machregs.v lib/Coqlib.vo lib/Decidableplus.vo lib/Maps.vo common/AST.vo lib/Integers.vo $(ARCH)/Op.vo
backend/Locations.vo backend/Locations.glob backend/Locations.v.beautified: backend/Locations.v lib/Coqlib.vo lib/Maps.vo lib/Ordered.vo common/AST.vo common/Values.vo $(ARCH)/Machregs.vo
-$(ARCH)/Conventions1.vo $(ARCH)/Conventions1.glob $(ARCH)/Conventions1.v.beautified: $(ARCH)/Conventions1.v lib/Coqlib.vo common/AST.vo common/Events.vo backend/Locations.vo
+$(ARCH)/Conventions1.vo $(ARCH)/Conventions1.glob $(ARCH)/Conventions1.v.beautified: $(ARCH)/Conventions1.v lib/Coqlib.vo lib/Decidableplus.vo common/AST.vo common/Events.vo backend/Locations.vo
backend/Conventions.vo backend/Conventions.glob backend/Conventions.v.beautified: backend/Conventions.v lib/Coqlib.vo common/AST.vo backend/Locations.vo $(ARCH)/Conventions1.vo
backend/LTL.vo backend/LTL.glob backend/LTL.v.beautified: backend/LTL.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Events.vo common/Memory.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Locations.vo backend/Conventions.vo
-backend/Allocation.vo backend/Allocation.glob backend/Allocation.v.beautified: backend/Allocation.v lib/FSetAVLplus.vo $(ARCH)/Archi.vo lib/Coqlib.vo lib/Ordered.vo common/Errors.vo lib/Maps.vo lib/Lattice.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Memdata.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo backend/Kildall.vo backend/Locations.vo backend/Conventions.vo backend/RTLtyping.vo backend/LTL.vo
-backend/Allocproof.vo backend/Allocproof.glob backend/Allocproof.v.beautified: backend/Allocproof.v $(ARCH)/Archi.vo lib/Coqlib.vo lib/Ordered.vo common/Errors.vo lib/Maps.vo lib/Lattice.vo common/AST.vo lib/Integers.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo backend/RTLtyping.vo backend/Kildall.vo backend/Locations.vo backend/Conventions.vo backend/LTL.vo backend/Allocation.vo
+backend/Allocation.vo backend/Allocation.glob backend/Allocation.v.beautified: backend/Allocation.v lib/FSetAVLplus.vo lib/Coqlib.vo lib/Ordered.vo lib/Maps.vo common/Errors.vo lib/Integers.vo lib/Floats.vo common/AST.vo lib/Lattice.vo backend/Kildall.vo common/Memdata.vo $(ARCH)/Archi.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo backend/Locations.vo backend/Conventions.vo backend/RTLtyping.vo backend/LTL.vo
+backend/Allocproof.vo backend/Allocproof.glob backend/Allocproof.v.beautified: backend/Allocproof.v lib/Coqlib.vo lib/Ordered.vo lib/Maps.vo common/Errors.vo lib/Integers.vo lib/Floats.vo common/AST.vo common/Linking.vo lib/Lattice.vo backend/Kildall.vo common/Values.vo common/Memory.vo common/Globalenvs.vo common/Events.vo common/Smallstep.vo $(ARCH)/Archi.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo backend/Locations.vo backend/Conventions.vo backend/RTLtyping.vo backend/LTL.vo backend/Allocation.vo
backend/Tunneling.vo backend/Tunneling.glob backend/Tunneling.v.beautified: backend/Tunneling.v lib/Coqlib.vo lib/Maps.vo lib/UnionFind.vo common/AST.vo backend/LTL.vo
-backend/Tunnelingproof.vo backend/Tunnelingproof.glob backend/Tunnelingproof.v.beautified: backend/Tunnelingproof.v lib/Coqlib.vo lib/Maps.vo lib/UnionFind.vo common/AST.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Locations.vo backend/LTL.vo backend/Tunneling.vo
+backend/Tunnelingproof.vo backend/Tunnelingproof.glob backend/Tunnelingproof.v.beautified: backend/Tunnelingproof.v lib/Coqlib.vo lib/Maps.vo lib/UnionFind.vo common/AST.vo common/Linking.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Locations.vo backend/LTL.vo backend/Tunneling.vo
backend/Linear.vo backend/Linear.glob backend/Linear.v.beautified: backend/Linear.v lib/Coqlib.vo common/AST.vo lib/Integers.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Locations.vo backend/LTL.vo backend/Conventions.vo
backend/Lineartyping.vo backend/Lineartyping.glob backend/Lineartyping.v.beautified: backend/Lineartyping.v lib/Coqlib.vo common/AST.vo lib/Integers.vo common/Values.vo common/Globalenvs.vo common/Memory.vo common/Events.vo $(ARCH)/Op.vo $(ARCH)/Machregs.vo backend/Locations.vo backend/Conventions.vo backend/LTL.vo backend/Linear.vo
-backend/Linearize.vo backend/Linearize.glob backend/Linearize.v.beautified: backend/Linearize.v lib/Coqlib.vo lib/Maps.vo lib/Ordered.vo common/AST.vo common/Errors.vo $(ARCH)/Op.vo backend/Locations.vo backend/LTL.vo backend/Linear.vo backend/Kildall.vo lib/Lattice.vo
-backend/Linearizeproof.vo backend/Linearizeproof.glob backend/Linearizeproof.v.beautified: backend/Linearizeproof.v lib/Coqlib.vo lib/Maps.vo lib/Ordered.vo lib/Lattice.vo common/AST.vo lib/Integers.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Errors.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Locations.vo backend/LTL.vo backend/Linear.vo backend/Linearize.vo
+backend/Linearize.vo backend/Linearize.glob backend/Linearize.v.beautified: backend/Linearize.v lib/Coqlib.vo lib/Maps.vo lib/Ordered.vo common/Errors.vo lib/Lattice.vo backend/Kildall.vo common/AST.vo $(ARCH)/Op.vo backend/Locations.vo backend/LTL.vo backend/Linear.vo
+backend/Linearizeproof.vo backend/Linearizeproof.glob backend/Linearizeproof.v.beautified: backend/Linearizeproof.v lib/Coqlib.vo lib/Maps.vo lib/Ordered.vo common/Errors.vo lib/Lattice.vo backend/Kildall.vo lib/Integers.vo common/AST.vo common/Linking.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Locations.vo backend/LTL.vo backend/Linear.vo backend/Linearize.vo
backend/CleanupLabels.vo backend/CleanupLabels.glob backend/CleanupLabels.v.beautified: backend/CleanupLabels.v lib/Coqlib.vo lib/Ordered.vo backend/Linear.vo
-backend/CleanupLabelsproof.vo backend/CleanupLabelsproof.glob backend/CleanupLabelsproof.v.beautified: backend/CleanupLabelsproof.v lib/Coqlib.vo lib/Ordered.vo common/AST.vo lib/Integers.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Locations.vo backend/Linear.vo backend/CleanupLabels.vo
-backend/Debugvar.vo backend/Debugvar.glob backend/Debugvar.v.beautified: backend/Debugvar.v lib/Coqlib.vo lib/Axioms.vo lib/Maps.vo lib/Iteration.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Errors.vo $(ARCH)/Machregs.vo backend/Locations.vo backend/Conventions.vo backend/Linear.vo
-backend/Debugvarproof.vo backend/Debugvarproof.glob backend/Debugvarproof.v.beautified: backend/Debugvarproof.v lib/Coqlib.vo lib/Axioms.vo lib/Maps.vo lib/Iteration.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo common/Errors.vo $(ARCH)/Machregs.vo backend/Locations.vo backend/Conventions.vo backend/Linear.vo backend/Debugvar.vo
+backend/CleanupLabelsproof.vo backend/CleanupLabelsproof.glob backend/CleanupLabelsproof.v.beautified: backend/CleanupLabelsproof.v lib/Coqlib.vo lib/Ordered.vo lib/Integers.vo common/AST.vo common/Linking.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Locations.vo backend/Linear.vo backend/CleanupLabels.vo
+backend/Debugvar.vo backend/Debugvar.glob backend/Debugvar.v.beautified: backend/Debugvar.v lib/Axioms.vo lib/Coqlib.vo lib/Maps.vo lib/Iteration.vo common/Errors.vo lib/Integers.vo lib/Floats.vo common/AST.vo $(ARCH)/Machregs.vo backend/Locations.vo backend/Conventions.vo backend/Linear.vo
+backend/Debugvarproof.vo backend/Debugvarproof.glob backend/Debugvarproof.v.beautified: backend/Debugvarproof.v lib/Axioms.vo lib/Coqlib.vo lib/Maps.vo lib/Iteration.vo common/Errors.vo lib/Integers.vo lib/Floats.vo common/AST.vo common/Linking.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Machregs.vo backend/Locations.vo backend/Conventions.vo $(ARCH)/Op.vo backend/Linear.vo backend/Debugvar.vo
backend/Mach.vo backend/Mach.glob backend/Mach.v.beautified: backend/Mach.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Memory.vo common/Globalenvs.vo common/Events.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Locations.vo backend/Conventions.vo $(ARCH)/Stacklayout.vo
-backend/Bounds.vo backend/Bounds.glob backend/Bounds.v.beautified: backend/Bounds.v lib/Coqlib.vo common/AST.vo $(ARCH)/Op.vo backend/Locations.vo backend/Linear.vo backend/Conventions.vo
-$(ARCH)/Stacklayout.vo $(ARCH)/Stacklayout.glob $(ARCH)/Stacklayout.v.beautified: $(ARCH)/Stacklayout.v lib/Coqlib.vo backend/Bounds.vo
-backend/Stacking.vo backend/Stacking.glob backend/Stacking.v.beautified: backend/Stacking.v lib/Coqlib.vo common/Errors.vo common/AST.vo lib/Integers.vo $(ARCH)/Op.vo backend/Locations.vo backend/Linear.vo backend/Bounds.vo backend/Mach.vo backend/Conventions.vo $(ARCH)/Stacklayout.vo backend/Lineartyping.vo
-backend/Stackingproof.vo backend/Stackingproof.glob backend/Stackingproof.v.beautified: backend/Stackingproof.v lib/Coqlib.vo common/Errors.vo common/AST.vo lib/Integers.vo common/Values.vo $(ARCH)/Op.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo backend/Locations.vo backend/LTL.vo backend/Linear.vo backend/Lineartyping.vo backend/Mach.vo backend/Bounds.vo backend/Conventions.vo $(ARCH)/Stacklayout.vo backend/Stacking.vo
+backend/Bounds.vo backend/Bounds.glob backend/Bounds.v.beautified: backend/Bounds.v lib/Coqlib.vo lib/Ordered.vo lib/Intv.vo common/AST.vo $(ARCH)/Op.vo $(ARCH)/Machregs.vo backend/Locations.vo backend/Linear.vo backend/Conventions.vo
+$(ARCH)/Stacklayout.vo $(ARCH)/Stacklayout.glob $(ARCH)/Stacklayout.v.beautified: $(ARCH)/Stacklayout.v lib/Coqlib.vo common/Memory.vo common/Separation.vo backend/Bounds.vo
+backend/Stacking.vo backend/Stacking.glob backend/Stacking.v.beautified: backend/Stacking.v lib/Coqlib.vo common/Errors.vo lib/Integers.vo common/AST.vo $(ARCH)/Op.vo backend/Locations.vo backend/Linear.vo backend/Mach.vo backend/Bounds.vo backend/Conventions.vo $(ARCH)/Stacklayout.vo backend/Lineartyping.vo
+backend/Stackingproof.vo backend/Stackingproof.glob backend/Stackingproof.v.beautified: backend/Stackingproof.v lib/Coqlib.vo common/Errors.vo lib/Integers.vo common/AST.vo common/Linking.vo common/Values.vo common/Memory.vo common/Separation.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo backend/LTL.vo $(ARCH)/Op.vo backend/Locations.vo backend/Linear.vo backend/Mach.vo backend/Bounds.vo backend/Conventions.vo $(ARCH)/Stacklayout.vo backend/Lineartyping.vo backend/Stacking.vo
$(ARCH)/Asm.vo $(ARCH)/Asm.glob $(ARCH)/Asm.v.beautified: $(ARCH)/Asm.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo backend/Locations.vo $(ARCH)/Stacklayout.vo backend/Conventions.vo
-$(ARCH)/Asmgen.vo $(ARCH)/Asmgen.glob $(ARCH)/Asmgen.v.beautified: $(ARCH)/Asmgen.v lib/Coqlib.vo common/Errors.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Memdata.vo $(ARCH)/Op.vo backend/Locations.vo backend/Mach.vo $(ARCH)/Asm.vo
+$(ARCH)/Asmgen.vo $(ARCH)/Asmgen.glob $(ARCH)/Asmgen.v.beautified: $(ARCH)/Asmgen.v lib/Coqlib.vo common/Errors.vo lib/Integers.vo lib/Floats.vo common/AST.vo common/Memdata.vo $(ARCH)/Op.vo backend/Locations.vo backend/Mach.vo $(ARCH)/Asm.vo
backend/Asmgenproof0.vo backend/Asmgenproof0.glob backend/Asmgenproof0.v.beautified: backend/Asmgenproof0.v lib/Coqlib.vo lib/Intv.vo common/AST.vo common/Errors.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Globalenvs.vo common/Events.vo common/Smallstep.vo backend/Locations.vo backend/Mach.vo $(ARCH)/Asm.vo $(ARCH)/Asmgen.vo backend/Conventions.vo
$(ARCH)/Asmgenproof1.vo $(ARCH)/Asmgenproof1.glob $(ARCH)/Asmgenproof1.v.beautified: $(ARCH)/Asmgenproof1.v lib/Coqlib.vo common/AST.vo common/Errors.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Globalenvs.vo $(ARCH)/Op.vo backend/Locations.vo backend/Mach.vo $(ARCH)/Asm.vo $(ARCH)/Asmgen.vo backend/Asmgenproof0.vo backend/Conventions.vo
-$(ARCH)/Asmgenproof.vo $(ARCH)/Asmgenproof.glob $(ARCH)/Asmgenproof.v.beautified: $(ARCH)/Asmgenproof.v lib/Coqlib.vo common/Errors.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Locations.vo backend/Mach.vo backend/Conventions.vo $(ARCH)/Asm.vo $(ARCH)/Asmgen.vo backend/Asmgenproof0.vo $(ARCH)/Asmgenproof1.vo
+$(ARCH)/Asmgenproof.vo $(ARCH)/Asmgenproof.glob $(ARCH)/Asmgenproof.v.beautified: $(ARCH)/Asmgenproof.v lib/Coqlib.vo common/Errors.vo lib/Integers.vo lib/Floats.vo common/AST.vo common/Linking.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Locations.vo backend/Mach.vo backend/Conventions.vo $(ARCH)/Asm.vo $(ARCH)/Asmgen.vo backend/Asmgenproof0.vo $(ARCH)/Asmgenproof1.vo
cfrontend/Ctypes.vo cfrontend/Ctypes.glob cfrontend/Ctypes.v.beautified: cfrontend/Ctypes.v lib/Axioms.vo lib/Coqlib.vo lib/Maps.vo common/Errors.vo common/AST.vo common/Linking.vo $(ARCH)/Archi.vo
cfrontend/Cop.vo cfrontend/Cop.glob cfrontend/Cop.v.beautified: cfrontend/Cop.v lib/Coqlib.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo cfrontend/Ctypes.vo
cfrontend/Csyntax.vo cfrontend/Csyntax.glob cfrontend/Csyntax.v.beautified: cfrontend/Csyntax.v lib/Coqlib.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/Errors.vo common/AST.vo common/Linking.vo common/Values.vo cfrontend/Ctypes.vo cfrontend/Cop.vo
cfrontend/Csem.vo cfrontend/Csem.glob cfrontend/Csem.v.beautified: cfrontend/Csem.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/AST.vo common/Memory.vo common/Events.vo common/Globalenvs.vo cfrontend/Ctypes.vo cfrontend/Cop.vo cfrontend/Csyntax.vo common/Smallstep.vo
-cfrontend/Ctyping.vo cfrontend/Ctyping.glob cfrontend/Ctyping.v.beautified: cfrontend/Ctyping.v lib/Coqlib.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Globalenvs.vo common/Events.vo common/AST.vo cfrontend/Ctypes.vo cfrontend/Cop.vo cfrontend/Csyntax.vo cfrontend/Csem.vo common/Errors.vo
+cfrontend/Ctyping.vo cfrontend/Ctyping.glob cfrontend/Ctyping.v.beautified: cfrontend/Ctyping.v lib/Coqlib.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/Errors.vo common/AST.vo common/Linking.vo common/Values.vo common/Memory.vo common/Globalenvs.vo common/Events.vo cfrontend/Ctypes.vo cfrontend/Cop.vo cfrontend/Csyntax.vo cfrontend/Csem.vo
cfrontend/Cstrategy.vo cfrontend/Cstrategy.glob cfrontend/Cstrategy.v.beautified: cfrontend/Cstrategy.v lib/Axioms.vo lib/Coqlib.vo common/Errors.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/AST.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo cfrontend/Ctypes.vo cfrontend/Cop.vo cfrontend/Csyntax.vo cfrontend/Csem.vo
cfrontend/Cexec.vo cfrontend/Cexec.glob cfrontend/Cexec.v.beautified: cfrontend/Cexec.v lib/Axioms.vo lib/Coqlib.vo common/Errors.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/AST.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Determinism.vo cfrontend/Ctypes.vo cfrontend/Cop.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Cstrategy.vo
cfrontend/Initializers.vo cfrontend/Initializers.glob cfrontend/Initializers.v.beautified: cfrontend/Initializers.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/AST.vo common/Memory.vo common/Globalenvs.vo cfrontend/Ctypes.vo cfrontend/Cop.vo cfrontend/Csyntax.vo
@@ -123,7 +125,7 @@ cfrontend/Csharpminor.vo cfrontend/Csharpminor.glob cfrontend/Csharpminor.v.beau
cfrontend/Cminorgen.vo cfrontend/Cminorgen.glob cfrontend/Cminorgen.v.beautified: cfrontend/Cminorgen.v lib/Coqlib.vo lib/Maps.vo lib/Ordered.vo common/Errors.vo lib/Integers.vo lib/Floats.vo common/AST.vo common/Linking.vo cfrontend/Csharpminor.vo backend/Cminor.vo
cfrontend/Cminorgenproof.vo cfrontend/Cminorgenproof.glob cfrontend/Cminorgenproof.v.beautified: cfrontend/Cminorgenproof.v lib/Coqlib.vo lib/Maps.vo lib/Ordered.vo common/Errors.vo lib/Integers.vo lib/Floats.vo lib/Intv.vo common/AST.vo common/Linking.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo cfrontend/Csharpminor.vo common/Switch.vo backend/Cminor.vo cfrontend/Cminorgen.vo
driver/Compopts.vo driver/Compopts.glob driver/Compopts.v.beautified: driver/Compopts.v
-driver/Compiler.vo driver/Compiler.glob driver/Compiler.v.beautified: driver/Compiler.v lib/Coqlib.vo common/Errors.vo common/AST.vo common/Smallstep.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Cstrategy.vo cfrontend/Cexec.vo cfrontend/Clight.vo cfrontend/Csharpminor.vo backend/Cminor.vo backend/CminorSel.vo backend/RTL.vo backend/LTL.vo backend/Linear.vo backend/Mach.vo $(ARCH)/Asm.vo cfrontend/Initializers.vo cfrontend/SimplExpr.vo cfrontend/SimplLocals.vo cfrontend/Cshmgen.vo cfrontend/Cminorgen.vo backend/Selection.vo backend/RTLgen.vo backend/Tailcall.vo backend/Inlining.vo backend/Renumber.vo backend/Constprop.vo backend/CSE.vo backend/Deadcode.vo backend/Unusedglob.vo backend/Allocation.vo backend/Tunneling.vo backend/Linearize.vo backend/CleanupLabels.vo backend/Debugvar.vo backend/Stacking.vo $(ARCH)/Asmgen.vo cfrontend/SimplExprproof.vo cfrontend/SimplLocalsproof.vo cfrontend/Cshmgenproof.vo cfrontend/Cminorgenproof.vo backend/Selectionproof.vo backend/RTLgenproof.vo backend/Tailcallproof.vo backend/Inliningproof.vo backend/Renumberproof.vo backend/Constpropproof.vo backend/CSEproof.vo backend/Deadcodeproof.vo backend/Unusedglobproof.vo backend/Allocproof.vo backend/Tunnelingproof.vo backend/Linearizeproof.vo backend/CleanupLabelsproof.vo backend/Debugvarproof.vo backend/Stackingproof.vo $(ARCH)/Asmgenproof.vo driver/Compopts.vo
+driver/Compiler.vo driver/Compiler.glob driver/Compiler.v.beautified: driver/Compiler.v lib/Coqlib.vo common/Errors.vo common/AST.vo common/Linking.vo common/Smallstep.vo cfrontend/Ctypes.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Cstrategy.vo cfrontend/Cexec.vo cfrontend/Clight.vo cfrontend/Csharpminor.vo backend/Cminor.vo backend/CminorSel.vo backend/RTL.vo backend/LTL.vo backend/Linear.vo backend/Mach.vo $(ARCH)/Asm.vo cfrontend/Initializers.vo cfrontend/SimplExpr.vo cfrontend/SimplLocals.vo cfrontend/Cshmgen.vo cfrontend/Cminorgen.vo backend/Selection.vo backend/RTLgen.vo backend/Tailcall.vo backend/Inlining.vo backend/Renumber.vo backend/Constprop.vo backend/CSE.vo backend/Deadcode.vo backend/Unusedglob.vo backend/Allocation.vo backend/Tunneling.vo backend/Linearize.vo backend/CleanupLabels.vo backend/Debugvar.vo backend/Stacking.vo $(ARCH)/Asmgen.vo cfrontend/SimplExprproof.vo cfrontend/SimplLocalsproof.vo cfrontend/Cshmgenproof.vo cfrontend/Cminorgenproof.vo backend/Selectionproof.vo backend/RTLgenproof.vo backend/Tailcallproof.vo backend/Inliningproof.vo backend/Renumberproof.vo backend/Constpropproof.vo backend/CSEproof.vo backend/Deadcodeproof.vo backend/Unusedglobproof.vo backend/Allocproof.vo backend/Tunnelingproof.vo backend/Linearizeproof.vo backend/CleanupLabelsproof.vo backend/Debugvarproof.vo backend/Stackingproof.vo $(ARCH)/Asmgenproof.vo driver/Compopts.vo
driver/Complements.vo driver/Complements.glob driver/Complements.v.beautified: driver/Complements.v lib/Coqlib.vo common/AST.vo lib/Integers.vo common/Values.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo common/Behaviors.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Cstrategy.vo cfrontend/Clight.vo backend/Cminor.vo backend/RTL.vo $(ARCH)/Asm.vo driver/Compiler.vo common/Errors.vo
flocq/Core/Fcore_Raux.vo flocq/Core/Fcore_Raux.glob flocq/Core/Fcore_Raux.v.beautified: flocq/Core/Fcore_Raux.v flocq/Core/Fcore_Zaux.vo
flocq/Core/Fcore_Zaux.vo flocq/Core/Fcore_Zaux.glob flocq/Core/Fcore_Zaux.v.beautified: flocq/Core/Fcore_Zaux.v
diff --git a/Makefile b/Makefile
index 4cc83f89..66fa90f6 100644
--- a/Makefile
+++ b/Makefile
@@ -52,13 +52,14 @@ FLOCQ=\
VLIB=Axioms.v Coqlib.v Intv.v Maps.v Heaps.v Lattice.v Ordered.v \
Iteration.v Integers.v Archi.v Fappli_IEEE_extra.v Floats.v \
Parmov.v UnionFind.v Wfsimpl.v \
- Postorder.v FSetAVLplus.v IntvSets.v
+ Postorder.v FSetAVLplus.v IntvSets.v Decidableplus.v
# Parts common to the front-ends and the back-end (in common/)
COMMON=Errors.v AST.v Linking.v \
Events.v Globalenvs.v Memdata.v Memtype.v Memory.v \
- Values.v Smallstep.v Behaviors.v Switch.v Determinism.v Unityping.v
+ Values.v Smallstep.v Behaviors.v Switch.v Determinism.v Unityping.v \
+ Separation.v
# Back-end modules (in backend/, $(ARCH)/)
diff --git a/arm/Conventions1.v b/arm/Conventions1.v
index e27a9293..abd28b18 100644
--- a/arm/Conventions1.v
+++ b/arm/Conventions1.v
@@ -14,6 +14,7 @@
machine registers and stack slots. *)
Require Import Coqlib.
+Require Import Decidableplus.
Require Import AST.
Require Import Events.
Require Import Locations.
@@ -33,6 +34,14 @@ Require Archi.
of callee- and caller-save registers.
*)
+Definition is_callee_save (r: mreg): bool :=
+ match r with
+ | R0 | R1 | R2 | R3 | R12 => false
+ | R4 | R5 | R6 | R7 | R8 | R9 | R10 | R11 => true
+ | F0 | F1 | F2 | F3 | F4 | F5 | F6 | F7 => false
+ | F8 | F9 | F10 | F11 | F12 | F13 | F14 | F15 => true
+ end.
+
Definition int_caller_save_regs :=
R0 :: R1 :: R2 :: R3 :: R12 :: nil.
@@ -46,171 +55,11 @@ Definition float_callee_save_regs :=
F8 :: F9 :: F10 :: F11 :: F12 :: F13 :: F14 :: F15 :: nil.
Definition destroyed_at_call :=
- int_caller_save_regs ++ float_caller_save_regs.
+ List.filter (fun r => negb (is_callee_save r)) all_mregs.
Definition dummy_int_reg := R0. (**r Used in [Coloring]. *)
Definition dummy_float_reg := F0. (**r Used in [Coloring]. *)
-(** The [index_int_callee_save] and [index_float_callee_save] associate
- a unique positive integer to callee-save registers. This integer is
- used in [Stacking] to determine where to save these registers in
- the activation record if they are used by the current function. *)
-
-Definition index_int_callee_save (r: mreg) :=
- match r with
- | R4 => 0 | R5 => 1 | R6 => 2 | R7 => 3
- | R8 => 4 | R9 => 5 | R10 => 6 | R11 => 7
- | _ => -1
- end.
-
-Definition index_float_callee_save (r: mreg) :=
- match r with
- | F8 => 0 | F9 => 1 | F10 => 2 | F11 => 3
- | F12 => 4 | F13 => 5 | F14 => 6 | F15 => 7
- | _ => -1
- end.
-
-Ltac ElimOrEq :=
- match goal with
- | |- (?x = ?y) \/ _ -> _ =>
- let H := fresh in
- (intro H; elim H; clear H;
- [intro H; rewrite <- H; clear H | ElimOrEq])
- | |- False -> _ =>
- let H := fresh in (intro H; contradiction)
- end.
-
-Ltac OrEq :=
- match goal with
- | |- (?x = ?x) \/ _ => left; reflexivity
- | |- (?x = ?y) \/ _ => right; OrEq
- | |- False => fail
- end.
-
-Ltac NotOrEq :=
- match goal with
- | |- (?x = ?y) \/ _ -> False =>
- let H := fresh in (
- intro H; elim H; clear H; [intro; discriminate | NotOrEq])
- | |- False -> False =>
- contradiction
- end.
-
-Lemma index_int_callee_save_pos:
- forall r, In r int_callee_save_regs -> index_int_callee_save r >= 0.
-Proof.
- intro r. simpl; ElimOrEq; unfold index_int_callee_save; omega.
-Qed.
-
-Lemma index_float_callee_save_pos:
- forall r, In r float_callee_save_regs -> index_float_callee_save r >= 0.
-Proof.
- intro r. simpl; ElimOrEq; unfold index_float_callee_save; omega.
-Qed.
-
-Lemma index_int_callee_save_pos2:
- forall r, index_int_callee_save r >= 0 -> In r int_callee_save_regs.
-Proof.
- destruct r; simpl; intro; omegaContradiction || OrEq.
-Qed.
-
-Lemma index_float_callee_save_pos2:
- forall r, index_float_callee_save r >= 0 -> In r float_callee_save_regs.
-Proof.
- destruct r; simpl; intro; omegaContradiction || OrEq.
-Qed.
-
-Lemma index_int_callee_save_inj:
- forall r1 r2,
- In r1 int_callee_save_regs ->
- In r2 int_callee_save_regs ->
- r1 <> r2 ->
- index_int_callee_save r1 <> index_int_callee_save r2.
-Proof.
- intros r1 r2.
- simpl; ElimOrEq; ElimOrEq; unfold index_int_callee_save;
- intros; congruence.
-Qed.
-
-Lemma index_float_callee_save_inj:
- forall r1 r2,
- In r1 float_callee_save_regs ->
- In r2 float_callee_save_regs ->
- r1 <> r2 ->
- index_float_callee_save r1 <> index_float_callee_save r2.
-Proof.
- intros r1 r2.
- simpl; ElimOrEq; ElimOrEq; unfold index_float_callee_save;
- intros; congruence.
-Qed.
-
-(** The following lemmas show that
- (temporaries, destroyed at call, integer callee-save, float callee-save)
- is a partition of the set of machine registers. *)
-
-Lemma int_float_callee_save_disjoint:
- list_disjoint int_callee_save_regs float_callee_save_regs.
-Proof.
- red; intros r1 r2. simpl; ElimOrEq; ElimOrEq; discriminate.
-Qed.
-
-Lemma register_classification:
- forall r,
- In r destroyed_at_call \/ In r int_callee_save_regs \/ In r float_callee_save_regs.
-Proof.
- destruct r;
- try (left; simpl; OrEq);
- try (right; left; simpl; OrEq);
- try (right; right; simpl; OrEq).
-Qed.
-
-
-Lemma int_callee_save_not_destroyed:
- forall r,
- In r destroyed_at_call -> In r int_callee_save_regs -> False.
-Proof.
- intros. revert H0 H. simpl. ElimOrEq; NotOrEq.
-Qed.
-
-Lemma float_callee_save_not_destroyed:
- forall r,
- In r destroyed_at_call -> In r float_callee_save_regs -> False.
-Proof.
- intros. revert H0 H. simpl. ElimOrEq; NotOrEq.
-Qed.
-
-Lemma int_callee_save_type:
- forall r, In r int_callee_save_regs -> mreg_type r = Tany32.
-Proof.
- intro. simpl; ElimOrEq; reflexivity.
-Qed.
-
-Lemma float_callee_save_type:
- forall r, In r float_callee_save_regs -> mreg_type r = Tany64.
-Proof.
- intro. simpl; ElimOrEq; reflexivity.
-Qed.
-
-Ltac NoRepet :=
- match goal with
- | |- list_norepet nil =>
- apply list_norepet_nil
- | |- list_norepet (?a :: ?b) =>
- apply list_norepet_cons; [simpl; intuition discriminate | NoRepet]
- end.
-
-Lemma int_callee_save_norepet:
- list_norepet int_callee_save_regs.
-Proof.
- unfold int_callee_save_regs; NoRepet.
-Qed.
-
-Lemma float_callee_save_norepet:
- list_norepet float_callee_save_regs.
-Proof.
- unfold float_callee_save_regs; NoRepet.
-Qed.
-
(** * Function calling conventions *)
(** The functions in this section determine the locations (machine registers
@@ -260,12 +109,12 @@ Qed.
Lemma loc_result_caller_save:
forall (s: signature) (r: mreg),
- In r (loc_result s) -> In r destroyed_at_call.
+ In r (loc_result s) -> is_callee_save r = false.
Proof.
intros.
assert (r = R0 \/ r = R1 \/ r = F0).
unfold loc_result in H. destruct (sig_res s); [destruct t|idtac]; simpl in H; intuition.
- destruct H0 as [A | [A | A]]; subst r; simpl; OrEq.
+ destruct H0 as [A | [A | A]]; subst r; auto.
Qed.
(** ** Location of function arguments *)
@@ -425,8 +274,8 @@ Definition size_arguments (s: signature) : Z :=
Definition loc_argument_acceptable (l: loc) : Prop :=
match l with
- | R r => In r destroyed_at_call
- | S Outgoing ofs ty => ofs >= 0 /\ ty <> Tlong
+ | R r => is_callee_save r = false
+ | S Outgoing ofs ty => ofs >= 0 /\ (typealign ty | ofs)
| _ => False
end.
@@ -451,20 +300,20 @@ Remark loc_arguments_hf_charact:
In l (loc_arguments_hf tyl ir fr ofs) ->
match l with
| R r => In r int_param_regs \/ In r float_param_regs
- | S Outgoing ofs' ty => ofs' >= ofs /\ ty <> Tlong
+ | S Outgoing ofs' ty => ofs' >= ofs /\ typealign ty = 1
| S _ _ _ => False
end.
Proof.
assert (INCR: forall l ofs1 ofs2,
match l with
| R r => In r int_param_regs \/ In r float_param_regs
- | S Outgoing ofs' ty => ofs' >= ofs2 /\ ty <> Tlong
+ | S Outgoing ofs' ty => ofs' >= ofs2 /\ typealign ty = 1
| S _ _ _ => False
end ->
ofs1 <= ofs2 ->
match l with
| R r => In r int_param_regs \/ In r float_param_regs
- | S Outgoing ofs' ty => ofs' >= ofs1 /\ ty <> Tlong
+ | S Outgoing ofs' ty => ofs' >= ofs1 /\ typealign ty = 1
| S _ _ _ => False
end).
{
@@ -477,13 +326,13 @@ Proof.
destruct (zlt ir 4); destruct H.
subst. left; apply ireg_param_in_params.
eapply IHtyl; eauto.
- subst. split; [omega | congruence].
+ subst. split; [omega | auto].
eapply INCR. eapply IHtyl; eauto. omega.
- (* float *)
destruct (zlt fr 8); destruct H.
subst. right; apply freg_param_in_params.
eapply IHtyl; eauto.
- subst. split. apply Zle_ge. apply align_le. omega. congruence.
+ subst. split. apply Zle_ge. apply align_le. omega. auto.
eapply INCR. eapply IHtyl; eauto.
apply Zle_trans with (align ofs 2). apply align_le; omega. omega.
- (* long *)
@@ -493,26 +342,26 @@ Proof.
destruct H. subst l; left; apply ireg_param_in_params.
destruct H. subst l; left; apply ireg_param_in_params.
eapply IHtyl; eauto.
- destruct H. subst l; split; [ omega | congruence ].
- destruct H. subst l; split; [ omega | congruence ].
+ destruct H. subst l; split; [ omega | auto ].
+ destruct H. subst l; split; [ omega | auto ].
eapply INCR. eapply IHtyl; eauto. omega.
- (* single *)
destruct (zlt fr 8); destruct H.
subst. right; apply freg_param_in_params.
eapply IHtyl; eauto.
- subst. split; [omega | congruence].
+ subst. split; [omega | auto].
eapply INCR. eapply IHtyl; eauto. omega.
- (* any32 *)
destruct (zlt ir 4); destruct H.
subst. left; apply ireg_param_in_params.
eapply IHtyl; eauto.
- subst. split; [omega | congruence].
+ subst. split; [omega | auto].
eapply INCR. eapply IHtyl; eauto. omega.
- (* any64 *)
destruct (zlt fr 8); destruct H.
subst. right; apply freg_param_in_params.
eapply IHtyl; eauto.
- subst. split. apply Zle_ge. apply align_le. omega. congruence.
+ subst. split. apply Zle_ge. apply align_le. omega. auto.
eapply INCR. eapply IHtyl; eauto.
apply Zle_trans with (align ofs 2). apply align_le; omega. omega.
Qed.
@@ -522,20 +371,20 @@ Remark loc_arguments_sf_charact:
In l (loc_arguments_sf tyl ofs) ->
match l with
| R r => In r int_param_regs \/ In r float_param_regs
- | S Outgoing ofs' ty => ofs' >= Zmax 0 ofs /\ ty <> Tlong
+ | S Outgoing ofs' ty => ofs' >= Zmax 0 ofs /\ typealign ty = 1
| S _ _ _ => False
end.
Proof.
assert (INCR: forall l ofs1 ofs2,
match l with
| R r => In r int_param_regs \/ In r float_param_regs
- | S Outgoing ofs' ty => ofs' >= Zmax 0 ofs2 /\ ty <> Tlong
+ | S Outgoing ofs' ty => ofs' >= Zmax 0 ofs2 /\ typealign ty = 1
| S _ _ _ => False
end ->
ofs1 <= ofs2 ->
match l with
| R r => In r int_param_regs \/ In r float_param_regs
- | S Outgoing ofs' ty => ofs' >= Zmax 0 ofs1 /\ ty <> Tlong
+ | S Outgoing ofs' ty => ofs' >= Zmax 0 ofs1 /\ typealign ty = 1
| S _ _ _ => False
end).
{
@@ -548,7 +397,7 @@ Proof.
destruct H.
destruct (zlt ofs 0); subst l.
left; apply ireg_param_in_params.
- split. xomega. congruence.
+ split. xomega. auto.
eapply INCR. eapply IHtyl; eauto. omega.
- (* float *)
set (ofs' := align ofs 2) in *.
@@ -556,7 +405,7 @@ Proof.
destruct H.
destruct (zlt ofs' 0); subst l.
right; apply freg_param_in_params.
- split. xomega. congruence.
+ split. xomega. auto.
eapply INCR. eapply IHtyl; eauto. omega.
- (* long *)
set (ofs' := align ofs 2) in *.
@@ -564,23 +413,23 @@ Proof.
destruct H.
destruct (zlt ofs' 0); subst l.
left; apply ireg_param_in_params.
- split. xomega. congruence.
+ split. xomega. auto.
destruct H.
destruct (zlt ofs' 0); subst l.
left; apply ireg_param_in_params.
- split. xomega. congruence.
+ split. xomega. auto.
eapply INCR. eapply IHtyl; eauto. omega.
- (* single *)
destruct H.
destruct (zlt ofs 0); subst l.
right; apply freg_param_in_params.
- split. xomega. congruence.
+ split. xomega. auto.
eapply INCR. eapply IHtyl; eauto. omega.
- (* any32 *)
destruct H.
destruct (zlt ofs 0); subst l.
left; apply ireg_param_in_params.
- split. xomega. congruence.
+ split. xomega. auto.
eapply INCR. eapply IHtyl; eauto. omega.
- (* any64 *)
set (ofs' := align ofs 2) in *.
@@ -588,7 +437,7 @@ Proof.
destruct H.
destruct (zlt ofs' 0); subst l.
right; apply freg_param_in_params.
- split. xomega. congruence.
+ split. xomega. auto.
eapply INCR. eapply IHtyl; eauto. omega.
Qed.
@@ -597,14 +446,18 @@ Lemma loc_arguments_acceptable:
In l (loc_arguments s) -> loc_argument_acceptable l.
Proof.
unfold loc_arguments; intros.
- assert (forall r, In r int_param_regs \/ In r float_param_regs -> In r destroyed_at_call).
- {
- intros. elim H0; simpl; ElimOrEq; OrEq.
- }
+ assert (A: forall r, In r int_param_regs -> is_callee_save r = false) by decide_goal.
+ assert (B: forall r, In r float_param_regs -> is_callee_save r = false) by decide_goal.
+ assert (C: forall r, In r int_param_regs \/ In r float_param_regs -> is_callee_save r = false).
+ { intros. destruct H0; auto. }
assert (In l (loc_arguments_sf (sig_args s) (-4)) -> loc_argument_acceptable l).
- { intros. red. exploit loc_arguments_sf_charact; eauto. destruct l; auto. }
+ { intros. red. exploit loc_arguments_sf_charact; eauto.
+ destruct l as [r | [] ofs ty]; auto.
+ intros [P Q]. rewrite Q; split. auto. apply Z.divide_1_l. }
assert (In l (loc_arguments_hf (sig_args s) 0 0 0) -> loc_argument_acceptable l).
- { intros. red. exploit loc_arguments_hf_charact; eauto. destruct l; auto. }
+ { intros. red. exploit loc_arguments_hf_charact; eauto.
+ destruct l as [r | [] ofs ty]; auto.
+ intros [P Q]. rewrite Q; split. auto. apply Z.divide_1_l. }
destruct Archi.abi; [ | destruct (cc_vararg (sig_cc s)) ]; auto.
Qed.
diff --git a/arm/Machregs.v b/arm/Machregs.v
index 211d2791..b43f9be6 100644
--- a/arm/Machregs.v
+++ b/arm/Machregs.v
@@ -12,6 +12,7 @@
Require Import String.
Require Import Coqlib.
+Require Import Decidableplus.
Require Import Maps.
Require Import AST.
Require Import Op.
@@ -43,6 +44,26 @@ Lemma mreg_eq: forall (r1 r2: mreg), {r1 = r2} + {r1 <> r2}.
Proof. decide equality. Defined.
Global Opaque mreg_eq.
+Definition all_mregs :=
+ R0 :: R1 :: R2 :: R3 :: R4 :: R5 :: R6 :: R7
+ :: R8 :: R9 :: R10 :: R11 :: R12
+ :: F0 :: F1 :: F2 :: F3 :: F4 :: F5 :: F6 :: F7
+ :: F8 :: F9 :: F10 :: F11 :: F12 :: F13 :: F14 :: F15 :: nil.
+
+Lemma all_mregs_complete:
+ forall (r: mreg), In r all_mregs.
+Proof.
+ assert (forall r, proj_sumbool (In_dec mreg_eq r all_mregs) = true) by (destruct r; reflexivity).
+ intros. specialize (H r). InvBooleans. auto.
+Qed.
+
+Instance Decidable_eq_mreg : forall (x y: mreg), Decidable (eq x y) := Decidable_eq mreg_eq.
+
+Instance Finite_mreg : Finite mreg := {
+ Finite_elements := all_mregs;
+ Finite_elements_spec := all_mregs_complete
+}.
+
Definition mreg_type (r: mreg): typ :=
match r with
| R0 | R1 | R2 | R3 | R4 | R5 | R6 | R7
@@ -70,7 +91,7 @@ Module IndexedMreg <: INDEXED_TYPE.
Lemma index_inj:
forall r1 r2, index r1 = index r2 -> r1 = r2.
Proof.
- destruct r1; destruct r2; simpl; intro; discriminate || reflexivity.
+ decide_goal.
Qed.
End IndexedMreg.
diff --git a/arm/Stacklayout.v b/arm/Stacklayout.v
index 82d11727..f5c07fff 100644
--- a/arm/Stacklayout.v
+++ b/arm/Stacklayout.v
@@ -13,6 +13,7 @@
(** Machine- and ABI-dependent layout information for activation records. *)
Require Import Coqlib.
+Require Import Memory Separation.
Require Import Bounds.
(** The general shape of activation records is as follows,
@@ -31,102 +32,112 @@ the boundaries between areas in the frame part.
Definition fe_ofs_arg := 0.
-Record frame_env : Type := mk_frame_env {
- fe_size: Z;
- fe_ofs_link: Z;
- fe_ofs_retaddr: Z;
- fe_ofs_local: Z;
- fe_ofs_int_callee_save: Z;
- fe_num_int_callee_save: Z;
- fe_ofs_float_callee_save: Z;
- fe_num_float_callee_save: Z;
- fe_stack_data: Z
-}.
-
(** Computation of the frame environment from the bounds of the current
function. *)
Definition make_env (b: bounds) :=
let ol := align (4 * b.(bound_outgoing)) 8 in (* locals *)
- let oics := ol + 4 * b.(bound_local) in (* integer callee-saves *)
- let oendi := oics + 4 * b.(bound_int_callee_save) in
- let ofcs := align oendi 8 in (* float callee-saves *)
- let ora := ofcs + 8 * b.(bound_float_callee_save) in (* retaddr *)
+ let ocs := ol + 4 * b.(bound_local) in (* callee-saves *)
+ let ora := align (size_callee_save_area b ocs) 4 in (* retaddr *)
let olink := ora + 4 in (* back link *)
- let ostkdata := olink + 4 in (* stack data *)
+ let ostkdata := align (olink + 4) 8 in (* stack data *)
let sz := align (ostkdata + b.(bound_stack_data)) 8 in
- mk_frame_env sz olink ora ol
- oics b.(bound_int_callee_save)
- ofcs b.(bound_float_callee_save)
- ostkdata.
+ {| fe_size := sz;
+ fe_ofs_link := olink;
+ fe_ofs_retaddr := ora;
+ fe_ofs_local := ol;
+ fe_ofs_callee_save := ocs;
+ fe_stack_data := ostkdata;
+ fe_used_callee_save := b.(used_callee_save) |}.
(** Separation property *)
-Remark frame_env_separated:
- forall b,
+Local Open Scope sep_scope.
+
+Lemma frame_env_separated:
+ forall b sp m P,
let fe := make_env b in
- 0 <= fe_ofs_arg
- /\ fe_ofs_arg + 4 * b.(bound_outgoing) <= fe.(fe_ofs_local)
- /\ fe.(fe_ofs_local) + 4 * b.(bound_local) <= fe.(fe_ofs_int_callee_save)
- /\ fe.(fe_ofs_int_callee_save) + 4 * b.(bound_int_callee_save) <= fe.(fe_ofs_float_callee_save)
- /\ fe.(fe_ofs_float_callee_save) + 8 * b.(bound_float_callee_save) <= fe.(fe_ofs_retaddr)
- /\ fe.(fe_ofs_retaddr) + 4 <= fe.(fe_ofs_link)
- /\ fe.(fe_ofs_link) + 4 <= fe.(fe_stack_data)
- /\ fe.(fe_stack_data) + b.(bound_stack_data) <= fe.(fe_size).
+ m |= range sp 0 (fe_stack_data fe) ** range sp (fe_stack_data fe + bound_stack_data b) (fe_size fe) ** P ->
+ m |= range sp (fe_ofs_local fe) (fe_ofs_local fe + 4 * bound_local b)
+ ** range sp fe_ofs_arg (fe_ofs_arg + 4 * bound_outgoing b)
+ ** range sp (fe_ofs_link fe) (fe_ofs_link fe + 4)
+ ** range sp (fe_ofs_retaddr fe) (fe_ofs_retaddr fe + 4)
+ ** range sp (fe_ofs_callee_save fe) (size_callee_save_area b (fe_ofs_callee_save fe))
+ ** P.
Proof.
- intros.
- generalize (align_le (4 * bound_outgoing b) 8 (refl_equal)).
- generalize (align_le (fe_ofs_int_callee_save fe + 4 * b.(bound_int_callee_save)) 8 (refl_equal _)).
- generalize (align_le (fe_stack_data fe + b.(bound_stack_data)) 8 (refl_equal)).
- unfold fe, make_env, fe_size, fe_ofs_link, fe_ofs_retaddr,
- fe_ofs_local, fe_ofs_int_callee_save, fe_num_int_callee_save,
- fe_ofs_float_callee_save, fe_num_float_callee_save,
- fe_stack_data, fe_ofs_arg.
- intros.
- generalize (bound_local_pos b); intro;
- generalize (bound_int_callee_save_pos b); intro;
- generalize (bound_float_callee_save_pos b); intro;
- generalize (bound_outgoing_pos b); intro;
- generalize (bound_stack_data_pos b); intro.
- omega.
+Local Opaque Z.add Z.mul sepconj range.
+ intros; simpl.
+ set (ol := align (4 * b.(bound_outgoing)) 8);
+ set (ocs := ol + 4 * b.(bound_local));
+ set (ora := align (size_callee_save_area b ocs) 4);
+ set (olink := ora + 4);
+ set (ostkdata := align (olink + 4) 8).
+ generalize b.(bound_local_pos) b.(bound_outgoing_pos) b.(bound_stack_data_pos); intros.
+ assert (4 * b.(bound_outgoing) <= ol) by (apply align_le; omega).
+ assert (ol + 4 * b.(bound_local) <= ocs) by (unfold ocs; omega).
+ assert (ocs <= size_callee_save_area b ocs) by apply size_callee_save_area_incr.
+ assert (size_callee_save_area b ocs <= ora) by (apply align_le; omega).
+ assert (ora <= olink) by (unfold olink; omega).
+ assert (olink + 4 <= ostkdata) by (apply align_le; omega).
+(* Reorder as:
+ outgoing
+ local
+ callee-save
+ retaddr
+ back link *)
+ rewrite sep_swap12.
+ rewrite sep_swap45.
+ rewrite sep_swap34.
+ rewrite sep_swap45.
+(* Apply range_split and range_split2 repeatedly *)
+ unfold fe_ofs_arg.
+ apply range_split_2. fold ol; omega. omega.
+ apply range_split. omega.
+ apply range_split_2. fold ora; omega. omega.
+ apply range_split. omega.
+ apply range_drop_right with ostkdata. omega.
+ eapply sep_drop2. eexact H.
Qed.
-(** Alignment property *)
+Lemma frame_env_range:
+ forall b,
+ let fe := make_env b in
+ 0 <= fe_stack_data fe /\ fe_stack_data fe + bound_stack_data b <= fe_size fe.
+Proof.
+ intros; simpl.
+ set (ol := align (4 * b.(bound_outgoing)) 8);
+ set (ocs := ol + 4 * b.(bound_local));
+ set (ora := align (size_callee_save_area b ocs) 4);
+ set (olink := ora + 4);
+ set (ostkdata := align (olink + 4) 8).
+ generalize b.(bound_local_pos) b.(bound_outgoing_pos) b.(bound_stack_data_pos); intros.
+ assert (4 * b.(bound_outgoing) <= ol) by (apply align_le; omega).
+ assert (ol + 4 * b.(bound_local) <= ocs) by (unfold ocs; omega).
+ assert (ocs <= size_callee_save_area b ocs) by apply size_callee_save_area_incr.
+ assert (size_callee_save_area b ocs <= ora) by (apply align_le; omega).
+ assert (ora <= olink) by (unfold olink; omega).
+ assert (olink + 4 <= ostkdata) by (apply align_le; omega).
+ split. omega. apply align_le; omega.
+Qed.
-Remark frame_env_aligned:
+Lemma frame_env_aligned:
forall b,
let fe := make_env b in
- (4 | fe.(fe_ofs_link))
- /\ (8 | fe.(fe_ofs_local))
- /\ (4 | fe.(fe_ofs_int_callee_save))
- /\ (8 | fe.(fe_ofs_float_callee_save))
- /\ (4 | fe.(fe_ofs_retaddr))
- /\ (8 | fe.(fe_stack_data))
- /\ (8 | fe.(fe_size)).
+ (8 | fe_ofs_arg)
+ /\ (8 | fe_ofs_local fe)
+ /\ (8 | fe_stack_data fe)
+ /\ (4 | fe_ofs_link fe)
+ /\ (4 | fe_ofs_retaddr fe).
Proof.
- intros.
- unfold fe, make_env, fe_size, fe_ofs_link, fe_ofs_retaddr,
- fe_ofs_local, fe_ofs_int_callee_save, fe_num_int_callee_save,
- fe_ofs_float_callee_save, fe_num_float_callee_save,
- fe_stack_data.
- set (x1 := 4 * bound_outgoing b).
- assert (4 | x1). unfold x1; exists (bound_outgoing b); ring.
- set (x2 := align x1 8).
- assert (8 | x2). apply align_divides. omega.
- set (x3 := x2 + 4 * bound_local b).
- assert (4 | x3). apply Zdivide_plus_r. apply Zdivides_trans with 8; auto. exists 2; auto.
- exists (bound_local b); ring.
- set (x4 := align (x3 + 4 * bound_int_callee_save b) 8).
- assert (8 | x4). apply align_divides. omega.
- set (x5 := x4 + 8 * bound_float_callee_save b).
- assert (8 | x5). apply Zdivide_plus_r; auto. exists (bound_float_callee_save b); ring.
- assert (4 | x5). apply Zdivides_trans with 8; auto. exists 2; auto.
- set (x6 := x5 + 4).
- assert (4 | x6). apply Zdivide_plus_r; auto. exists 1; auto.
- set (x7 := x6 + 4).
- assert (8 | x7). unfold x7, x6. replace (x5 + 4 + 4) with (x5 + 8) by omega.
- apply Zdivide_plus_r; auto. exists 1; auto.
- set (x8 := align (x7 + bound_stack_data b) 8).
- assert (8 | x8). apply align_divides. omega.
- tauto.
+ intros; simpl.
+ set (ol := align (4 * b.(bound_outgoing)) 8);
+ set (ocs := ol + 4 * b.(bound_local));
+ set (ora := align (size_callee_save_area b ocs) 4);
+ set (olink := ora + 4);
+ set (ostkdata := align (olink + 4) 8).
+ split. apply Zdivide_0.
+ split. apply align_divides; omega.
+ split. apply align_divides; omega.
+ split. apply Z.divide_add_r. apply align_divides; omega. apply Z.divide_refl.
+ apply align_divides; omega.
Qed.
diff --git a/backend/Allocation.v b/backend/Allocation.v
index 6a6c1eb6..84606210 100644
--- a/backend/Allocation.v
+++ b/backend/Allocation.v
@@ -781,8 +781,7 @@ Definition no_caller_saves (e: eqs) : bool :=
EqSet.for_all
(fun eq =>
match eloc eq with
- | R r =>
- zle 0 (index_int_callee_save r) || zle 0 (index_float_callee_save r)
+ | R r => is_callee_save r
| S Outgoing _ _ => false
| S _ _ _ => true
end)
@@ -821,7 +820,7 @@ Definition compat_left2 (r: reg) (l1 l2: loc) (e: eqs) : bool :=
Definition ros_compatible_tailcall (ros: mreg + ident) : bool :=
match ros with
- | inl r => In_dec mreg_eq r destroyed_at_call
+ | inl r => negb (is_callee_save r)
| inr id => true
end.
diff --git a/backend/Allocproof.v b/backend/Allocproof.v
index 84d4bdd5..bf60a57f 100644
--- a/backend/Allocproof.v
+++ b/backend/Allocproof.v
@@ -1120,7 +1120,7 @@ Qed.
Definition callee_save_loc (l: loc) :=
match l with
- | R r => ~(In r destroyed_at_call)
+ | R r => is_callee_save r = true
| S sl ofs ty => sl <> Outgoing
end.
@@ -1133,7 +1133,7 @@ Lemma return_regs_agree_callee_save:
Proof.
intros; red; intros. unfold return_regs. red in H.
destruct l.
- rewrite pred_dec_false; auto.
+ rewrite H; auto.
destruct sl; auto || congruence.
Qed.
@@ -1146,13 +1146,7 @@ Proof.
unfold no_caller_saves, callee_save_loc; intros.
exploit EqSet.for_all_2; eauto.
hnf. intros. simpl in H1. rewrite H1. auto.
- lazy beta. destruct (eloc q).
- intros; red; intros. destruct (orb_true_elim _ _ H1); InvBooleans.
- eapply int_callee_save_not_destroyed; eauto.
- apply index_int_callee_save_pos2. omega.
- eapply float_callee_save_not_destroyed; eauto.
- apply index_float_callee_save_pos2. omega.
- destruct sl; congruence.
+ lazy beta. destruct (eloc q). auto. destruct sl; congruence.
Qed.
Lemma function_return_satisf:
@@ -1304,7 +1298,7 @@ Proof.
exploit tailcall_is_possible_correct; eauto.
unfold loc_argument_acceptable, return_regs.
destruct x; intros.
- rewrite pred_dec_true; auto.
+ rewrite H2; auto.
contradiction.
Qed.
@@ -1315,8 +1309,7 @@ Lemma find_function_tailcall:
Proof.
unfold ros_compatible_tailcall, find_function; intros.
destruct ros as [r|id]; auto.
- unfold return_regs. destruct (in_dec mreg_eq r destroyed_at_call); simpl in H.
- auto. congruence.
+ unfold return_regs. destruct (is_callee_save r). discriminate. auto.
Qed.
Lemma loadv_int64_split:
@@ -2224,7 +2217,7 @@ Proof.
with (map ls1 (map R (loc_result (RTL.fn_sig f)))).
eapply add_equations_res_lessdef; eauto.
rewrite !list_map_compose. apply list_map_exten; intros.
- unfold return_regs. apply pred_dec_true. eapply loc_result_caller_save; eauto.
+ unfold return_regs. erewrite loc_result_caller_save by eauto. auto.
apply return_regs_agree_callee_save.
unfold proj_sig_res. rewrite <- H11; rewrite H13. apply WTRS.
@@ -2267,8 +2260,7 @@ Proof.
red; intros. rewrite Locmap.gsetlisto. apply AG; auto.
apply Loc.notin_iff. intros.
exploit list_in_map_inv; eauto. intros [r [A B]]; subst l'.
- destruct l; simpl; auto. red; intros; subst r0; elim H0.
- eapply loc_result_caller_save; eauto.
+ destruct l; simpl; auto. red in H0. apply loc_result_caller_save in B. congruence.
simpl. eapply external_call_well_typed; eauto.
(* return *)
diff --git a/backend/Bounds.v b/backend/Bounds.v
index 2a63b1d5..178ff6ed 100644
--- a/backend/Bounds.v
+++ b/backend/Bounds.v
@@ -12,13 +12,18 @@
(** Computation of resource bounds for Linear code. *)
-Require Import Coqlib.
+Require Import FSets FSetAVL.
+Require Import Coqlib Ordered.
+Require Intv.
Require Import AST.
Require Import Op.
-Require Import Locations.
+Require Import Machregs Locations.
Require Import Linear.
Require Import Conventions.
+Module RegOrd := OrderedIndexed (IndexedMreg).
+Module RegSet := FSetAVL.Make (RegOrd).
+
(** * Resource bounds for a function *)
(** The [bounds] record capture how many local and outgoing stack slots
@@ -29,16 +34,15 @@ Require Import Conventions.
the activation record. *)
Record bounds : Type := mkbounds {
+ used_callee_save: list mreg;
bound_local: Z;
- bound_int_callee_save: Z;
- bound_float_callee_save: Z;
bound_outgoing: Z;
bound_stack_data: Z;
bound_local_pos: bound_local >= 0;
- bound_int_callee_save_pos: bound_int_callee_save >= 0;
- bound_float_callee_save_pos: bound_float_callee_save >= 0;
bound_outgoing_pos: bound_outgoing >= 0;
- bound_stack_data_pos: bound_stack_data >= 0
+ bound_stack_data_pos: bound_stack_data >= 0;
+ used_callee_save_norepet: list_norepet used_callee_save;
+ used_callee_save_prop: forall r, In r used_callee_save -> is_callee_save r = true
}.
(** The following predicates define the correctness of a set of bounds
@@ -49,8 +53,7 @@ Section WITHIN_BOUNDS.
Variable b: bounds.
Definition mreg_within_bounds (r: mreg) :=
- index_int_callee_save r < bound_int_callee_save b
- /\ index_float_callee_save r < bound_float_callee_save b.
+ is_callee_save r = true -> In r (used_callee_save b).
Definition slot_within_bounds (sl: slot) (ofs: Z) (ty: typ) :=
match sl with
@@ -86,28 +89,37 @@ Section BOUNDS.
Variable f: function.
+Definition record_reg (u: RegSet.t) (r: mreg) : RegSet.t :=
+ if is_callee_save r then RegSet.add r u else u.
+
+Definition record_regs (u: RegSet.t) (rl: list mreg) : RegSet.t :=
+ fold_left record_reg rl u.
+
(** In the proof of the [Stacking] pass, we only need to bound the
- registers written by an instruction. Therefore, this function
- returns these registers, ignoring registers used only as
- arguments. *)
+ registers written by an instruction. Therefore, we examine the
+ result registers only, not the argument registers. *)
-Definition regs_of_instr (i: instruction) : list mreg :=
+Definition record_regs_of_instr (u: RegSet.t) (i: instruction) : RegSet.t :=
match i with
- | Lgetstack sl ofs ty r => r :: nil
- | Lsetstack r sl ofs ty => r :: nil
- | Lop op args res => res :: nil
- | Lload chunk addr args dst => dst :: nil
- | Lstore chunk addr args src => nil
- | Lcall sig ros => nil
- | Ltailcall sig ros => nil
- | Lbuiltin ef args res => params_of_builtin_res res ++ destroyed_by_builtin ef
- | Llabel lbl => nil
- | Lgoto lbl => nil
- | Lcond cond args lbl => nil
- | Ljumptable arg tbl => nil
- | Lreturn => nil
+ | Lgetstack sl ofs ty r => record_reg u r
+ | Lsetstack r sl ofs ty => record_reg u r
+ | Lop op args res => record_reg u res
+ | Lload chunk addr args dst => record_reg u dst
+ | Lstore chunk addr args src => u
+ | Lcall sig ros => u
+ | Ltailcall sig ros => u
+ | Lbuiltin ef args res =>
+ record_regs (record_regs u (params_of_builtin_res res)) (destroyed_by_builtin ef)
+ | Llabel lbl => u
+ | Lgoto lbl => u
+ | Lcond cond args lbl => u
+ | Ljumptable arg tbl => u
+ | Lreturn => u
end.
+Definition record_regs_of_function : RegSet.t :=
+ fold_left record_regs_of_instr f.(fn_code) RegSet.empty.
+
Fixpoint slots_of_locs (l: list loc) : list (slot * Z * typ) :=
match l with
| nil => nil
@@ -129,22 +141,12 @@ Definition max_over_list {A: Type} (valu: A -> Z) (l: list A) : Z :=
Definition max_over_instrs (valu: instruction -> Z) : Z :=
max_over_list valu f.(fn_code).
-Definition max_over_regs_of_instr (valu: mreg -> Z) (i: instruction) : Z :=
- max_over_list valu (regs_of_instr i).
-
Definition max_over_slots_of_instr (valu: slot * Z * typ -> Z) (i: instruction) : Z :=
max_over_list valu (slots_of_instr i).
-Definition max_over_regs_of_funct (valu: mreg -> Z) : Z :=
- max_over_instrs (max_over_regs_of_instr valu).
-
Definition max_over_slots_of_funct (valu: slot * Z * typ -> Z) : Z :=
max_over_instrs (max_over_slots_of_instr valu).
-Definition int_callee_save (r: mreg) := 1 + index_int_callee_save r.
-
-Definition float_callee_save (r: mreg) := 1 + index_float_callee_save r.
-
Definition local_slot (s: slot * Z * typ) :=
match s with (Local, ofs, ty) => ofs + typesize ty | _ => 0 end.
@@ -172,25 +174,63 @@ Proof.
unfold max_over_instrs. apply max_over_list_pos.
Qed.
-Lemma max_over_regs_of_funct_pos:
- forall (valu: mreg -> Z), max_over_regs_of_funct valu >= 0.
+(* Move elsewhere? *)
+
+Remark fold_left_preserves:
+ forall (A B: Type) (f: A -> B -> A) (P: A -> Prop),
+ (forall a b, P a -> P (f a b)) ->
+ forall l a, P a -> P (fold_left f l a).
Proof.
- intros. unfold max_over_regs_of_funct.
- unfold max_over_instrs. apply max_over_list_pos.
+ induction l; simpl; auto.
+Qed.
+
+Remark fold_left_ensures:
+ forall (A B: Type) (f: A -> B -> A) (P: A -> Prop) b0,
+ (forall a b, P a -> P (f a b)) ->
+ (forall a, P (f a b0)) ->
+ forall l a, In b0 l -> P (fold_left f l a).
+Proof.
+ induction l; simpl; intros. contradiction.
+ destruct H1. subst a. apply fold_left_preserves; auto. apply IHl; auto.
+Qed.
+
+Definition only_callee_saves (u: RegSet.t) : Prop :=
+ forall r, RegSet.In r u -> is_callee_save r = true.
+
+Lemma record_reg_only: forall u r, only_callee_saves u -> only_callee_saves (record_reg u r).
+Proof.
+ unfold only_callee_saves, record_reg; intros.
+ destruct (is_callee_save r) eqn:CS; auto.
+ destruct (mreg_eq r r0). congruence. apply H; eapply RegSet.add_3; eauto.
+Qed.
+
+Lemma record_regs_only: forall rl u, only_callee_saves u -> only_callee_saves (record_regs u rl).
+Proof.
+ intros. unfold record_regs. apply fold_left_preserves; auto using record_reg_only.
Qed.
-Program Definition function_bounds :=
- mkbounds
- (max_over_slots_of_funct local_slot)
- (max_over_regs_of_funct int_callee_save)
- (max_over_regs_of_funct float_callee_save)
- (Zmax (max_over_instrs outgoing_space)
- (max_over_slots_of_funct outgoing_slot))
- (Zmax f.(fn_stacksize) 0)
- (max_over_slots_of_funct_pos local_slot)
- (max_over_regs_of_funct_pos int_callee_save)
- (max_over_regs_of_funct_pos float_callee_save)
- _ _.
+Lemma record_regs_of_instr_only: forall u i, only_callee_saves u -> only_callee_saves (record_regs_of_instr u i).
+Proof.
+ intros. destruct i; simpl; auto using record_reg_only, record_regs_only.
+Qed.
+
+Lemma record_regs_of_function_only:
+ only_callee_saves record_regs_of_function.
+Proof.
+ intros. unfold record_regs_of_function.
+ apply fold_left_preserves. apply record_regs_of_instr_only.
+ red; intros. eelim RegSet.empty_1; eauto.
+Qed.
+
+Program Definition function_bounds := {|
+ used_callee_save := RegSet.elements record_regs_of_function;
+ bound_local := max_over_slots_of_funct local_slot;
+ bound_outgoing := Zmax (max_over_instrs outgoing_space) (max_over_slots_of_funct outgoing_slot);
+ bound_stack_data := Zmax f.(fn_stacksize) 0
+|}.
+Next Obligation.
+ apply max_over_slots_of_funct_pos.
+Qed.
Next Obligation.
apply Zle_ge. eapply Zle_trans. 2: apply Zmax2.
apply Zge_le. apply max_over_slots_of_funct_pos.
@@ -198,9 +238,66 @@ Qed.
Next Obligation.
apply Zle_ge. apply Zmax2.
Qed.
-
+Next Obligation.
+ generalize (RegSet.elements_3w record_regs_of_function).
+ generalize (RegSet.elements record_regs_of_function).
+ induction 1. constructor. constructor; auto.
+ red; intros; elim H. apply InA_alt. exists x; auto.
+Qed.
+Next Obligation.
+ apply record_regs_of_function_only. apply RegSet.elements_2.
+ apply InA_alt. exists r; auto.
+Qed.
+
(** We now show the correctness of the inferred bounds. *)
+Lemma record_reg_incr: forall u r r', RegSet.In r' u -> RegSet.In r' (record_reg u r).
+Proof.
+ unfold record_reg; intros. destruct (is_callee_save r); auto. apply RegSet.add_2; auto.
+Qed.
+
+Lemma record_reg_ok: forall u r, is_callee_save r = true -> RegSet.In r (record_reg u r).
+Proof.
+ unfold record_reg; intros. rewrite H. apply RegSet.add_1; auto.
+Qed.
+
+Lemma record_regs_incr: forall r' rl u, RegSet.In r' u -> RegSet.In r' (record_regs u rl).
+Proof.
+ intros. unfold record_regs. apply fold_left_preserves; auto using record_reg_incr.
+Qed.
+
+Lemma record_regs_ok: forall r rl u, In r rl -> is_callee_save r = true -> RegSet.In r (record_regs u rl).
+Proof.
+ intros. unfold record_regs. eapply fold_left_ensures; eauto using record_reg_incr, record_reg_ok.
+Qed.
+
+Lemma record_regs_of_instr_incr: forall r' u i, RegSet.In r' u -> RegSet.In r' (record_regs_of_instr u i).
+Proof.
+ intros. destruct i; simpl; auto using record_reg_incr, record_regs_incr.
+Qed.
+
+Definition defined_by_instr (r': mreg) (i: instruction) :=
+ match i with
+ | Lgetstack sl ofs ty r => r' = r
+ | Lop op args res => r' = res
+ | Lload chunk addr args dst => r' = dst
+ | Lbuiltin ef args res => In r' (params_of_builtin_res res) \/ In r' (destroyed_by_builtin ef)
+ | _ => False
+ end.
+
+Lemma record_regs_of_instr_ok: forall r' u i, defined_by_instr r' i -> is_callee_save r' = true -> RegSet.In r' (record_regs_of_instr u i).
+Proof.
+ intros. destruct i; simpl in *; try contradiction; subst; auto using record_reg_ok.
+ destruct H; auto using record_regs_incr, record_regs_ok.
+Qed.
+
+Lemma record_regs_of_function_ok:
+ forall r i, In i f.(fn_code) -> defined_by_instr r i -> is_callee_save r = true -> RegSet.In r record_regs_of_function.
+Proof.
+ intros. unfold record_regs_of_function.
+ eapply fold_left_ensures; eauto using record_regs_of_instr_incr, record_regs_of_instr_ok.
+Qed.
+
Lemma max_over_list_bound:
forall (A: Type) (valu: A -> Z) (l: list A) (x: A),
In x l -> valu x <= max_over_list valu l.
@@ -226,17 +323,6 @@ Proof.
intros. unfold max_over_instrs. apply max_over_list_bound; auto.
Qed.
-Lemma max_over_regs_of_funct_bound:
- forall (valu: mreg -> Z) i r,
- In i f.(fn_code) -> In r (regs_of_instr i) ->
- valu r <= max_over_regs_of_funct valu.
-Proof.
- intros. unfold max_over_regs_of_funct.
- apply Zle_trans with (max_over_regs_of_instr valu i).
- unfold max_over_regs_of_instr. apply max_over_list_bound. auto.
- apply max_over_instrs_bound. auto.
-Qed.
-
Lemma max_over_slots_of_funct_bound:
forall (valu: slot * Z * typ -> Z) i s,
In i f.(fn_code) -> In s (slots_of_instr i) ->
@@ -248,28 +334,6 @@ Proof.
apply max_over_instrs_bound. auto.
Qed.
-Lemma int_callee_save_bound:
- forall i r,
- In i f.(fn_code) -> In r (regs_of_instr i) ->
- index_int_callee_save r < bound_int_callee_save function_bounds.
-Proof.
- intros. apply Zlt_le_trans with (int_callee_save r).
- unfold int_callee_save. omega.
- unfold function_bounds, bound_int_callee_save.
- eapply max_over_regs_of_funct_bound; eauto.
-Qed.
-
-Lemma float_callee_save_bound:
- forall i r,
- In i f.(fn_code) -> In r (regs_of_instr i) ->
- index_float_callee_save r < bound_float_callee_save function_bounds.
-Proof.
- intros. apply Zlt_le_trans with (float_callee_save r).
- unfold float_callee_save. omega.
- unfold function_bounds, bound_float_callee_save.
- eapply max_over_regs_of_funct_bound; eauto.
-Qed.
-
Lemma local_slot_bound:
forall i ofs ty,
In i f.(fn_code) -> In (Local, ofs, ty) (slots_of_instr i) ->
@@ -306,12 +370,13 @@ Qed.
Lemma mreg_is_within_bounds:
forall i, In i f.(fn_code) ->
- forall r, In r (regs_of_instr i) ->
+ forall r, defined_by_instr r i ->
mreg_within_bounds function_bounds r.
Proof.
- intros. unfold mreg_within_bounds. split.
- eapply int_callee_save_bound; eauto.
- eapply float_callee_save_bound; eauto.
+ intros. unfold mreg_within_bounds. intros.
+ exploit record_regs_of_function_ok; eauto. intros.
+ apply RegSet.elements_1 in H2. rewrite InA_alt in H2. destruct H2 as (r' & A & B).
+ subst r'; auto.
Qed.
Lemma slot_is_within_bounds:
@@ -350,7 +415,7 @@ Proof.
eapply size_arguments_bound; eauto.
(* builtin *)
split; intros.
- apply H1. apply in_or_app; auto.
+ apply H1; auto.
apply H0. rewrite slots_of_locs_charact; auto.
Qed.
@@ -362,3 +427,90 @@ Qed.
End BOUNDS.
+(** Helper to determine the size of the frame area that holds the contents of saved registers. *)
+
+Fixpoint size_callee_save_area_rec (l: list mreg) (ofs: Z) : Z :=
+ match l with
+ | nil => ofs
+ | r :: l =>
+ let ty := mreg_type r in
+ let sz := AST.typesize ty in
+ size_callee_save_area_rec l (align ofs sz + sz)
+ end.
+
+Definition size_callee_save_area (b: bounds) (ofs: Z) : Z :=
+ size_callee_save_area_rec (used_callee_save b) ofs.
+
+Lemma size_callee_save_area_rec_incr:
+ forall l ofs, ofs <= size_callee_save_area_rec l ofs.
+Proof.
+ induction l as [ | r l]; intros; simpl.
+- omega.
+- eapply Zle_trans. 2: apply IHl.
+ generalize (AST.typesize_pos (mreg_type r)); intros.
+ apply Zle_trans with (align ofs (AST.typesize (mreg_type r))).
+ apply align_le; auto.
+ omega.
+Qed.
+
+Lemma size_callee_save_area_incr:
+ forall b ofs, ofs <= size_callee_save_area b ofs.
+Proof.
+ intros. apply size_callee_save_area_rec_incr.
+Qed.
+
+(** Layout of the stack frame and its properties. These definitions
+ are used in the machine-dependent [Stacklayout] module and in the
+ [Stacking] pass. *)
+
+Record frame_env : Type := mk_frame_env {
+ fe_size: Z;
+ fe_ofs_link: Z;
+ fe_ofs_retaddr: Z;
+ fe_ofs_local: Z;
+ fe_ofs_callee_save: Z;
+ fe_stack_data: Z;
+ fe_used_callee_save: list mreg
+}.
+
+(*
+Record frame_env_properties (b: bounds) (fe: frame_env) (fe_ofs_arg: Z) := mk_frame_env_properties {
+ (** Separation property *)
+ fe_separated:
+ Intv.pairwise_disjoint (
+ (fe.(fe_ofs_link), fe.(fe_ofs_link) + 4)
+ :: (fe.(fe_ofs_retaddr), fe.(fe_ofs_retaddr) + 4)
+ :: (fe.(fe_ofs_local), fe.(fe_ofs_local) + 4 * b.(bound_local))
+ :: (fe_ofs_arg, fe_ofs_arg + 4 * b.(bound_outgoing))
+ :: (fe.(fe_ofs_callee_save), size_callee_save_area b fe.(fe_ofs_callee_save))
+ :: (fe.(fe_stack_data), fe.(fe_stack_data) + b.(bound_stack_data))
+ :: nil);
+ (** Inclusion properties *)
+ fe_incl_link:
+ Intv.incl (fe.(fe_ofs_link), fe.(fe_ofs_link) + 4) (0, fe.(fe_size));
+ fe_incl_retaddr:
+ Intv.incl (fe.(fe_ofs_retaddr), fe.(fe_ofs_retaddr) + 4) (0, fe.(fe_size));
+ fe_incl_local:
+ Intv.incl (fe.(fe_ofs_local), fe.(fe_ofs_local) + 4 * b.(bound_local)) (0, fe.(fe_size));
+ fe_incl_outgoing:
+ Intv.incl (fe_ofs_arg, fe_ofs_arg + 4 * b.(bound_outgoing)) (0, fe.(fe_size));
+ fe_incl_callee_save:
+ Intv.incl (fe.(fe_ofs_callee_save), size_callee_save_area b fe.(fe_ofs_callee_save)) (0, fe.(fe_size));
+ fe_incl_stack_data:
+ Intv.incl (fe.(fe_stack_data), fe.(fe_stack_data) + b.(bound_stack_data)) (0, fe.(fe_size));
+ (** Alignment properties *)
+ fe_align_link:
+ (4 | fe.(fe_ofs_link));
+ fe_align_retaddr:
+ (4 | fe.(fe_ofs_retaddr));
+ fe_align_local:
+ (8 | fe.(fe_ofs_local));
+ fe_align_stack_data:
+ (8 | fe.(fe_stack_data));
+ fe_align_size:
+ (4 | fe.(fe_size));
+ (** Callee-save registers *)
+ fe_used_callee_save_eq:
+ fe.(fe_used_callee_save) = b.(used_callee_save)
+}.
+*)
diff --git a/backend/IRC.ml b/backend/IRC.ml
index d542f85e..036b4ac5 100644
--- a/backend/IRC.ml
+++ b/backend/IRC.ml
@@ -833,10 +833,10 @@ let find_slot conflicts typ =
| [] ->
S(Local, curr, typ)
| S(Local, ofs, typ') :: l ->
- if Z.le (Z.add curr (typesize typ)) ofs then
+ if Z.le (Z.add curr (Locations.typesize typ)) ofs then
S(Local, curr, typ)
else begin
- let ofs' = Z.add ofs (typesize typ') in
+ let ofs' = Z.add ofs (Locations.typesize typ') in
find (if Z.le ofs' curr then curr else ofs') l
end
| _ :: l ->
diff --git a/backend/LTL.v b/backend/LTL.v
index 48c5c850..bb596fa2 100644
--- a/backend/LTL.v
+++ b/backend/LTL.v
@@ -111,10 +111,7 @@ Definition call_regs (caller: locset) : locset :=
Definition return_regs (caller callee: locset) : locset :=
fun (l: loc) =>
match l with
- | R r =>
- if In_dec mreg_eq r destroyed_at_call
- then callee (R r)
- else caller (R r)
+ | R r => if is_callee_save r then caller (R r) else callee (R r)
| S sl ofs ty => caller (S sl ofs ty)
end.
diff --git a/backend/Lineartyping.v b/backend/Lineartyping.v
index a52e47bb..50cd16d6 100644
--- a/backend/Lineartyping.v
+++ b/backend/Lineartyping.v
@@ -38,8 +38,8 @@ Definition slot_valid (sl: slot) (ofs: Z) (ty: typ): bool :=
| Local => zle 0 ofs
| Outgoing => zle 0 ofs
| Incoming => In_dec Loc.eq (S Incoming ofs ty) (loc_parameters funct.(fn_sig))
- end &&
- match ty with Tlong => false | _ => true end.
+ end
+ && Zdivide_dec (typealign ty) ofs (typealign_pos ty).
Definition slot_writable (sl: slot) : bool :=
match sl with
@@ -146,8 +146,7 @@ Lemma wt_return_regs:
wt_locset caller -> wt_locset callee -> wt_locset (return_regs caller callee).
Proof.
intros; red; intros.
- unfold return_regs. destruct l; auto.
- destruct (in_dec mreg_eq r destroyed_at_call); auto.
+ unfold return_regs. destruct l; auto. destruct (is_callee_save r); auto.
Qed.
Lemma wt_init:
diff --git a/backend/Locations.v b/backend/Locations.v
index ea614585..6ca84ea7 100644
--- a/backend/Locations.v
+++ b/backend/Locations.v
@@ -84,6 +84,28 @@ Proof.
destruct ty; compute; auto.
Qed.
+Definition typealign (ty: typ) : Z :=
+ match ty with
+ | Tint => 1
+ | Tlong => 2
+ | Tfloat => 1
+ | Tsingle => 1
+ | Tany32 => 1
+ | Tany64 => 1
+ end.
+
+Lemma typealign_pos:
+ forall (ty: typ), typealign ty > 0.
+Proof.
+ destruct ty; compute; auto.
+Qed.
+
+Lemma typealign_typesize:
+ forall (ty: typ), (typealign ty | typesize ty).
+Proof.
+ intros. exists (typesize ty / typealign ty); destruct ty; reflexivity.
+Qed.
+
(** ** Locations *)
(** Locations are just the disjoint union of machine registers and
diff --git a/backend/Stacking.v b/backend/Stacking.v
index cf797a11..d1c17029 100644
--- a/backend/Stacking.v
+++ b/backend/Stacking.v
@@ -22,88 +22,45 @@ Require Import Bounds Conventions Stacklayout Lineartyping.
(** The machine- and ABI-dependent aspects of the layout are defined
in module [Stacklayout]. *)
-(** Computation the frame offset for the given component of the frame.
- The component is expressed by the following [frame_index] sum type. *)
-
-Inductive frame_index: Type :=
- | FI_link: frame_index
- | FI_retaddr: frame_index
- | FI_local: Z -> typ -> frame_index
- | FI_arg: Z -> typ -> frame_index
- | FI_saved_int: Z -> frame_index
- | FI_saved_float: Z -> frame_index.
-
-Definition offset_of_index (fe: frame_env) (idx: frame_index) :=
- match idx with
- | FI_link => fe.(fe_ofs_link)
- | FI_retaddr => fe.(fe_ofs_retaddr)
- | FI_local x ty => fe.(fe_ofs_local) + 4 * x
- | FI_arg x ty => fe_ofs_arg + 4 * x
- | FI_saved_int x => fe.(fe_ofs_int_callee_save) + 4 * x
- | FI_saved_float x => fe.(fe_ofs_float_callee_save) + 8 * x
- end.
-
-(** * Saving and restoring callee-save registers *)
-
-(** [save_callee_save fe k] adds before [k] the instructions that
- store in the frame the values of callee-save registers used by the
- current function. *)
+(** Offsets (in bytes) corresponding to stack slots. *)
-Definition save_callee_save_reg
- (bound: frame_env -> Z) (number: mreg -> Z) (mkindex: Z -> frame_index)
- (ty: typ) (fe: frame_env) (cs: mreg) (k: Mach.code) :=
- let i := number cs in
- if zlt i (bound fe)
- then Msetstack cs (Int.repr (offset_of_index fe (mkindex i))) ty :: k
- else k.
+Definition offset_local (fe: frame_env) (x: Z) := fe.(fe_ofs_local) + 4 * x.
-Definition save_callee_save_regs
- (bound: frame_env -> Z) (number: mreg -> Z) (mkindex: Z -> frame_index)
- (ty: typ) (fe: frame_env) (csl: list mreg) (k: Mach.code) :=
- List.fold_right (save_callee_save_reg bound number mkindex ty fe) k csl.
+Definition offset_arg (x: Z) := fe_ofs_arg + 4 * x.
-Definition save_callee_save_int (fe: frame_env) :=
- save_callee_save_regs
- fe_num_int_callee_save index_int_callee_save FI_saved_int
- Tany32 fe int_callee_save_regs.
+(** [save_callee_save rl ofs k] adds before [k] the instructions that
+ store in the frame the values of callee-save registers [rl],
+ starting at offset [ofs]. *)
-Definition save_callee_save_float (fe: frame_env) :=
- save_callee_save_regs
- fe_num_float_callee_save index_float_callee_save FI_saved_float
- Tany64 fe float_callee_save_regs.
+Fixpoint save_callee_save_rec (rl: list mreg) (ofs: Z) (k: Mach.code) :=
+ match rl with
+ | nil => k
+ | r :: rl =>
+ let ty := mreg_type r in
+ let sz := AST.typesize ty in
+ let ofs1 := align ofs sz in
+ Msetstack r (Int.repr ofs1) ty :: save_callee_save_rec rl (ofs1 + sz) k
+ end.
Definition save_callee_save (fe: frame_env) (k: Mach.code) :=
- save_callee_save_int fe (save_callee_save_float fe k).
+ save_callee_save_rec fe.(fe_used_callee_save) fe.(fe_ofs_callee_save) k.
(** [restore_callee_save fe k] adds before [k] the instructions that
re-load from the frame the values of callee-save registers used by the
current function, restoring these registers to their initial values. *)
-Definition restore_callee_save_reg
- (bound: frame_env -> Z) (number: mreg -> Z) (mkindex: Z -> frame_index)
- (ty: typ) (fe: frame_env) (cs: mreg) (k: Mach.code) :=
- let i := number cs in
- if zlt i (bound fe)
- then Mgetstack (Int.repr (offset_of_index fe (mkindex i))) ty cs :: k
- else k.
-
-Definition restore_callee_save_regs
- (bound: frame_env -> Z) (number: mreg -> Z) (mkindex: Z -> frame_index)
- (ty: typ) (fe: frame_env) (csl: list mreg) (k: Mach.code) :=
- List.fold_right (restore_callee_save_reg bound number mkindex ty fe) k csl.
-
-Definition restore_callee_save_int (fe: frame_env) :=
- restore_callee_save_regs
- fe_num_int_callee_save index_int_callee_save FI_saved_int
- Tany32 fe int_callee_save_regs.
-
-Definition restore_callee_save_float (fe: frame_env) :=
- restore_callee_save_regs
- fe_num_float_callee_save index_float_callee_save FI_saved_float
- Tany64 fe float_callee_save_regs.
+Fixpoint restore_callee_save_rec (rl: list mreg) (ofs: Z) (k: Mach.code) :=
+ match rl with
+ | nil => k
+ | r :: rl =>
+ let ty := mreg_type r in
+ let sz := AST.typesize ty in
+ let ofs1 := align ofs sz in
+ Mgetstack (Int.repr ofs1) ty r :: restore_callee_save_rec rl (ofs1 + sz) k
+ end.
Definition restore_callee_save (fe: frame_env) (k: Mach.code) :=
- restore_callee_save_int fe (restore_callee_save_float fe k).
+ restore_callee_save_rec fe.(fe_used_callee_save) fe.(fe_ofs_callee_save) k.
(** * Code transformation. *)
@@ -126,7 +83,7 @@ Fixpoint transl_builtin_arg (fe: frame_env) (a: builtin_arg loc) : builtin_arg m
match a with
| BA (R r) => BA r
| BA (S Local ofs ty) =>
- BA_loadstack (chunk_of_type ty) (Int.repr (offset_of_index fe (FI_local ofs ty)))
+ BA_loadstack (chunk_of_type ty) (Int.repr (offset_local fe ofs))
| BA (S _ _ _) => BA_int Int.zero (**r never happens *)
| BA_int n => BA_int n
| BA_long n => BA_long n
@@ -157,20 +114,20 @@ Definition transl_instr
| Lgetstack sl ofs ty r =>
match sl with
| Local =>
- Mgetstack (Int.repr (offset_of_index fe (FI_local ofs ty))) ty r :: k
+ Mgetstack (Int.repr (offset_local fe ofs)) ty r :: k
| Incoming =>
- Mgetparam (Int.repr (offset_of_index fe (FI_arg ofs ty))) ty r :: k
+ Mgetparam (Int.repr (offset_arg ofs)) ty r :: k
| Outgoing =>
- Mgetstack (Int.repr (offset_of_index fe (FI_arg ofs ty))) ty r :: k
+ Mgetstack (Int.repr (offset_arg ofs)) ty r :: k
end
| Lsetstack r sl ofs ty =>
match sl with
| Local =>
- Msetstack r (Int.repr (offset_of_index fe (FI_local ofs ty))) ty :: k
+ Msetstack r (Int.repr (offset_local fe ofs)) ty :: k
| Incoming =>
k (* should not happen *)
| Outgoing =>
- Msetstack r (Int.repr (offset_of_index fe (FI_arg ofs ty))) ty :: k
+ Msetstack r (Int.repr (offset_arg ofs)) ty :: k
end
| Lop op args res =>
Mop (transl_op fe op) args res :: k
@@ -181,8 +138,7 @@ Definition transl_instr
| Lcall sig ros =>
Mcall sig ros :: k
| Ltailcall sig ros =>
- restore_callee_save fe
- (Mtailcall sig ros :: k)
+ restore_callee_save fe (Mtailcall sig ros :: k)
| Lbuiltin ef args dst =>
Mbuiltin ef (map (transl_builtin_arg fe) args) dst :: k
| Llabel lbl =>
@@ -194,8 +150,7 @@ Definition transl_instr
| Ljumptable arg tbl =>
Mjumptable arg tbl :: k
| Lreturn =>
- restore_callee_save fe
- (Mreturn :: k)
+ restore_callee_save fe (Mreturn :: k)
end.
(** Translation of a function. Code that saves the values of used
diff --git a/backend/Stackingproof.v b/backend/Stackingproof.v
index a76fdbba..15953131 100644
--- a/backend/Stackingproof.v
+++ b/backend/Stackingproof.v
@@ -16,11 +16,13 @@
Require Import Coqlib Errors.
Require Import Integers AST Linking.
-Require Import Values Memory Events Globalenvs Smallstep.
+Require Import Values Memory Separation Events Globalenvs Smallstep.
Require Import LTL Op Locations Linear Mach.
Require Import Bounds Conventions Stacklayout Lineartyping.
Require Import Stacking.
+Local Open Scope sep_scope.
+
Definition match_prog (p: Linear.program) (tp: Mach.program) :=
match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp.
@@ -30,7 +32,7 @@ Proof.
intros. eapply match_transform_partial_program; eauto.
Qed.
-(** * Properties of frame offsets *)
+(** * Basic properties of the translation *)
Lemma typesize_typesize:
forall ty, AST.typesize ty = 4 * Locations.typesize ty.
@@ -44,6 +46,30 @@ Proof.
destruct ty; reflexivity.
Qed.
+Remark align_type_chunk:
+ forall ty, align_chunk (chunk_of_type ty) = 4 * Locations.typealign ty.
+Proof.
+ destruct ty; reflexivity.
+Qed.
+
+Lemma slot_outgoing_argument_valid:
+ forall f ofs ty sg,
+ In (S Outgoing ofs ty) (loc_arguments sg) -> slot_valid f Outgoing ofs ty = true.
+Proof.
+ intros. exploit loc_arguments_acceptable; eauto. intros [A B].
+ unfold slot_valid. unfold proj_sumbool.
+ rewrite zle_true by omega.
+ rewrite pred_dec_true by auto.
+ auto.
+Qed.
+
+Lemma load_result_inject:
+ forall j ty v v',
+ Val.inject j v v' -> Val.has_type v ty -> Val.inject j v (Val.load_result (chunk_of_type ty) v').
+Proof.
+ destruct 1; intros; auto; destruct ty; simpl; try contradiction; econstructor; eauto.
+Qed.
+
Section PRESERVATION.
Variable return_address_offset: Mach.function -> Mach.code -> int -> Prop.
@@ -108,486 +134,417 @@ Proof.
unfold b, function_bounds, bound_stack_data. apply Zmax1.
Qed.
-(** A frame index is valid if it lies within the resource bounds
- of the current function. *)
-
-Definition index_valid (idx: frame_index) :=
- match idx with
- | FI_link => True
- | FI_retaddr => True
- | FI_local x ty => ty <> Tlong /\ 0 <= x /\ x + typesize ty <= b.(bound_local)
- | FI_arg x ty => ty <> Tlong /\ 0 <= x /\ x + typesize ty <= b.(bound_outgoing)
- | FI_saved_int x => 0 <= x < b.(bound_int_callee_save)
- | FI_saved_float x => 0 <= x < b.(bound_float_callee_save)
- end.
-
-Definition type_of_index (idx: frame_index) :=
- match idx with
- | FI_link => Tint
- | FI_retaddr => Tint
- | FI_local x ty => ty
- | FI_arg x ty => ty
- | FI_saved_int x => Tany32
- | FI_saved_float x => Tany64
- end.
-
-(** Non-overlap between the memory areas corresponding to two
- frame indices. *)
-
-Definition index_diff (idx1 idx2: frame_index) : Prop :=
- match idx1, idx2 with
- | FI_link, FI_link => False
- | FI_retaddr, FI_retaddr => False
- | FI_local x1 ty1, FI_local x2 ty2 =>
- x1 + typesize ty1 <= x2 \/ x2 + typesize ty2 <= x1
- | FI_arg x1 ty1, FI_arg x2 ty2 =>
- x1 + typesize ty1 <= x2 \/ x2 + typesize ty2 <= x1
- | FI_saved_int x1, FI_saved_int x2 => x1 <> x2
- | FI_saved_float x1, FI_saved_float x2 => x1 <> x2
- | _, _ => True
- end.
-
-Lemma index_diff_sym:
- forall idx1 idx2, index_diff idx1 idx2 -> index_diff idx2 idx1.
-Proof.
- unfold index_diff; intros.
- destruct idx1; destruct idx2; intuition.
-Qed.
-
-Ltac AddPosProps :=
- generalize (bound_local_pos b); intro;
- generalize (bound_int_callee_save_pos b); intro;
- generalize (bound_float_callee_save_pos b); intro;
- generalize (bound_outgoing_pos b); intro;
- generalize (bound_stack_data_pos b); intro.
-
-Lemma size_pos: 0 <= fe.(fe_size).
-Proof.
- generalize (frame_env_separated b). intuition.
- AddPosProps.
- unfold fe. omega.
-Qed.
-
-Opaque function_bounds.
-
-Ltac InvIndexValid :=
- match goal with
- | [ H: ?ty <> Tlong /\ _ |- _ ] =>
- destruct H; generalize (typesize_pos ty) (typesize_typesize ty); intros
- end.
-
-Lemma offset_of_index_disj:
- forall idx1 idx2,
- index_valid idx1 -> index_valid idx2 ->
- index_diff idx1 idx2 ->
- offset_of_index fe idx1 + AST.typesize (type_of_index idx1) <= offset_of_index fe idx2 \/
- offset_of_index fe idx2 + AST.typesize (type_of_index idx2) <= offset_of_index fe idx1.
-Proof.
- intros idx1 idx2 V1 V2 DIFF.
- generalize (frame_env_separated b). intuition. fold fe in H.
- AddPosProps.
- destruct idx1; destruct idx2;
- simpl in V1; simpl in V2; repeat InvIndexValid; simpl in DIFF;
- unfold offset_of_index, type_of_index;
- change (AST.typesize Tany32) with 4; change (AST.typesize Tany64) with 8;
- change (AST.typesize Tint) with 4;
- omega.
-Qed.
-
-Lemma offset_of_index_disj_stack_data_1:
- forall idx,
- index_valid idx ->
- offset_of_index fe idx + AST.typesize (type_of_index idx) <= fe.(fe_stack_data)
- \/ fe.(fe_stack_data) + b.(bound_stack_data) <= offset_of_index fe idx.
-Proof.
- intros idx V.
- generalize (frame_env_separated b). intuition. fold fe in H.
- AddPosProps.
- destruct idx;
- simpl in V; repeat InvIndexValid;
- unfold offset_of_index, type_of_index;
- change (AST.typesize Tany32) with 4; change (AST.typesize Tany64) with 8;
- change (AST.typesize Tint) with 4;
- omega.
-Qed.
-
-Lemma offset_of_index_disj_stack_data_2:
- forall idx,
- index_valid idx ->
- offset_of_index fe idx + AST.typesize (type_of_index idx) <= fe.(fe_stack_data)
- \/ fe.(fe_stack_data) + f.(Linear.fn_stacksize) <= offset_of_index fe idx.
-Proof.
- intros.
- exploit offset_of_index_disj_stack_data_1; eauto.
- generalize bound_stack_data_stacksize.
- omega.
-Qed.
-
-(** Alignment properties *)
-
-Remark aligned_4_4x: forall x, (4 | 4 * x).
-Proof. intro. exists x; ring. Qed.
-
-Remark aligned_4_8x: forall x, (4 | 8 * x).
-Proof. intro. exists (x * 2); ring. Qed.
+(** * Memory assertions used to describe the contents of stack frames *)
-Remark aligned_8_4:
- forall x, (8 | x) -> (4 | x).
-Proof. intros. apply Zdivides_trans with 8; auto. exists 2; auto. Qed.
+Local Opaque Z.add Z.mul Z.divide.
-Hint Resolve Zdivide_0 Zdivide_refl Zdivide_plus_r
- aligned_4_4x aligned_4_8x aligned_8_4: align_4.
-Hint Extern 4 (?X | ?Y) => (exists (Y/X); reflexivity) : align_4.
+(** Accessing the stack frame using [load_stack] and [store_stack]. *)
-Lemma offset_of_index_aligned:
- forall idx, (4 | offset_of_index fe idx).
+Lemma contains_get_stack:
+ forall spec m ty sp ofs,
+ m |= contains (chunk_of_type ty) sp ofs spec ->
+ exists v, load_stack m (Vptr sp Int.zero) ty (Int.repr ofs) = Some v /\ spec v.
Proof.
- intros.
- generalize (frame_env_aligned b). intuition. fold fe in H. intuition.
- destruct idx; try (destruct t);
- unfold offset_of_index, type_of_index, AST.typesize;
- auto with align_4.
+ intros. unfold load_stack.
+ replace (Val.add (Vptr sp Int.zero) (Vint (Int.repr ofs))) with (Vptr sp (Int.repr ofs)).
+ eapply loadv_rule; eauto.
+ simpl. rewrite Int.add_zero_l; auto.
Qed.
-Lemma offset_of_index_aligned_2:
- forall idx, index_valid idx ->
- (align_chunk (chunk_of_type (type_of_index idx)) | offset_of_index fe idx).
+Lemma hasvalue_get_stack:
+ forall ty m sp ofs v,
+ m |= hasvalue (chunk_of_type ty) sp ofs v ->
+ load_stack m (Vptr sp Int.zero) ty (Int.repr ofs) = Some v.
Proof.
- intros. replace (align_chunk (chunk_of_type (type_of_index idx))) with 4.
- apply offset_of_index_aligned.
- assert (type_of_index idx <> Tlong) by
- (destruct idx; simpl; simpl in H; intuition congruence).
- destruct (type_of_index idx); auto; congruence.
+ intros. exploit contains_get_stack; eauto. intros (v' & A & B). congruence.
Qed.
-Lemma fe_stack_data_aligned:
- (8 | fe_stack_data fe).
-Proof.
- intros.
- generalize (frame_env_aligned b). intuition. fold fe in H. intuition.
+Lemma contains_set_stack:
+ forall (spec: val -> Prop) v spec1 m ty sp ofs P,
+ m |= contains (chunk_of_type ty) sp ofs spec1 ** P ->
+ spec (Val.load_result (chunk_of_type ty) v) ->
+ exists m',
+ store_stack m (Vptr sp Int.zero) ty (Int.repr ofs) v = Some m'
+ /\ m' |= contains (chunk_of_type ty) sp ofs spec ** P.
+Proof.
+ intros. unfold store_stack.
+ replace (Val.add (Vptr sp Int.zero) (Vint (Int.repr ofs))) with (Vptr sp (Int.repr ofs)).
+ eapply storev_rule; eauto.
+ simpl. rewrite Int.add_zero_l; auto.
+Qed.
+
+(** [contains_locations j sp pos bound sl ls] is a separation logic assertion
+ that holds if the memory area at block [sp], offset [pos], size [4 * bound],
+ reflects the values of the stack locations of kind [sl] given by the
+ location map [ls], up to the memory injection [j].
+
+ Two such [contains_locations] assertions will be used later, one to
+ reason about the values of [Local] slots, the other about the values of
+ [Outgoing] slots. *)
+
+Program Definition contains_locations (j: meminj) (sp: block) (pos bound: Z) (sl: slot) (ls: locset) : massert := {|
+ m_pred := fun m =>
+ (8 | pos) /\ 0 <= pos /\ pos + 4 * bound <= Int.modulus /\
+ Mem.range_perm m sp pos (pos + 4 * bound) Cur Freeable /\
+ forall ofs ty, 0 <= ofs -> ofs + typesize ty <= bound -> (typealign ty | ofs) ->
+ exists v, Mem.load (chunk_of_type ty) m sp (pos + 4 * ofs) = Some v
+ /\ Val.inject j (ls (S sl ofs ty)) v;
+ m_footprint := fun b ofs =>
+ b = sp /\ pos <= ofs < pos + 4 * bound
+|}.
+Next Obligation.
+ intuition auto.
+- red; intros. eapply Mem.perm_unchanged_on; eauto. simpl; auto.
+- exploit H4; eauto. intros (v & A & B). exists v; split; auto.
+ eapply Mem.load_unchanged_on; eauto.
+ simpl; intros. rewrite size_type_chunk, typesize_typesize in H8.
+ split; auto. omega.
+Qed.
+Next Obligation.
+ eauto with mem.
Qed.
-(** The following lemmas give sufficient conditions for indices
- of various kinds to be valid. *)
+Remark valid_access_location:
+ forall m sp pos bound ofs ty p,
+ (8 | pos) ->
+ Mem.range_perm m sp pos (pos + 4 * bound) Cur Freeable ->
+ 0 <= ofs -> ofs + typesize ty <= bound -> (typealign ty | ofs) ->
+ Mem.valid_access m (chunk_of_type ty) sp (pos + 4 * ofs) p.
+Proof.
+ intros; split.
+- red; intros. apply Mem.perm_implies with Freeable; auto with mem.
+ apply H0. rewrite size_type_chunk, typesize_typesize in H4. omega.
+- rewrite align_type_chunk. apply Z.divide_add_r.
+ apply Zdivide_trans with 8; auto.
+ exists (8 / (4 * typealign ty)); destruct ty; reflexivity.
+ apply Z.mul_divide_mono_l. auto.
+Qed.
+
+Lemma get_location:
+ forall m j sp pos bound sl ls ofs ty,
+ m |= contains_locations j sp pos bound sl ls ->
+ 0 <= ofs -> ofs + typesize ty <= bound -> (typealign ty | ofs) ->
+ exists v,
+ load_stack m (Vptr sp Int.zero) ty (Int.repr (pos + 4 * ofs)) = Some v
+ /\ Val.inject j (ls (S sl ofs ty)) v.
+Proof.
+ intros. destruct H as (D & E & F & G & H).
+ exploit H; eauto. intros (v & U & V). exists v; split; auto.
+ unfold load_stack; simpl. rewrite Int.add_zero_l, Int.unsigned_repr; auto.
+ unfold Int.max_unsigned. generalize (typesize_pos ty). omega.
+Qed.
+
+Lemma set_location:
+ forall m j sp pos bound sl ls P ofs ty v v',
+ m |= contains_locations j sp pos bound sl ls ** P ->
+ 0 <= ofs -> ofs + typesize ty <= bound -> (typealign ty | ofs) ->
+ Val.inject j v v' ->
+ exists m',
+ store_stack m (Vptr sp Int.zero) ty (Int.repr (pos + 4 * ofs)) v' = Some m'
+ /\ m' |= contains_locations j sp pos bound sl (Locmap.set (S sl ofs ty) v ls) ** P.
+Proof.
+ intros. destruct H as (A & B & C). destruct A as (D & E & F & G & H).
+ edestruct Mem.valid_access_store as [m' STORE].
+ eapply valid_access_location; eauto.
+ assert (PERM: Mem.range_perm m' sp pos (pos + 4 * bound) Cur Freeable).
+ { red; intros; eauto with mem. }
+ exists m'; split.
+- unfold store_stack; simpl. rewrite Int.add_zero_l, Int.unsigned_repr; eauto.
+ unfold Int.max_unsigned. generalize (typesize_pos ty). omega.
+- simpl. intuition auto.
++ unfold Locmap.set.
+ destruct (Loc.eq (S sl ofs ty) (S sl ofs0 ty0)); [|destruct (Loc.diff_dec (S sl ofs ty) (S sl ofs0 ty0))].
+* (* same location *)
+ inv e. rename ofs0 into ofs. rename ty0 into ty.
+ exists (Val.load_result (chunk_of_type ty) v'); split.
+ eapply Mem.load_store_similar_2; eauto. omega.
+ inv H3; destruct (chunk_of_type ty); simpl; econstructor; eauto.
+* (* different locations *)
+ exploit H; eauto. intros (v0 & X & Y). exists v0; split; auto.
+ rewrite <- X; eapply Mem.load_store_other; eauto.
+ destruct d. congruence. right. rewrite ! size_type_chunk, ! typesize_typesize. omega.
+* (* overlapping locations *)
+ destruct (Mem.valid_access_load m' (chunk_of_type ty0) sp (pos + 4 * ofs0)) as [v'' LOAD].
+ apply Mem.valid_access_implies with Writable; auto with mem.
+ eapply valid_access_location; eauto.
+ exists v''; auto.
++ apply (m_invar P) with m; auto.
+ eapply Mem.store_unchanged_on; eauto.
+ intros i; rewrite size_type_chunk, typesize_typesize. intros; red; intros.
+ eelim C; eauto. simpl. split; auto. omega.
+Qed.
+
+Lemma initial_locations:
+ forall j sp pos bound P sl ls m,
+ m |= range sp pos (pos + 4 * bound) ** P ->
+ (8 | pos) ->
+ (forall ofs ty, ls (S sl ofs ty) = Vundef) ->
+ m |= contains_locations j sp pos bound sl ls ** P.
+Proof.
+ intros. destruct H as (A & B & C). destruct A as (D & E & F). split.
+- simpl; intuition auto. red; intros; eauto with mem.
+ destruct (Mem.valid_access_load m (chunk_of_type ty) sp (pos + 4 * ofs)) as [v LOAD].
+ eapply valid_access_location; eauto.
+ red; intros; eauto with mem.
+ exists v; split; auto. rewrite H1; auto.
+- split; assumption.
+Qed.
+
+Lemma contains_locations_exten:
+ forall ls ls' j sp pos bound sl,
+ (forall ofs ty, ls' (S sl ofs ty) = ls (S sl ofs ty)) ->
+ massert_imp (contains_locations j sp pos bound sl ls)
+ (contains_locations j sp pos bound sl ls').
+Proof.
+ intros; split; simpl; intros; auto.
+ intuition auto. rewrite H. eauto.
+Qed.
+
+Lemma contains_locations_incr:
+ forall j j' sp pos bound sl ls,
+ inject_incr j j' ->
+ massert_imp (contains_locations j sp pos bound sl ls)
+ (contains_locations j' sp pos bound sl ls).
+Proof.
+ intros; split; simpl; intros; auto.
+ intuition auto. exploit H5; eauto. intros (v & A & B). exists v; eauto.
+Qed.
+
+(** [contains_callee_saves j sp pos rl ls] is a memory assertion that holds
+ if block [sp], starting at offset [pos], contains the values of the
+ callee-save registers [rl] as given by the location map [ls],
+ up to the memory injection [j]. The memory layout of the registers in [rl]
+ is the same as that implemented by [save_callee_save_rec]. *)
+
+Fixpoint contains_callee_saves (j: meminj) (sp: block) (pos: Z) (rl: list mreg) (ls: locset) : massert :=
+ match rl with
+ | nil => pure True
+ | r :: rl =>
+ let ty := mreg_type r in
+ let sz := AST.typesize ty in
+ let pos1 := align pos sz in
+ contains (chunk_of_type ty) sp pos1 (fun v => Val.inject j (ls (R r)) v)
+ ** contains_callee_saves j sp (pos1 + sz) rl ls
+ end.
-Lemma index_local_valid:
- forall ofs ty,
+Lemma contains_callee_saves_incr:
+ forall j j' sp ls,
+ inject_incr j j' ->
+ forall rl pos,
+ massert_imp (contains_callee_saves j sp pos rl ls)
+ (contains_callee_saves j' sp pos rl ls).
+Proof.
+ induction rl as [ | r1 rl]; simpl; intros.
+- reflexivity.
+- apply sepconj_morph_1; auto. apply contains_imp. eauto.
+Qed.
+
+Lemma contains_callee_saves_exten:
+ forall j sp ls ls' rl pos,
+ (forall r, In r rl -> ls' (R r) = ls (R r)) ->
+ massert_eqv (contains_callee_saves j sp pos rl ls)
+ (contains_callee_saves j sp pos rl ls').
+Proof.
+ induction rl as [ | r1 rl]; simpl; intros.
+- reflexivity.
+- apply sepconj_morph_2; auto. rewrite H by auto. reflexivity.
+Qed.
+
+(** Separation logic assertions describing the stack frame at [sp].
+ It must contain:
+ - the values of the [Local] stack slots of [ls], as per [contains_locations]
+ - the values of the [Outgoing] stack slots of [ls], as per [contains_locations]
+ - the [parent] pointer representing the back link to the caller's frame
+ - the [retaddr] pointer representing the saved return address
+ - the initial values of the used callee-save registers as given by [ls0],
+ as per [contains_callee_saves].
+
+In addition, we use a nonseparating conjunction to record the fact that
+we have full access rights on the stack frame, except the part that
+represents the Linear stack data. *)
+
+Definition frame_contents_1 (j: meminj) (sp: block) (ls ls0: locset) (parent retaddr: val) :=
+ contains_locations j sp fe.(fe_ofs_local) b.(bound_local) Local ls
+ ** contains_locations j sp fe_ofs_arg b.(bound_outgoing) Outgoing ls
+ ** hasvalue Mint32 sp fe.(fe_ofs_link) parent
+ ** hasvalue Mint32 sp fe.(fe_ofs_retaddr) retaddr
+ ** contains_callee_saves j sp fe.(fe_ofs_callee_save) b.(used_callee_save) ls0.
+
+Definition frame_contents (j: meminj) (sp: block) (ls ls0: locset) (parent retaddr: val) :=
+ mconj (frame_contents_1 j sp ls ls0 parent retaddr)
+ (range sp 0 fe.(fe_stack_data) **
+ range sp (fe.(fe_stack_data) + b.(bound_stack_data)) fe.(fe_size)).
+
+(** Accessing components of the frame. *)
+
+Lemma frame_get_local:
+ forall ofs ty j sp ls ls0 parent retaddr m P,
+ m |= frame_contents j sp ls ls0 parent retaddr ** P ->
slot_within_bounds b Local ofs ty -> slot_valid f Local ofs ty = true ->
- index_valid (FI_local ofs ty).
+ exists v,
+ load_stack m (Vptr sp Int.zero) ty (Int.repr (offset_local fe ofs)) = Some v
+ /\ Val.inject j (ls (S Local ofs ty)) v.
Proof.
- unfold slot_within_bounds, slot_valid, index_valid; intros.
- InvBooleans.
- split. destruct ty; auto || discriminate. auto.
+ unfold frame_contents, frame_contents_1; intros. unfold slot_valid in H1; InvBooleans.
+ apply mconj_proj1 in H. apply sep_proj1 in H. apply sep_proj1 in H.
+ eapply get_location; eauto.
Qed.
-Lemma index_arg_valid:
- forall ofs ty,
+Lemma frame_get_outgoing:
+ forall ofs ty j sp ls ls0 parent retaddr m P,
+ m |= frame_contents j sp ls ls0 parent retaddr ** P ->
slot_within_bounds b Outgoing ofs ty -> slot_valid f Outgoing ofs ty = true ->
- index_valid (FI_arg ofs ty).
+ exists v,
+ load_stack m (Vptr sp Int.zero) ty (Int.repr (offset_arg ofs)) = Some v
+ /\ Val.inject j (ls (S Outgoing ofs ty)) v.
Proof.
- unfold slot_within_bounds, slot_valid, index_valid; intros.
- InvBooleans.
- split. destruct ty; auto || discriminate. auto.
+ unfold frame_contents, frame_contents_1; intros. unfold slot_valid in H1; InvBooleans.
+ apply mconj_proj1 in H. apply sep_proj1 in H. apply sep_pick2 in H.
+ eapply get_location; eauto.
Qed.
-Lemma index_saved_int_valid:
- forall r,
- In r int_callee_save_regs ->
- index_int_callee_save r < b.(bound_int_callee_save) ->
- index_valid (FI_saved_int (index_int_callee_save r)).
+Lemma frame_get_parent:
+ forall j sp ls ls0 parent retaddr m P,
+ m |= frame_contents j sp ls ls0 parent retaddr ** P ->
+ load_stack m (Vptr sp Int.zero) Tint (Int.repr fe.(fe_ofs_link)) = Some parent.
Proof.
- intros. red. split.
- apply Zge_le. apply index_int_callee_save_pos; auto.
- auto.
+ unfold frame_contents, frame_contents_1; intros.
+ apply mconj_proj1 in H. apply sep_proj1 in H. apply sep_pick3 in H.
+ eapply hasvalue_get_stack; eauto.
Qed.
-Lemma index_saved_float_valid:
- forall r,
- In r float_callee_save_regs ->
- index_float_callee_save r < b.(bound_float_callee_save) ->
- index_valid (FI_saved_float (index_float_callee_save r)).
+Lemma frame_get_retaddr:
+ forall j sp ls ls0 parent retaddr m P,
+ m |= frame_contents j sp ls ls0 parent retaddr ** P ->
+ load_stack m (Vptr sp Int.zero) Tint (Int.repr fe.(fe_ofs_retaddr)) = Some retaddr.
Proof.
- intros. red. split.
- apply Zge_le. apply index_float_callee_save_pos; auto.
- auto.
+ unfold frame_contents, frame_contents_1; intros.
+ apply mconj_proj1 in H. apply sep_proj1 in H. apply sep_pick4 in H.
+ eapply hasvalue_get_stack; eauto.
Qed.
-Hint Resolve index_local_valid index_arg_valid
- index_saved_int_valid index_saved_float_valid: stacking.
-
-(** The offset of a valid index lies within the bounds of the frame. *)
-
-Lemma offset_of_index_valid:
- forall idx,
- index_valid idx ->
- 0 <= offset_of_index fe idx /\
- offset_of_index fe idx + AST.typesize (type_of_index idx) <= fe.(fe_size).
-Proof.
- intros idx V.
- generalize (frame_env_separated b). intros [A B]. fold fe in A. fold fe in B.
- AddPosProps.
- destruct idx; simpl in V; repeat InvIndexValid;
- unfold offset_of_index, type_of_index;
- change (AST.typesize Tany32) with 4; change (AST.typesize Tany64) with 8;
- change (AST.typesize Tint) with 4;
- omega.
-Qed.
+(** Assigning a [Local] or [Outgoing] stack slot. *)
-(** The image of the Linear stack data block lies within the bounds of the frame. *)
-
-Lemma stack_data_offset_valid:
- 0 <= fe.(fe_stack_data) /\ fe.(fe_stack_data) + b.(bound_stack_data) <= fe.(fe_size).
-Proof.
- generalize (frame_env_separated b). intros [A B]. fold fe in A. fold fe in B.
- AddPosProps.
- omega.
-Qed.
-
-(** Offsets for valid index are representable as signed machine integers
- without loss of precision. *)
-
-Lemma offset_of_index_no_overflow:
- forall idx,
- index_valid idx ->
- Int.unsigned (Int.repr (offset_of_index fe idx)) = offset_of_index fe idx.
-Proof.
- intros.
- generalize (offset_of_index_valid idx H). intros [A B].
- apply Int.unsigned_repr.
- generalize (AST.typesize_pos (type_of_index idx)).
- generalize size_no_overflow.
- omega.
-Qed.
-
-(** Likewise, for offsets within the Linear stack slot, after shifting. *)
-
-Lemma shifted_stack_offset_no_overflow:
- forall ofs,
- 0 <= Int.unsigned ofs < Linear.fn_stacksize f ->
- Int.unsigned (Int.add ofs (Int.repr fe.(fe_stack_data)))
- = Int.unsigned ofs + fe.(fe_stack_data).
-Proof.
- intros. unfold Int.add.
- generalize size_no_overflow stack_data_offset_valid bound_stack_data_stacksize; intros.
- AddPosProps.
- replace (Int.unsigned (Int.repr (fe_stack_data fe))) with (fe_stack_data fe).
- apply Int.unsigned_repr. omega.
- symmetry. apply Int.unsigned_repr. omega.
-Qed.
-
-(** * Contents of frame slots *)
-
-Inductive index_contains (m: mem) (sp: block) (idx: frame_index) (v: val) : Prop :=
- | index_contains_intro:
- index_valid idx ->
- Mem.load (chunk_of_type (type_of_index idx)) m sp (offset_of_index fe idx) = Some v ->
- index_contains m sp idx v.
-
-Lemma index_contains_load_stack:
- forall m sp idx v,
- index_contains m sp idx v ->
- load_stack m (Vptr sp Int.zero) (type_of_index idx)
- (Int.repr (offset_of_index fe idx)) = Some v.
+Lemma frame_set_local:
+ forall ofs ty v v' j sp ls ls0 parent retaddr m P,
+ m |= frame_contents j sp ls ls0 parent retaddr ** P ->
+ slot_within_bounds b Local ofs ty -> slot_valid f Local ofs ty = true ->
+ Val.inject j v v' ->
+ exists m',
+ store_stack m (Vptr sp Int.zero) ty (Int.repr (offset_local fe ofs)) v' = Some m'
+ /\ m' |= frame_contents j sp (Locmap.set (S Local ofs ty) v ls) ls0 parent retaddr ** P.
+Proof.
+ intros. unfold frame_contents in H.
+ exploit mconj_proj1; eauto. unfold frame_contents_1.
+ rewrite ! sep_assoc; intros SEP.
+ unfold slot_valid in H1; InvBooleans. simpl in H0.
+ exploit set_location; eauto. intros (m' & A & B).
+ exists m'; split; auto.
+ assert (forall i k p, Mem.perm m sp i k p -> Mem.perm m' sp i k p).
+ { intros. unfold store_stack in A; simpl in A. eapply Mem.perm_store_1; eauto. }
+ eapply frame_mconj. eauto.
+ unfold frame_contents_1; rewrite ! sep_assoc; exact B.
+ eapply sep_preserved.
+ eapply sep_proj1. eapply mconj_proj2. eassumption.
+ intros; eapply range_preserved; eauto.
+ intros; eapply range_preserved; eauto.
+Qed.
+
+Lemma frame_set_outgoing:
+ forall ofs ty v v' j sp ls ls0 parent retaddr m P,
+ m |= frame_contents j sp ls ls0 parent retaddr ** P ->
+ slot_within_bounds b Outgoing ofs ty -> slot_valid f Outgoing ofs ty = true ->
+ Val.inject j v v' ->
+ exists m',
+ store_stack m (Vptr sp Int.zero) ty (Int.repr (offset_arg ofs)) v' = Some m'
+ /\ m' |= frame_contents j sp (Locmap.set (S Outgoing ofs ty) v ls) ls0 parent retaddr ** P.
Proof.
- intros. inv H.
- unfold load_stack, Mem.loadv, Val.add. rewrite Int.add_commut. rewrite Int.add_zero.
- rewrite offset_of_index_no_overflow; auto.
+ intros. unfold frame_contents in H.
+ exploit mconj_proj1; eauto. unfold frame_contents_1.
+ rewrite ! sep_assoc, sep_swap. intros SEP.
+ unfold slot_valid in H1; InvBooleans. simpl in H0.
+ exploit set_location; eauto. intros (m' & A & B).
+ exists m'; split; auto.
+ assert (forall i k p, Mem.perm m sp i k p -> Mem.perm m' sp i k p).
+ { intros. unfold store_stack in A; simpl in A. eapply Mem.perm_store_1; eauto. }
+ eapply frame_mconj. eauto.
+ unfold frame_contents_1; rewrite ! sep_assoc, sep_swap; eauto.
+ eapply sep_preserved.
+ eapply sep_proj1. eapply mconj_proj2. eassumption.
+ intros; eapply range_preserved; eauto.
+ intros; eapply range_preserved; eauto.
Qed.
-(** Good variable properties for [index_contains] *)
+(** Invariance by change of location maps. *)
-Lemma gss_index_contains_base:
- forall idx m m' sp v,
- Mem.store (chunk_of_type (type_of_index idx)) m sp (offset_of_index fe idx) v = Some m' ->
- index_valid idx ->
- exists v',
- index_contains m' sp idx v'
- /\ decode_encode_val v (chunk_of_type (type_of_index idx)) (chunk_of_type (type_of_index idx)) v'.
-Proof.
- intros.
- exploit Mem.load_store_similar. eauto. reflexivity. omega.
- intros [v' [A B]].
- exists v'; split; auto. constructor; auto.
-Qed.
-
-Lemma gss_index_contains:
- forall idx m m' sp v,
- Mem.store (chunk_of_type (type_of_index idx)) m sp (offset_of_index fe idx) v = Some m' ->
- index_valid idx ->
- Val.has_type v (type_of_index idx) ->
- index_contains m' sp idx v.
-Proof.
- intros. exploit gss_index_contains_base; eauto. intros [v' [A B]].
- assert (v' = v).
- destruct v; destruct (type_of_index idx); simpl in *;
- try contradiction; auto.
- subst v'. auto.
-Qed.
-
-Lemma gso_index_contains:
- forall idx m m' sp v idx' v',
- Mem.store (chunk_of_type (type_of_index idx)) m sp (offset_of_index fe idx) v = Some m' ->
- index_valid idx ->
- index_contains m sp idx' v' ->
- index_diff idx idx' ->
- index_contains m' sp idx' v'.
-Proof.
- intros. inv H1. constructor; auto.
- rewrite <- H4. eapply Mem.load_store_other; eauto.
- right. repeat rewrite size_type_chunk.
- apply offset_of_index_disj; auto. apply index_diff_sym; auto.
-Qed.
-
-Lemma store_other_index_contains:
- forall chunk m blk ofs v' m' sp idx v,
- Mem.store chunk m blk ofs v' = Some m' ->
- blk <> sp \/
- (fe.(fe_stack_data) <= ofs /\ ofs + size_chunk chunk <= fe.(fe_stack_data) + f.(Linear.fn_stacksize)) ->
- index_contains m sp idx v ->
- index_contains m' sp idx v.
-Proof.
- intros. inv H1. constructor; auto. rewrite <- H3.
- eapply Mem.load_store_other; eauto.
- destruct H0. auto. right.
- exploit offset_of_index_disj_stack_data_2; eauto. intros.
- rewrite size_type_chunk.
- omega.
-Qed.
-
-Definition frame_perm_freeable (m: mem) (sp: block): Prop :=
- forall ofs,
- 0 <= ofs < fe.(fe_size) ->
- ofs < fe.(fe_stack_data) \/ fe.(fe_stack_data) + f.(Linear.fn_stacksize) <= ofs ->
- Mem.perm m sp ofs Cur Freeable.
-
-Lemma offset_of_index_perm:
- forall m sp idx,
- index_valid idx ->
- frame_perm_freeable m sp ->
- Mem.range_perm m sp (offset_of_index fe idx) (offset_of_index fe idx + AST.typesize (type_of_index idx)) Cur Freeable.
+Lemma frame_contents_exten:
+ forall ls ls0 ls' ls0' j sp parent retaddr P m,
+ (forall sl ofs ty, ls' (S sl ofs ty) = ls (S sl ofs ty)) ->
+ (forall r, In r b.(used_callee_save) -> ls0' (R r) = ls0 (R r)) ->
+ m |= frame_contents j sp ls ls0 parent retaddr ** P ->
+ m |= frame_contents j sp ls' ls0' parent retaddr ** P.
Proof.
- intros.
- exploit offset_of_index_valid; eauto. intros [A B].
- exploit offset_of_index_disj_stack_data_2; eauto. intros.
- red; intros. apply H0. omega. omega.
+ unfold frame_contents, frame_contents_1; intros.
+ rewrite <- ! (contains_locations_exten ls ls') by auto.
+ erewrite <- contains_callee_saves_exten by eauto.
+ assumption.
Qed.
-Lemma store_index_succeeds:
- forall m sp idx v,
- index_valid idx ->
- frame_perm_freeable m sp ->
- exists m',
- Mem.store (chunk_of_type (type_of_index idx)) m sp (offset_of_index fe idx) v = Some m'.
-Proof.
- intros.
- destruct (Mem.valid_access_store m (chunk_of_type (type_of_index idx)) sp (offset_of_index fe idx) v) as [m' ST].
- constructor.
- rewrite size_type_chunk.
- apply Mem.range_perm_implies with Freeable; auto with mem.
- apply offset_of_index_perm; auto.
- apply offset_of_index_aligned_2; auto.
- exists m'; auto.
-Qed.
+(** Invariance by assignment to registers. *)
-Lemma store_stack_succeeds:
- forall m sp idx v m',
- index_valid idx ->
- Mem.store (chunk_of_type (type_of_index idx)) m sp (offset_of_index fe idx) v = Some m' ->
- store_stack m (Vptr sp Int.zero) (type_of_index idx) (Int.repr (offset_of_index fe idx)) v = Some m'.
+Corollary frame_set_reg:
+ forall r v j sp ls ls0 parent retaddr m P,
+ m |= frame_contents j sp ls ls0 parent retaddr ** P ->
+ m |= frame_contents j sp (Locmap.set (R r) v ls) ls0 parent retaddr ** P.
Proof.
- intros. unfold store_stack, Mem.storev, Val.add.
- rewrite Int.add_commut. rewrite Int.add_zero.
- rewrite offset_of_index_no_overflow; auto.
+ intros. apply frame_contents_exten with ls ls0; auto.
Qed.
-(** A variant of [index_contains], up to a memory injection. *)
-
-Definition index_contains_inj (j: meminj) (m: mem) (sp: block) (idx: frame_index) (v: val) : Prop :=
- exists v', index_contains m sp idx v' /\ Val.inject j v v'.
-
-Lemma gss_index_contains_inj:
- forall j idx m m' sp v v',
- Mem.store (chunk_of_type (type_of_index idx)) m sp (offset_of_index fe idx) v' = Some m' ->
- index_valid idx ->
- Val.has_type v (type_of_index idx) ->
- Val.inject j v v' ->
- index_contains_inj j m' sp idx v.
+Corollary frame_undef_regs:
+ forall j sp ls ls0 parent retaddr m P rl,
+ m |= frame_contents j sp ls ls0 parent retaddr ** P ->
+ m |= frame_contents j sp (LTL.undef_regs rl ls) ls0 parent retaddr ** P.
Proof.
- intros. exploit gss_index_contains_base; eauto. intros [v'' [A B]].
- exists v''; split; auto.
- inv H2; destruct (type_of_index idx); simpl in *; try contradiction; subst; auto.
- econstructor; eauto.
- econstructor; eauto.
- econstructor; eauto.
+Local Opaque sepconj.
+ induction rl; simpl; intros.
+- auto.
+- apply frame_set_reg; auto.
Qed.
-Lemma gss_index_contains_inj':
- forall j idx m m' sp v v',
- Mem.store (chunk_of_type (type_of_index idx)) m sp (offset_of_index fe idx) v' = Some m' ->
- index_valid idx ->
- Val.inject j v v' ->
- index_contains_inj j m' sp idx (Val.load_result (chunk_of_type (type_of_index idx)) v).
+Corollary frame_set_regs:
+ forall j sp ls0 parent retaddr m P rl vl ls,
+ m |= frame_contents j sp ls ls0 parent retaddr ** P ->
+ m |= frame_contents j sp (Locmap.setlist (map R rl) vl ls) ls0 parent retaddr ** P.
Proof.
- intros. exploit gss_index_contains_base; eauto. intros [v'' [A B]].
- exists v''; split; auto.
- inv H1; destruct (type_of_index idx); simpl in *; try contradiction; subst; auto.
- econstructor; eauto.
- econstructor; eauto.
- econstructor; eauto.
+ induction rl; destruct vl; simpl; intros; trivial. apply IHrl. apply frame_set_reg; auto.
Qed.
-Lemma gso_index_contains_inj:
- forall j idx m m' sp v idx' v',
- Mem.store (chunk_of_type (type_of_index idx)) m sp (offset_of_index fe idx) v = Some m' ->
- index_valid idx ->
- index_contains_inj j m sp idx' v' ->
- index_diff idx idx' ->
- index_contains_inj j m' sp idx' v'.
+Corollary frame_set_res:
+ forall j sp ls0 parent retaddr m P res v ls,
+ m |= frame_contents j sp ls ls0 parent retaddr ** P ->
+ m |= frame_contents j sp (Locmap.setres res v ls) ls0 parent retaddr ** P.
Proof.
- intros. destruct H1 as [v'' [A B]]. exists v''; split; auto.
- eapply gso_index_contains; eauto.
+ induction res; simpl; intros.
+- apply frame_set_reg; auto.
+- auto.
+- eauto.
Qed.
-Lemma store_other_index_contains_inj:
- forall j chunk m b ofs v' m' sp idx v,
- Mem.store chunk m b ofs v' = Some m' ->
- b <> sp \/
- (fe.(fe_stack_data) <= ofs /\ ofs + size_chunk chunk <= fe.(fe_stack_data) + f.(Linear.fn_stacksize)) ->
- index_contains_inj j m sp idx v ->
- index_contains_inj j m' sp idx v.
-Proof.
- intros. destruct H1 as [v'' [A B]]. exists v''; split; auto.
- eapply store_other_index_contains; eauto.
-Qed.
+(** Invariance by change of memory injection. *)
-Lemma index_contains_inj_incr:
- forall j m sp idx v j',
- index_contains_inj j m sp idx v ->
+Lemma frame_contents_incr:
+ forall j sp ls ls0 parent retaddr m P j',
+ m |= frame_contents j sp ls ls0 parent retaddr ** P ->
inject_incr j j' ->
- index_contains_inj j' m sp idx v.
-Proof.
- intros. destruct H as [v'' [A B]]. exists v''; split; auto. eauto.
-Qed.
-
-Lemma index_contains_inj_undef:
- forall j m sp idx,
- index_valid idx ->
- frame_perm_freeable m sp ->
- index_contains_inj j m sp idx Vundef.
+ m |= frame_contents j' sp ls ls0 parent retaddr ** P.
Proof.
- intros.
- exploit (Mem.valid_access_load m (chunk_of_type (type_of_index idx)) sp (offset_of_index fe idx)).
- constructor.
- rewrite size_type_chunk.
- apply Mem.range_perm_implies with Freeable; auto with mem.
- apply offset_of_index_perm; auto.
- apply offset_of_index_aligned_2; auto.
- intros [v C].
- exists v; split; auto. constructor; auto.
+ unfold frame_contents, frame_contents_1; intros.
+ rewrite <- (contains_locations_incr j j') by auto.
+ rewrite <- (contains_locations_incr j j') by auto.
+ erewrite <- contains_callee_saves_incr by eauto.
+ assumption.
Qed.
-Hint Resolve store_other_index_contains_inj index_contains_inj_incr: stacking.
-
(** * Agreement between location sets and Mach states *)
(** Agreement with Mach register states *)
@@ -595,89 +552,29 @@ Hint Resolve store_other_index_contains_inj index_contains_inj_incr: stacking.
Definition agree_regs (j: meminj) (ls: locset) (rs: regset) : Prop :=
forall r, Val.inject j (ls (R r)) (rs r).
-(** Agreement over data stored in memory *)
+(** Agreement over locations *)
-Record agree_frame (j: meminj) (ls ls0: locset)
- (m: mem) (sp: block)
- (m': mem) (sp': block)
- (parent retaddr: val) : Prop :=
- mk_agree_frame {
+Record agree_locs (ls ls0: locset) : Prop :=
+ mk_agree_locs {
(** Unused registers have the same value as in the caller *)
agree_unused_reg:
forall r, ~(mreg_within_bounds b r) -> ls (R r) = ls0 (R r);
- (** Local and outgoing stack slots (on the Linear side) have
- the same values as the one loaded from the current Mach frame
- at the corresponding offsets. *)
- agree_locals:
- forall ofs ty,
- slot_within_bounds b Local ofs ty -> slot_valid f Local ofs ty = true ->
- index_contains_inj j m' sp' (FI_local ofs ty) (ls (S Local ofs ty));
- agree_outgoing:
- forall ofs ty,
- slot_within_bounds b Outgoing ofs ty -> slot_valid f Outgoing ofs ty = true ->
- index_contains_inj j m' sp' (FI_arg ofs ty) (ls (S Outgoing ofs ty));
-
(** Incoming stack slots have the same value as the
corresponding Outgoing stack slots in the caller *)
agree_incoming:
forall ofs ty,
In (S Incoming ofs ty) (loc_parameters f.(Linear.fn_sig)) ->
- ls (S Incoming ofs ty) = ls0 (S Outgoing ofs ty);
-
- (** The back link and return address slots of the Mach frame contain
- the [parent] and [retaddr] values, respectively. *)
- agree_link:
- index_contains m' sp' FI_link parent;
- agree_retaddr:
- index_contains m' sp' FI_retaddr retaddr;
-
- (** The areas of the frame reserved for saving used callee-save
- registers always contain the values that those registers had
- in the caller. *)
- agree_saved_int:
- forall r,
- In r int_callee_save_regs ->
- index_int_callee_save r < b.(bound_int_callee_save) ->
- index_contains_inj j m' sp' (FI_saved_int (index_int_callee_save r)) (ls0 (R r));
- agree_saved_float:
- forall r,
- In r float_callee_save_regs ->
- index_float_callee_save r < b.(bound_float_callee_save) ->
- index_contains_inj j m' sp' (FI_saved_float (index_float_callee_save r)) (ls0 (R r));
-
- (** Mapping between the Linear stack pointer and the Mach stack pointer *)
- agree_inj:
- j sp = Some(sp', fe.(fe_stack_data));
- agree_inj_unique:
- forall b delta, j b = Some(sp', delta) -> b = sp /\ delta = fe.(fe_stack_data);
-
- (** The Linear and Mach stack pointers are valid *)
- agree_valid_linear:
- Mem.valid_block m sp;
- agree_valid_mach:
- Mem.valid_block m' sp';
-
- (** Bounds of the Linear stack data block *)
- agree_bounds:
- forall ofs p, Mem.perm m sp ofs Max p -> 0 <= ofs < f.(Linear.fn_stacksize);
-
- (** Permissions on the frame part of the Mach stack block *)
- agree_perm:
- frame_perm_freeable m' sp'
- }.
-
-Hint Resolve agree_unused_reg agree_locals agree_outgoing agree_incoming
- agree_link agree_retaddr agree_saved_int agree_saved_float
- agree_valid_linear agree_valid_mach agree_perm: stacking.
+ ls (S Incoming ofs ty) = ls0 (S Outgoing ofs ty)
+}.
(** Auxiliary predicate used at call points *)
Definition agree_callee_save (ls ls0: locset) : Prop :=
forall l,
match l with
- | R r => ~In r destroyed_at_call
+ | R r => is_callee_save r = true
| S _ _ _ => True
end ->
ls l = ls0 l.
@@ -698,7 +595,7 @@ Lemma agree_reglist:
agree_regs j ls rs -> Val.inject_list j (reglist ls rl) (rs##rl).
Proof.
induction rl; simpl; intros.
- auto. constructor. eauto with stacking. auto.
+ auto. constructor; auto using agree_reg.
Qed.
Hint Resolve agree_reg agree_reglist: stacking.
@@ -795,310 +692,130 @@ Proof.
unfold call_regs; intros; red; intros; auto.
Qed.
-(** ** Properties of [agree_frame] *)
+(** ** Properties of [agree_locs] *)
(** Preservation under assignment of machine register. *)
-Lemma agree_frame_set_reg:
- forall j ls ls0 m sp m' sp' parent ra r v,
- agree_frame j ls ls0 m sp m' sp' parent ra ->
+Lemma agree_locs_set_reg:
+ forall ls ls0 r v,
+ agree_locs ls ls0 ->
mreg_within_bounds b r ->
- agree_frame j (Locmap.set (R r) v ls) ls0 m sp m' sp' parent ra.
+ agree_locs (Locmap.set (R r) v ls) ls0.
Proof.
intros. inv H; constructor; auto; intros.
rewrite Locmap.gso. auto. red. intuition congruence.
Qed.
-Lemma agree_frame_set_regs:
- forall j ls0 m sp m' sp' parent ra rl vl ls,
- agree_frame j ls ls0 m sp m' sp' parent ra ->
+Lemma agree_locs_set_regs:
+ forall ls0 rl vl ls,
+ agree_locs ls ls0 ->
(forall r, In r rl -> mreg_within_bounds b r) ->
- agree_frame j (Locmap.setlist (map R rl) vl ls) ls0 m sp m' sp' parent ra.
+ agree_locs (Locmap.setlist (map R rl) vl ls) ls0.
Proof.
- induction rl; destruct vl; simpl; intros; intuition.
- apply IHrl; auto.
- eapply agree_frame_set_reg; eauto.
+ induction rl; destruct vl; simpl; intros; auto.
+ apply IHrl; auto. apply agree_locs_set_reg; auto.
Qed.
-Lemma agree_frame_set_res:
- forall j ls0 m sp m' sp' parent ra res v ls,
- agree_frame j ls ls0 m sp m' sp' parent ra ->
+Lemma agree_locs_set_res:
+ forall ls0 res v ls,
+ agree_locs ls ls0 ->
(forall r, In r (params_of_builtin_res res) -> mreg_within_bounds b r) ->
- agree_frame j (Locmap.setres res v ls) ls0 m sp m' sp' parent ra.
+ agree_locs (Locmap.setres res v ls) ls0.
Proof.
induction res; simpl; intros.
-- eapply agree_frame_set_reg; eauto.
+- eapply agree_locs_set_reg; eauto.
- auto.
- apply IHres2; auto using in_or_app.
Qed.
-Lemma agree_frame_undef_regs:
- forall j ls0 m sp m' sp' parent ra regs ls,
- agree_frame j ls ls0 m sp m' sp' parent ra ->
+Lemma agree_locs_undef_regs:
+ forall ls0 regs ls,
+ agree_locs ls ls0 ->
(forall r, In r regs -> mreg_within_bounds b r) ->
- agree_frame j (LTL.undef_regs regs ls) ls0 m sp m' sp' parent ra.
+ agree_locs (LTL.undef_regs regs ls) ls0.
Proof.
induction regs; simpl; intros.
auto.
- apply agree_frame_set_reg; auto.
+ apply agree_locs_set_reg; auto.
Qed.
Lemma caller_save_reg_within_bounds:
forall r,
- In r destroyed_at_call -> mreg_within_bounds b r.
+ is_callee_save r = false -> mreg_within_bounds b r.
Proof.
- intros. red.
- destruct (zlt (index_int_callee_save r) 0).
- destruct (zlt (index_float_callee_save r) 0).
- generalize (bound_int_callee_save_pos b) (bound_float_callee_save_pos b); omega.
- exfalso. eapply float_callee_save_not_destroyed; eauto. eapply index_float_callee_save_pos2; eauto.
- exfalso. eapply int_callee_save_not_destroyed; eauto. eapply index_int_callee_save_pos2; eauto.
+ intros; red; intros. congruence.
Qed.
-Lemma agree_frame_undef_locs:
- forall j ls0 m sp m' sp' parent ra regs ls,
- agree_frame j ls ls0 m sp m' sp' parent ra ->
- incl regs destroyed_at_call ->
- agree_frame j (LTL.undef_regs regs ls) ls0 m sp m' sp' parent ra.
+Lemma agree_locs_undef_locs_1:
+ forall ls0 regs ls,
+ agree_locs ls ls0 ->
+ (forall r, In r regs -> is_callee_save r = false) ->
+ agree_locs (LTL.undef_regs regs ls) ls0.
Proof.
- intros. eapply agree_frame_undef_regs; eauto.
+ intros. eapply agree_locs_undef_regs; eauto.
intros. apply caller_save_reg_within_bounds. auto.
Qed.
-(** Preservation by assignment to local slot *)
-
-Lemma agree_frame_set_local:
- forall j ls ls0 m sp m' sp' parent retaddr ofs ty v v' m'',
- agree_frame j ls ls0 m sp m' sp' parent retaddr ->
- slot_within_bounds b Local ofs ty -> slot_valid f Local ofs ty = true ->
- Val.inject j v v' ->
- Mem.store (chunk_of_type ty) m' sp' (offset_of_index fe (FI_local ofs ty)) v' = Some m'' ->
- agree_frame j (Locmap.set (S Local ofs ty) v ls) ls0 m sp m'' sp' parent retaddr.
+Lemma agree_locs_undef_locs:
+ forall ls0 regs ls,
+ agree_locs ls ls0 ->
+ existsb is_callee_save regs = false ->
+ agree_locs (LTL.undef_regs regs ls) ls0.
Proof.
- intros. inv H.
- change (chunk_of_type ty) with (chunk_of_type (type_of_index (FI_local ofs ty))) in H3.
- constructor; auto; intros.
-(* local *)
- unfold Locmap.set.
- destruct (Loc.eq (S Local ofs ty) (S Local ofs0 ty0)).
- inv e. eapply gss_index_contains_inj'; eauto with stacking.
- destruct (Loc.diff_dec (S Local ofs ty) (S Local ofs0 ty0)).
- eapply gso_index_contains_inj. eauto. eauto with stacking. eauto.
- simpl. simpl in d. intuition.
- apply index_contains_inj_undef. auto with stacking.
- red; intros. eapply Mem.perm_store_1; eauto.
-(* outgoing *)
- rewrite Locmap.gso. eapply gso_index_contains_inj; eauto with stacking.
- red; auto. red; left; congruence.
-(* parent *)
- eapply gso_index_contains; eauto with stacking. red; auto.
-(* retaddr *)
- eapply gso_index_contains; eauto with stacking. red; auto.
-(* int callee save *)
- eapply gso_index_contains_inj; eauto with stacking. simpl; auto.
-(* float callee save *)
- eapply gso_index_contains_inj; eauto with stacking. simpl; auto.
-(* valid *)
- eauto with mem.
-(* perm *)
- red; intros. eapply Mem.perm_store_1; eauto.
+ intros. eapply agree_locs_undef_locs_1; eauto.
+ intros. destruct (is_callee_save r) eqn:CS; auto.
+ assert (existsb is_callee_save regs = true).
+ { apply existsb_exists. exists r; auto. }
+ congruence.
Qed.
-(** Preservation by assignment to outgoing slot *)
+(** Preservation by assignment to local slot *)
-Lemma agree_frame_set_outgoing:
- forall j ls ls0 m sp m' sp' parent retaddr ofs ty v v' m'',
- agree_frame j ls ls0 m sp m' sp' parent retaddr ->
- slot_within_bounds b Outgoing ofs ty -> slot_valid f Outgoing ofs ty = true ->
- Val.inject j v v' ->
- Mem.store (chunk_of_type ty) m' sp' (offset_of_index fe (FI_arg ofs ty)) v' = Some m'' ->
- agree_frame j (Locmap.set (S Outgoing ofs ty) v ls) ls0 m sp m'' sp' parent retaddr.
+Lemma agree_locs_set_slot:
+ forall ls ls0 sl ofs ty v,
+ agree_locs ls ls0 ->
+ slot_writable sl = true ->
+ agree_locs (Locmap.set (S sl ofs ty) v ls) ls0.
Proof.
- intros. inv H.
- change (chunk_of_type ty) with (chunk_of_type (type_of_index (FI_arg ofs ty))) in H3.
- constructor; auto; intros.
-(* local *)
- rewrite Locmap.gso. eapply gso_index_contains_inj; eauto with stacking. red; auto.
- red; left; congruence.
-(* outgoing *)
- unfold Locmap.set. destruct (Loc.eq (S Outgoing ofs ty) (S Outgoing ofs0 ty0)).
- inv e. eapply gss_index_contains_inj'; eauto with stacking.
- destruct (Loc.diff_dec (S Outgoing ofs ty) (S Outgoing ofs0 ty0)).
- eapply gso_index_contains_inj; eauto with stacking.
- red. red in d. intuition.
- apply index_contains_inj_undef. auto with stacking.
- red; intros. eapply Mem.perm_store_1; eauto.
-(* parent *)
- eapply gso_index_contains; eauto with stacking. red; auto.
-(* retaddr *)
- eapply gso_index_contains; eauto with stacking. red; auto.
-(* int callee save *)
- eapply gso_index_contains_inj; eauto with stacking. simpl; auto.
-(* float callee save *)
- eapply gso_index_contains_inj; eauto with stacking. simpl; auto.
-(* valid *)
- eauto with mem stacking.
-(* perm *)
- red; intros. eapply Mem.perm_store_1; eauto.
-Qed.
-
-(** General invariance property with respect to memory changes. *)
-
-Lemma agree_frame_invariant:
- forall j ls ls0 m sp m' sp' parent retaddr m1 m1',
- agree_frame j ls ls0 m sp m' sp' parent retaddr ->
- (Mem.valid_block m sp -> Mem.valid_block m1 sp) ->
- (forall ofs p, Mem.perm m1 sp ofs Max p -> Mem.perm m sp ofs Max p) ->
- (Mem.valid_block m' sp' -> Mem.valid_block m1' sp') ->
- (forall chunk ofs v,
- ofs + size_chunk chunk <= fe.(fe_stack_data) \/
- fe.(fe_stack_data) + f.(Linear.fn_stacksize) <= ofs ->
- Mem.load chunk m' sp' ofs = Some v ->
- Mem.load chunk m1' sp' ofs = Some v) ->
- (forall ofs k p,
- ofs < fe.(fe_stack_data) \/ fe.(fe_stack_data) + f.(Linear.fn_stacksize) <= ofs ->
- Mem.perm m' sp' ofs k p -> Mem.perm m1' sp' ofs k p) ->
- agree_frame j ls ls0 m1 sp m1' sp' parent retaddr.
-Proof.
- intros.
- assert (IC: forall idx v,
- index_contains m' sp' idx v -> index_contains m1' sp' idx v).
- intros. inv H5.
- exploit offset_of_index_disj_stack_data_2; eauto. intros.
- constructor; eauto. apply H3; auto. rewrite size_type_chunk; auto.
- assert (ICI: forall idx v,
- index_contains_inj j m' sp' idx v -> index_contains_inj j m1' sp' idx v).
- intros. destruct H5 as [v' [A B]]. exists v'; split; auto.
- inv H; constructor; auto; intros.
- eauto.
- red; intros. apply H4; auto.
-Qed.
-
-(** A variant of the latter, for use with external calls *)
-
-Lemma agree_frame_extcall_invariant:
- forall j ls ls0 m sp m' sp' parent retaddr m1 m1',
- agree_frame j ls ls0 m sp m' sp' parent retaddr ->
- (Mem.valid_block m sp -> Mem.valid_block m1 sp) ->
- (forall ofs p, Mem.perm m1 sp ofs Max p -> Mem.perm m sp ofs Max p) ->
- (Mem.valid_block m' sp' -> Mem.valid_block m1' sp') ->
- Mem.unchanged_on (loc_out_of_reach j m) m' m1' ->
- agree_frame j ls ls0 m1 sp m1' sp' parent retaddr.
-Proof.
- intros.
- assert (REACH: forall ofs,
- ofs < fe.(fe_stack_data) \/ fe.(fe_stack_data) + f.(Linear.fn_stacksize) <= ofs ->
- loc_out_of_reach j m sp' ofs).
- intros; red; intros. exploit agree_inj_unique; eauto. intros [EQ1 EQ2]; subst.
- red; intros. exploit agree_bounds; eauto. omega.
- eapply agree_frame_invariant; eauto.
- intros. eapply Mem.load_unchanged_on; eauto. intros. apply REACH. omega. auto.
- intros. eapply Mem.perm_unchanged_on; eauto with mem. auto.
-Qed.
-
-(** Preservation by parallel stores in the Linear and Mach codes *)
-
-Lemma agree_frame_parallel_stores:
- forall j ls ls0 m sp m' sp' parent retaddr chunk addr addr' v v' m1 m1',
- agree_frame j ls ls0 m sp m' sp' parent retaddr ->
- Mem.inject j m m' ->
- Val.inject j addr addr' ->
- Mem.storev chunk m addr v = Some m1 ->
- Mem.storev chunk m' addr' v' = Some m1' ->
- agree_frame j ls ls0 m1 sp m1' sp' parent retaddr.
-Proof.
-Opaque Int.add.
- intros until m1'. intros AG MINJ VINJ STORE1 STORE2.
- inv VINJ; simpl in *; try discriminate.
- eapply agree_frame_invariant; eauto.
- eauto with mem.
- eauto with mem.
- eauto with mem.
- intros. rewrite <- H1. eapply Mem.load_store_other; eauto.
- destruct (eq_block sp' b2); auto.
- subst b2. right.
- exploit agree_inj_unique; eauto. intros [P Q]. subst b1 delta.
- exploit Mem.store_valid_access_3. eexact STORE1. intros [A B].
- rewrite shifted_stack_offset_no_overflow.
- exploit agree_bounds. eauto. apply Mem.perm_cur_max. apply A.
- instantiate (1 := Int.unsigned ofs1). generalize (size_chunk_pos chunk). omega.
- intros C.
- exploit agree_bounds. eauto. apply Mem.perm_cur_max. apply A.
- instantiate (1 := Int.unsigned ofs1 + size_chunk chunk - 1). generalize (size_chunk_pos chunk). omega.
- intros D.
- omega.
- eapply agree_bounds. eauto. apply Mem.perm_cur_max. apply A.
- generalize (size_chunk_pos chunk). omega.
- intros; eauto with mem.
-Qed.
-
-(** Preservation by increasing memory injections (allocations and external calls) *)
-
-Lemma agree_frame_inject_incr:
- forall j ls ls0 m sp m' sp' parent retaddr m1 m1' j',
- agree_frame j ls ls0 m sp m' sp' parent retaddr ->
- inject_incr j j' -> inject_separated j j' m1 m1' ->
- Mem.valid_block m1' sp' ->
- agree_frame j' ls ls0 m sp m' sp' parent retaddr.
-Proof.
- intros. inv H. constructor; auto; intros; eauto with stacking.
- case_eq (j b0).
- intros [b' delta'] EQ. rewrite (H0 _ _ _ EQ) in H. inv H. auto.
- intros EQ. exploit H1. eauto. eauto. intros [A B]. contradiction.
-Qed.
-
-Remark inject_alloc_separated:
- forall j m1 m2 j' b1 b2 delta,
- inject_incr j j' ->
- j' b1 = Some(b2, delta) ->
- (forall b, b <> b1 -> j' b = j b) ->
- ~Mem.valid_block m1 b1 -> ~Mem.valid_block m2 b2 ->
- inject_separated j j' m1 m2.
-Proof.
- intros. red. intros.
- destruct (eq_block b0 b1). subst b0. rewrite H0 in H5; inv H5. tauto.
- rewrite H1 in H5. congruence. auto.
+ intros. destruct H; constructor; intros.
+- rewrite Locmap.gso; auto. red; auto.
+- rewrite Locmap.gso; auto. red. left. destruct sl; discriminate.
Qed.
(** Preservation at return points (when [ls] is changed but not [ls0]). *)
-Lemma agree_frame_return:
- forall j ls ls0 m sp m' sp' parent retaddr ls',
- agree_frame j ls ls0 m sp m' sp' parent retaddr ->
+Lemma agree_locs_return:
+ forall ls ls0 ls',
+ agree_locs ls ls0 ->
agree_callee_save ls' ls ->
- agree_frame j ls' ls0 m sp m' sp' parent retaddr.
+ agree_locs ls' ls0.
Proof.
intros. red in H0. inv H; constructor; auto; intros.
- rewrite H0; auto. red; intros; elim H. apply caller_save_reg_within_bounds; auto.
- rewrite H0; auto.
- rewrite H0; auto.
- rewrite H0; auto.
+- rewrite H0; auto. unfold mreg_within_bounds in H. tauto.
+- rewrite H0; auto.
Qed.
(** Preservation at tailcalls (when [ls0] is changed but not [ls]). *)
-Lemma agree_frame_tailcall:
- forall j ls ls0 m sp m' sp' parent retaddr ls0',
- agree_frame j ls ls0 m sp m' sp' parent retaddr ->
+Lemma agree_locs_tailcall:
+ forall ls ls0 ls0',
+ agree_locs ls ls0 ->
agree_callee_save ls0 ls0' ->
- agree_frame j ls ls0' m sp m' sp' parent retaddr.
+ agree_locs ls ls0'.
Proof.
intros. red in H0. inv H; constructor; auto; intros.
- rewrite <- H0; auto. red; intros; elim H. apply caller_save_reg_within_bounds; auto.
- rewrite <- H0; auto.
- rewrite <- H0. auto. red; intros. eapply int_callee_save_not_destroyed; eauto.
- rewrite <- H0. auto. red; intros. eapply float_callee_save_not_destroyed; eauto.
+- rewrite <- H0; auto. unfold mreg_within_bounds in H. tauto.
+- rewrite <- H0; auto.
Qed.
-(** Properties of [agree_callee_save]. *)
+(** ** Properties of [agree_callee_save]. *)
Lemma agree_callee_save_return_regs:
forall ls1 ls2,
agree_callee_save (return_regs ls1 ls2) ls1.
Proof.
intros; red; intros.
- unfold return_regs. destruct l; auto.
- rewrite pred_dec_false; auto.
+ unfold return_regs. destruct l; auto. rewrite H; auto.
Qed.
Lemma agree_callee_save_set_result:
@@ -1108,74 +825,60 @@ Lemma agree_callee_save_set_result:
Proof.
intros sg. generalize (loc_result_caller_save sg).
generalize (loc_result sg).
-Opaque destroyed_at_call.
induction l; simpl; intros.
auto.
destruct vl; auto.
apply IHl; auto.
red; intros. rewrite Locmap.gso. apply H0; auto.
- destruct l0; simpl; auto.
+ destruct l0; simpl; auto. red; intros; subst a.
+ assert (is_callee_save r = false) by auto. congruence.
Qed.
-(** Properties of destroyed registers. *)
+(** ** Properties of destroyed registers. *)
-Lemma check_mreg_list_incl:
- forall l1 l2,
- forallb (fun r => In_dec mreg_eq r l2) l1 = true ->
- incl l1 l2.
-Proof.
- intros; red; intros.
- rewrite forallb_forall in H. eapply proj_sumbool_true. eauto.
-Qed.
+Definition no_callee_saves (l: list mreg) : Prop :=
+ existsb is_callee_save l = false.
Remark destroyed_by_op_caller_save:
- forall op, incl (destroyed_by_op op) destroyed_at_call.
+ forall op, no_callee_saves (destroyed_by_op op).
Proof.
- destruct op; apply check_mreg_list_incl; compute; auto.
+ unfold no_callee_saves; destruct op; reflexivity.
Qed.
Remark destroyed_by_load_caller_save:
- forall chunk addr, incl (destroyed_by_load chunk addr) destroyed_at_call.
+ forall chunk addr, no_callee_saves (destroyed_by_load chunk addr).
Proof.
- intros. destruct chunk; apply check_mreg_list_incl; compute; auto.
+ unfold no_callee_saves; destruct chunk; reflexivity.
Qed.
Remark destroyed_by_store_caller_save:
- forall chunk addr, incl (destroyed_by_store chunk addr) destroyed_at_call.
+ forall chunk addr, no_callee_saves (destroyed_by_store chunk addr).
Proof.
- intros. destruct chunk; apply check_mreg_list_incl; compute; auto.
+ unfold no_callee_saves; destruct chunk; reflexivity.
Qed.
Remark destroyed_by_cond_caller_save:
- forall cond, incl (destroyed_by_cond cond) destroyed_at_call.
+ forall cond, no_callee_saves (destroyed_by_cond cond).
Proof.
- destruct cond; apply check_mreg_list_incl; compute; auto.
+ unfold no_callee_saves; destruct cond; reflexivity.
Qed.
Remark destroyed_by_jumptable_caller_save:
- incl destroyed_by_jumptable destroyed_at_call.
+ no_callee_saves destroyed_by_jumptable.
Proof.
- apply check_mreg_list_incl; compute; auto.
+ red; reflexivity.
Qed.
Remark destroyed_by_setstack_caller_save:
- forall ty, incl (destroyed_by_setstack ty) destroyed_at_call.
+ forall ty, no_callee_saves (destroyed_by_setstack ty).
Proof.
- destruct ty; apply check_mreg_list_incl; compute; auto.
+ unfold no_callee_saves; destruct ty; reflexivity.
Qed.
Remark destroyed_at_function_entry_caller_save:
- incl destroyed_at_function_entry destroyed_at_call.
+ no_callee_saves destroyed_at_function_entry.
Proof.
- apply check_mreg_list_incl; compute; auto.
-Qed.
-
-Remark temp_for_parent_frame_caller_save:
- In temp_for_parent_frame destroyed_at_call.
-Proof.
- Transparent temp_for_parent_frame.
- Transparent destroyed_at_call.
- unfold temp_for_parent_frame; simpl; tauto.
+ red; reflexivity.
Qed.
Hint Resolve destroyed_by_op_caller_save destroyed_by_load_caller_save
@@ -1186,7 +889,8 @@ Hint Resolve destroyed_by_op_caller_save destroyed_by_load_caller_save
Remark destroyed_by_setstack_function_entry:
forall ty, incl (destroyed_by_setstack ty) destroyed_at_function_entry.
Proof.
- destruct ty; apply check_mreg_list_incl; compute; auto.
+Local Transparent destroyed_by_setstack destroyed_at_function_entry.
+ unfold incl; destruct ty; simpl; tauto.
Qed.
Remark transl_destroyed_by_op:
@@ -1216,129 +920,67 @@ Qed.
Section SAVE_CALLEE_SAVE.
-Variable bound: frame_env -> Z.
-Variable number: mreg -> Z.
-Variable mkindex: Z -> frame_index.
-Variable ty: typ.
Variable j: meminj.
Variable cs: list stackframe.
Variable fb: block.
Variable sp: block.
-Variable csregs: list mreg.
Variable ls: locset.
-Inductive stores_in_frame: mem -> mem -> Prop :=
- | stores_in_frame_refl: forall m,
- stores_in_frame m m
- | stores_in_frame_step: forall m1 chunk ofs v m2 m3,
- ofs + size_chunk chunk <= fe.(fe_stack_data)
- \/ fe.(fe_stack_data) + f.(Linear.fn_stacksize) <= ofs ->
- Mem.store chunk m1 sp ofs v = Some m2 ->
- stores_in_frame m2 m3 ->
- stores_in_frame m1 m3.
-
-Remark stores_in_frame_trans:
- forall m1 m2, stores_in_frame m1 m2 ->
- forall m3, stores_in_frame m2 m3 -> stores_in_frame m1 m3.
-Proof.
- induction 1; intros. auto. econstructor; eauto.
-Qed.
-
-Hypothesis number_inj:
- forall r1 r2, In r1 csregs -> In r2 csregs -> r1 <> r2 -> number r1 <> number r2.
-Hypothesis mkindex_valid:
- forall r, In r csregs -> number r < bound fe -> index_valid (mkindex (number r)).
-Hypothesis mkindex_typ:
- forall z, type_of_index (mkindex z) = ty.
-Hypothesis mkindex_inj:
- forall z1 z2, z1 <> z2 -> mkindex z1 <> mkindex z2.
-Hypothesis mkindex_diff:
- forall r idx,
- idx <> mkindex (number r) -> index_diff (mkindex (number r)) idx.
-Hypothesis csregs_typ:
- forall r, In r csregs -> mreg_type r = ty.
-
Hypothesis ls_temp_undef:
- forall r, In r (destroyed_by_setstack ty) -> ls (R r) = Vundef.
+ forall ty r, In r (destroyed_by_setstack ty) -> ls (R r) = Vundef.
Hypothesis wt_ls: forall r, Val.has_type (ls (R r)) (mreg_type r).
-Lemma save_callee_save_regs_correct:
- forall l k rs m,
- incl l csregs ->
- list_norepet l ->
- frame_perm_freeable m sp ->
+Lemma save_callee_save_rec_correct:
+ forall k l pos rs m P,
+ (forall r, In r l -> is_callee_save r = true) ->
+ m |= range sp pos (size_callee_save_area_rec l pos) ** P ->
agree_regs j ls rs ->
exists rs', exists m',
- star step tge
- (State cs fb (Vptr sp Int.zero)
- (save_callee_save_regs bound number mkindex ty fe l k) rs m)
- E0 (State cs fb (Vptr sp Int.zero) k rs' m')
- /\ (forall r,
- In r l -> number r < bound fe ->
- index_contains_inj j m' sp (mkindex (number r)) (ls (R r)))
- /\ (forall idx v,
- index_valid idx ->
- (forall r,
- In r l -> number r < bound fe -> idx <> mkindex (number r)) ->
- index_contains m sp idx v ->
- index_contains m' sp idx v)
- /\ stores_in_frame m m'
- /\ frame_perm_freeable m' sp
+ star step tge
+ (State cs fb (Vptr sp Int.zero) (save_callee_save_rec l pos k) rs m)
+ E0 (State cs fb (Vptr sp Int.zero) k rs' m')
+ /\ m' |= contains_callee_saves j sp pos l ls ** P
+ /\ (forall ofs k p, Mem.perm m sp ofs k p -> Mem.perm m' sp ofs k p)
/\ agree_regs j ls rs'.
Proof.
- induction l; intros; simpl save_callee_save_regs.
- (* base case *)
- exists rs; exists m. split. apply star_refl.
- split. intros. elim H3.
- split. auto.
- split. constructor.
+ induction l as [ | r l]; simpl; intros until P; intros CS SEP AG.
+- exists rs, m.
+ split. apply star_refl.
+ split. rewrite sep_pure; split; auto. eapply sep_drop; eauto.
+ split. auto.
auto.
- (* inductive case *)
- assert (R1: incl l csregs). eauto with coqlib.
- assert (R2: list_norepet l). inversion H0; auto.
- unfold save_callee_save_reg.
- destruct (zlt (number a) (bound fe)).
- (* a store takes place *)
- exploit store_index_succeeds. apply (mkindex_valid a); auto with coqlib.
- eauto. instantiate (1 := rs a). intros [m1 ST].
- exploit (IHl k (undef_regs (destroyed_by_setstack ty) rs) m1). auto with coqlib. auto.
- red; eauto with mem.
- apply agree_regs_exten with ls rs. auto.
- intros. destruct (In_dec mreg_eq r (destroyed_by_setstack ty)).
- left. apply ls_temp_undef; auto.
- right; split. auto. apply undef_regs_other; auto.
- intros [rs' [m' [A [B [C [D [E F]]]]]]].
- exists rs'; exists m'.
- split. eapply star_left; eauto. econstructor.
- rewrite <- (mkindex_typ (number a)).
- apply store_stack_succeeds; auto with coqlib.
- auto. traceEq.
- split; intros.
- simpl in H3. destruct (mreg_eq a r). subst r.
- assert (index_contains_inj j m1 sp (mkindex (number a)) (ls (R a))).
- eapply gss_index_contains_inj; eauto.
- rewrite mkindex_typ. rewrite <- (csregs_typ a). apply wt_ls.
- auto with coqlib.
- destruct H5 as [v' [P Q]].
- exists v'; split; auto. apply C; auto.
- intros. apply mkindex_inj. apply number_inj; auto with coqlib.
- inv H0. intuition congruence.
- apply B; auto with coqlib.
- intuition congruence.
- split. intros.
- apply C; auto with coqlib.
- eapply gso_index_contains; eauto with coqlib.
- split. econstructor; eauto.
- rewrite size_type_chunk. apply offset_of_index_disj_stack_data_2; eauto with coqlib.
+- set (ty := mreg_type r) in *.
+ set (sz := AST.typesize ty) in *.
+ set (pos1 := align pos sz) in *.
+ assert (SZPOS: sz > 0) by (apply AST.typesize_pos).
+ assert (SZREC: pos1 + sz <= size_callee_save_area_rec l (pos1 + sz)) by (apply size_callee_save_area_rec_incr).
+ assert (POS1: pos <= pos1) by (apply align_le; auto).
+ assert (AL1: (align_chunk (chunk_of_type ty) | pos1)).
+ { unfold pos1. apply Zdivide_trans with sz.
+ unfold sz; rewrite <- size_type_chunk. apply align_size_chunk_divides.
+ apply align_divides; auto. }
+ apply range_drop_left with (mid := pos1) in SEP; [ | omega ].
+ apply range_split with (mid := pos1 + sz) in SEP; [ | omega ].
+ unfold sz at 1 in SEP. rewrite <- size_type_chunk in SEP.
+ apply range_contains in SEP; auto.
+ exploit (contains_set_stack (fun v' => Val.inject j (ls (R r)) v') (rs r)).
+ eexact SEP.
+ apply load_result_inject; auto. apply wt_ls.
+ clear SEP; intros (m1 & STORE & SEP).
+ set (rs1 := undef_regs (destroyed_by_setstack ty) rs).
+ assert (AG1: agree_regs j ls rs1).
+ { red; intros. unfold rs1. destruct (In_dec mreg_eq r0 (destroyed_by_setstack ty)).
+ erewrite ls_temp_undef by eauto. auto.
+ rewrite undef_regs_other by auto. apply AG. }
+ rewrite sep_swap in SEP.
+ exploit (IHl (pos1 + sz) rs1 m1); eauto.
+ intros (rs2 & m2 & A & B & C & D).
+ exists rs2, m2.
+ split. eapply star_left; eauto. constructor. exact STORE. auto. traceEq.
+ split. rewrite sep_assoc, sep_swap. exact B.
+ split. intros. apply C. unfold store_stack in STORE; simpl in STORE. eapply Mem.perm_store_1; eauto.
auto.
- (* no store takes place *)
- exploit (IHl k rs m); auto with coqlib.
- intros [rs' [m' [A [B [C [D [E F]]]]]]].
- exists rs'; exists m'; intuition.
- simpl in H3. destruct H3. subst r. omegaContradiction. apply B; auto.
- apply C; auto with coqlib.
- intros. eapply H4; eauto. auto with coqlib.
Qed.
End SAVE_CALLEE_SAVE.
@@ -1366,127 +1008,7 @@ Proof.
rewrite Locmap.gso. apply IHrl. red; auto.
Qed.
-Lemma save_callee_save_correct:
- forall j ls0 rs sp cs fb k m,
- let ls := LTL.undef_regs destroyed_at_function_entry ls0 in
- agree_regs j ls rs ->
- (forall r, Val.has_type (ls (R r)) (mreg_type r)) ->
- frame_perm_freeable m sp ->
- exists rs', exists m',
- star step tge
- (State cs fb (Vptr sp Int.zero) (save_callee_save fe k) rs m)
- E0 (State cs fb (Vptr sp Int.zero) k rs' m')
- /\ (forall r,
- In r int_callee_save_regs -> index_int_callee_save r < b.(bound_int_callee_save) ->
- index_contains_inj j m' sp (FI_saved_int (index_int_callee_save r)) (ls (R r)))
- /\ (forall r,
- In r float_callee_save_regs -> index_float_callee_save r < b.(bound_float_callee_save) ->
- index_contains_inj j m' sp (FI_saved_float (index_float_callee_save r)) (ls (R r)))
- /\ (forall idx v,
- index_valid idx ->
- match idx with FI_saved_int _ => False | FI_saved_float _ => False | _ => True end ->
- index_contains m sp idx v ->
- index_contains m' sp idx v)
- /\ stores_in_frame sp m m'
- /\ frame_perm_freeable m' sp
- /\ agree_regs j ls rs'.
-Proof.
- intros.
- assert (UNDEF: forall r ty, In r (destroyed_by_setstack ty) -> ls (R r) = Vundef).
- intros. unfold ls. apply LTL_undef_regs_same. eapply destroyed_by_setstack_function_entry; eauto.
- exploit (save_callee_save_regs_correct
- fe_num_int_callee_save
- index_int_callee_save
- FI_saved_int Tany32
- j cs fb sp int_callee_save_regs ls).
- intros. apply index_int_callee_save_inj; auto.
- intros. simpl. split. apply Zge_le. apply index_int_callee_save_pos; auto. assumption.
- auto.
- intros; congruence.
- intros; simpl. destruct idx; auto. congruence.
- intros. apply int_callee_save_type. auto.
- eauto.
- auto.
- apply incl_refl.
- apply int_callee_save_norepet.
- eauto.
- eauto.
- intros [rs1 [m1 [A [B [C [D [E F]]]]]]].
- exploit (save_callee_save_regs_correct
- fe_num_float_callee_save
- index_float_callee_save
- FI_saved_float Tany64
- j cs fb sp float_callee_save_regs ls).
- intros. apply index_float_callee_save_inj; auto.
- intros. simpl. split. apply Zge_le. apply index_float_callee_save_pos; auto. assumption.
- simpl; auto.
- intros; congruence.
- intros; simpl. destruct idx; auto. congruence.
- intros. apply float_callee_save_type. auto.
- eauto.
- auto.
- apply incl_refl.
- apply float_callee_save_norepet.
- eexact E.
- eexact F.
- intros [rs2 [m2 [P [Q [R [S [T U]]]]]]].
- exists rs2; exists m2.
- split. unfold save_callee_save, save_callee_save_int, save_callee_save_float.
- eapply star_trans; eauto.
- split; intros.
- destruct (B r H2 H3) as [v [X Y]]. exists v; split; auto. apply R.
- apply index_saved_int_valid; auto.
- intros. congruence.
- auto.
- split. intros. apply Q; auto.
- split. intros. apply R. auto.
- intros. destruct idx; contradiction||congruence.
- apply C. auto.
- intros. destruct idx; contradiction||congruence.
- auto.
- split. eapply stores_in_frame_trans; eauto.
- auto.
-Qed.
-
-(** Properties of sequences of stores in the frame. *)
-
-Lemma stores_in_frame_inject:
- forall j sp sp' m,
- (forall b delta, j b = Some(sp', delta) -> b = sp /\ delta = fe.(fe_stack_data)) ->
- (forall ofs k p, Mem.perm m sp ofs k p -> 0 <= ofs < f.(Linear.fn_stacksize)) ->
- forall m1 m2, stores_in_frame sp' m1 m2 -> Mem.inject j m m1 -> Mem.inject j m m2.
-Proof.
- induction 3; intros.
- auto.
- apply IHstores_in_frame.
- intros. eapply Mem.store_outside_inject; eauto.
- intros. exploit H; eauto. intros [A B]; subst.
- exploit H0; eauto. omega.
-Qed.
-
-Lemma stores_in_frame_valid:
- forall b sp m m', stores_in_frame sp m m' -> Mem.valid_block m b -> Mem.valid_block m' b.
-Proof.
- induction 1; intros. auto. apply IHstores_in_frame. eauto with mem.
-Qed.
-
-Lemma stores_in_frame_perm:
- forall b ofs k p sp m m', stores_in_frame sp m m' -> Mem.perm m b ofs k p -> Mem.perm m' b ofs k p.
-Proof.
- induction 1; intros. auto. apply IHstores_in_frame. eauto with mem.
-Qed.
-
-Lemma stores_in_frame_contents:
- forall chunk b ofs sp, Plt b sp ->
- forall m m', stores_in_frame sp m m' ->
- Mem.load chunk m' b ofs = Mem.load chunk m b ofs.
-Proof.
- induction 2. auto.
- rewrite IHstores_in_frame. eapply Mem.load_store_other; eauto.
- left. apply Plt_ne; auto.
-Qed.
-
-Lemma undef_regs_type:
+Remark undef_regs_type:
forall ty l rl ls,
Val.has_type (ls l) ty -> Val.has_type (LTL.undef_regs rl ls l) ty.
Proof.
@@ -1496,21 +1018,60 @@ Proof.
destruct (Loc.diff_dec (R a) l); auto. red; auto.
Qed.
+Lemma save_callee_save_correct:
+ forall j ls ls0 rs sp cs fb k m P,
+ m |= range sp fe.(fe_ofs_callee_save) (size_callee_save_area b fe.(fe_ofs_callee_save)) ** P ->
+ (forall r, Val.has_type (ls (R r)) (mreg_type r)) ->
+ agree_callee_save ls ls0 ->
+ agree_regs j ls rs ->
+ let ls1 := LTL.undef_regs destroyed_at_function_entry (LTL.call_regs ls) in
+ let rs1 := undef_regs destroyed_at_function_entry rs in
+ exists rs', exists m',
+ star step tge
+ (State cs fb (Vptr sp Int.zero) (save_callee_save fe k) rs1 m)
+ E0 (State cs fb (Vptr sp Int.zero) k rs' m')
+ /\ m' |= contains_callee_saves j sp fe.(fe_ofs_callee_save) b.(used_callee_save) ls0 ** P
+ /\ (forall ofs k p, Mem.perm m sp ofs k p -> Mem.perm m' sp ofs k p)
+ /\ agree_regs j ls1 rs'.
+Proof.
+ intros until P; intros SEP TY AGCS AG; intros ls1 rs1.
+ exploit (save_callee_save_rec_correct j cs fb sp ls1).
+- intros. unfold ls1. apply LTL_undef_regs_same. eapply destroyed_by_setstack_function_entry; eauto.
+- intros. unfold ls1. apply undef_regs_type. apply TY.
+- exact b.(used_callee_save_prop).
+- eexact SEP.
+- instantiate (1 := rs1). apply agree_regs_undef_regs. apply agree_regs_call_regs. auto.
+- clear SEP. intros (rs' & m' & EXEC & SEP & PERMS & AG').
+ exists rs', m'.
+ split. eexact EXEC.
+ split. rewrite (contains_callee_saves_exten j sp ls0 ls1). exact SEP.
+ intros. apply b.(used_callee_save_prop) in H.
+ unfold ls1. rewrite LTL_undef_regs_others. unfold call_regs.
+ apply AGCS; auto.
+ red; intros.
+ assert (existsb is_callee_save destroyed_at_function_entry = false)
+ by (apply destroyed_at_function_entry_caller_save).
+ assert (existsb is_callee_save destroyed_at_function_entry = true).
+ { apply existsb_exists. exists r; auto. }
+ congruence.
+ split. exact PERMS. exact AG'.
+Qed.
+
(** As a corollary of the previous lemmas, we obtain the following
correctness theorem for the execution of a function prologue
(allocation of the frame + saving of the link and return address +
saving of the used callee-save registers). *)
Lemma function_prologue_correct:
- forall j ls ls0 ls1 rs rs1 m1 m1' m2 sp parent ra cs fb k,
+ forall j ls ls0 ls1 rs rs1 m1 m1' m2 sp parent ra cs fb k P,
agree_regs j ls rs ->
agree_callee_save ls ls0 ->
(forall r, Val.has_type (ls (R r)) (mreg_type r)) ->
ls1 = LTL.undef_regs destroyed_at_function_entry (LTL.call_regs ls) ->
rs1 = undef_regs destroyed_at_function_entry rs ->
- Mem.inject j m1 m1' ->
Mem.alloc m1 0 f.(Linear.fn_stacksize) = (m2, sp) ->
Val.has_type parent Tint -> Val.has_type ra Tint ->
+ m1' |= minjection j m1 ** globalenv_inject ge j ** P ->
exists j', exists rs', exists m2', exists sp', exists m3', exists m4', exists m5',
Mem.alloc m1' 0 tf.(fn_stacksize) = (m2', sp')
/\ store_stack m2' (Vptr sp' Int.zero) Tint tf.(fn_link_ofs) parent = Some m3'
@@ -1519,143 +1080,97 @@ Lemma function_prologue_correct:
(State cs fb (Vptr sp' Int.zero) (save_callee_save fe k) rs1 m4')
E0 (State cs fb (Vptr sp' Int.zero) k rs' m5')
/\ agree_regs j' ls1 rs'
- /\ agree_frame j' ls1 ls0 m2 sp m5' sp' parent ra
- /\ inject_incr j j'
- /\ inject_separated j j' m1 m1'
- /\ Mem.inject j' m2 m5'
- /\ stores_in_frame sp' m2' m5'.
+ /\ agree_locs ls1 ls0
+ /\ m5' |= frame_contents j' sp' ls1 ls0 parent ra ** minjection j' m2 ** globalenv_inject ge j' ** P
+ /\ j' sp = Some(sp', fe.(fe_stack_data))
+ /\ inject_incr j j'.
Proof.
- intros until k; intros AGREGS AGCS WTREGS LS1 RS1 INJ1 ALLOC TYPAR TYRA.
+ intros until P; intros AGREGS AGCS WTREGS LS1 RS1 ALLOC TYPAR TYRA SEP.
rewrite unfold_transf_function.
unfold fn_stacksize, fn_link_ofs, fn_retaddr_ofs.
+ (* Stack layout info *)
+Local Opaque b fe.
+ generalize (frame_env_range b) (frame_env_aligned b). replace (make_env b) with fe by auto. simpl.
+ intros LAYOUT1 LAYOUT2.
(* Allocation step *)
- caseEq (Mem.alloc m1' 0 (fe_size fe)). intros m2' sp' ALLOC'.
- exploit Mem.alloc_left_mapped_inject.
- eapply Mem.alloc_right_inject; eauto.
- eauto.
- instantiate (1 := sp'). eauto with mem.
- instantiate (1 := fe_stack_data fe).
- generalize stack_data_offset_valid (bound_stack_data_pos b) size_no_overflow; omega.
- intros; right.
- exploit Mem.perm_alloc_inv. eexact ALLOC'. eauto. rewrite dec_eq_true.
- generalize size_no_overflow. omega.
- intros. apply Mem.perm_implies with Freeable; auto with mem.
- eapply Mem.perm_alloc_2; eauto.
- generalize stack_data_offset_valid bound_stack_data_stacksize; omega.
- red. intros. apply Zdivides_trans with 8.
- destruct chunk; simpl; auto with align_4.
- apply fe_stack_data_aligned.
- intros.
- assert (Mem.valid_block m1' sp'). eapply Mem.valid_block_inject_2; eauto.
- assert (~Mem.valid_block m1' sp') by eauto with mem.
- contradiction.
- intros [j' [INJ2 [INCR [MAP1 MAP2]]]].
- assert (PERM: frame_perm_freeable m2' sp').
- red; intros. eapply Mem.perm_alloc_2; eauto.
+ destruct (Mem.alloc m1' 0 (fe_size fe)) as [m2' sp'] eqn:ALLOC'.
+ exploit alloc_parallel_rule_2.
+ eexact SEP. eexact ALLOC. eexact ALLOC'.
+ instantiate (1 := fe_stack_data fe). tauto.
+ reflexivity.
+ instantiate (1 := fe_stack_data fe + bound_stack_data b). rewrite Z.max_comm. reflexivity.
+ generalize (bound_stack_data_pos b) size_no_overflow; omega.
+ tauto.
+ tauto.
+ clear SEP. intros (j' & SEP & INCR & SAME).
+ (* Remember the freeable permissions using a mconj *)
+ assert (SEPCONJ:
+ m2' |= mconj (range sp' 0 (fe_stack_data fe) ** range sp' (fe_stack_data fe + bound_stack_data b) (fe_size fe))
+ (range sp' 0 (fe_stack_data fe) ** range sp' (fe_stack_data fe + bound_stack_data b) (fe_size fe))
+ ** minjection j' m2 ** globalenv_inject ge j' ** P).
+ { apply mconj_intro; rewrite sep_assoc; assumption. }
+ (* Dividing up the frame *)
+ apply (frame_env_separated b) in SEP. replace (make_env b) with fe in SEP by auto.
(* Store of parent *)
- exploit (store_index_succeeds m2' sp' FI_link parent). red; auto. auto.
- intros [m3' STORE2].
- (* Store of retaddr *)
- exploit (store_index_succeeds m3' sp' FI_retaddr ra). red; auto. red; eauto with mem.
- intros [m4' STORE3].
+ rewrite sep_swap3 in SEP.
+ apply (range_contains Mint32) in SEP; [|tauto].
+ exploit (contains_set_stack (fun v' => v' = parent) parent (fun _ => True) m2' Tint).
+ eexact SEP. apply Val.load_result_same; auto.
+ clear SEP; intros (m3' & STORE_PARENT & SEP).
+ rewrite sep_swap3 in SEP.
+ (* Store of return address *)
+ rewrite sep_swap4 in SEP.
+ apply (range_contains Mint32) in SEP; [|tauto].
+ exploit (contains_set_stack (fun v' => v' = ra) ra (fun _ => True) m3' Tint).
+ eexact SEP. apply Val.load_result_same; auto.
+ clear SEP; intros (m4' & STORE_RETADDR & SEP).
+ rewrite sep_swap4 in SEP.
(* Saving callee-save registers *)
- assert (PERM4: frame_perm_freeable m4' sp').
- red; intros. eauto with mem.
- exploit save_callee_save_correct.
- instantiate (1 := rs1). instantiate (1 := call_regs ls). instantiate (1 := j').
- subst rs1. apply agree_regs_undef_regs.
- apply agree_regs_call_regs. eapply agree_regs_inject_incr; eauto.
- intros. apply undef_regs_type. simpl. apply WTREGS.
- eexact PERM4.
- rewrite <- LS1.
- intros [rs' [m5' [STEPS [ICS [FCS [OTHERS [STORES [PERM5 AGREGS']]]]]]]].
- (* stores in frames *)
- assert (SIF: stores_in_frame sp' m2' m5').
- econstructor; eauto.
- rewrite size_type_chunk. apply offset_of_index_disj_stack_data_2; auto. red; auto.
- econstructor; eauto.
- rewrite size_type_chunk. apply offset_of_index_disj_stack_data_2; auto. red; auto.
- (* separation *)
- assert (SEP: forall b0 delta, j' b0 = Some(sp', delta) -> b0 = sp /\ delta = fe_stack_data fe).
- intros. destruct (eq_block b0 sp).
- subst b0. rewrite MAP1 in H; inv H; auto.
- rewrite MAP2 in H; auto.
- assert (Mem.valid_block m1' sp'). eapply Mem.valid_block_inject_2; eauto.
- assert (~Mem.valid_block m1' sp') by eauto with mem.
- contradiction.
- (* Conclusions *)
- exists j'; exists rs'; exists m2'; exists sp'; exists m3'; exists m4'; exists m5'.
+ rewrite sep_swap5 in SEP.
+ exploit (save_callee_save_correct j' ls ls0 rs); eauto.
+ apply agree_regs_inject_incr with j; auto.
+ replace (LTL.undef_regs destroyed_at_function_entry (call_regs ls)) with ls1 by auto.
+ replace (undef_regs destroyed_at_function_entry rs) with rs1 by auto.
+ clear SEP; intros (rs2 & m5' & SAVE_CS & SEP & PERMS & AGREGS').
+ rewrite sep_swap5 in SEP.
+ (* Materializing the Local and Outgoing locations *)
+ exploit (initial_locations j'). eexact SEP. tauto.
+ instantiate (1 := Local). instantiate (1 := ls1).
+ intros; rewrite LS1. rewrite LTL_undef_regs_slot. reflexivity.
+ clear SEP; intros SEP.
+ rewrite sep_swap in SEP.
+ exploit (initial_locations j'). eexact SEP. tauto.
+ instantiate (1 := Outgoing). instantiate (1 := ls1).
+ intros; rewrite LS1. rewrite LTL_undef_regs_slot. reflexivity.
+ clear SEP; intros SEP.
+ rewrite sep_swap in SEP.
+ (* Now we frame this *)
+ assert (SEPFINAL: m5' |= frame_contents j' sp' ls1 ls0 parent ra ** minjection j' m2 ** globalenv_inject ge j' ** P).
+ { eapply frame_mconj. eexact SEPCONJ.
+ unfold frame_contents_1; rewrite ! sep_assoc. exact SEP.
+ assert (forall ofs k p, Mem.perm m2' sp' ofs k p -> Mem.perm m5' sp' ofs k p).
+ { intros. apply PERMS.
+ unfold store_stack in STORE_PARENT, STORE_RETADDR.
+ simpl in STORE_PARENT, STORE_RETADDR.
+ eauto using Mem.perm_store_1. }
+ eapply sep_preserved. eapply sep_proj1. eapply mconj_proj2. eexact SEPCONJ.
+ intros; apply range_preserved with m2'; auto.
+ intros; apply range_preserved with m2'; auto.
+ }
+ clear SEP SEPCONJ.
+(* Conclusions *)
+ exists j', rs2, m2', sp', m3', m4', m5'.
split. auto.
- (* store parent *)
- split. change Tint with (type_of_index FI_link).
- change (fe_ofs_link fe) with (offset_of_index fe FI_link).
- apply store_stack_succeeds; auto. red; auto.
- (* store retaddr *)
- split. change Tint with (type_of_index FI_retaddr).
- change (fe_ofs_retaddr fe) with (offset_of_index fe FI_retaddr).
- apply store_stack_succeeds; auto. red; auto.
- (* saving of registers *)
- split. eexact STEPS.
- (* agree_regs *)
- split. auto.
- (* agree frame *)
- split. constructor; intros.
- (* unused regs *)
- assert (~In r destroyed_at_call).
- red; intros; elim H; apply caller_save_reg_within_bounds; auto.
- rewrite LS1. rewrite LTL_undef_regs_others. unfold call_regs.
- apply AGCS; auto. red; intros; elim H0.
- apply destroyed_at_function_entry_caller_save; auto.
- (* locals *)
- rewrite LS1. rewrite LTL_undef_regs_slot. unfold call_regs.
- apply index_contains_inj_undef; auto with stacking.
- (* outgoing *)
- rewrite LS1. rewrite LTL_undef_regs_slot. unfold call_regs.
- apply index_contains_inj_undef; auto with stacking.
- (* incoming *)
- rewrite LS1. rewrite LTL_undef_regs_slot. unfold call_regs.
- apply AGCS; auto.
- (* parent *)
- apply OTHERS; auto. red; auto.
- eapply gso_index_contains; eauto. red; auto.
- eapply gss_index_contains; eauto. red; auto.
- red; auto.
- (* retaddr *)
- apply OTHERS; auto. red; auto.
- eapply gss_index_contains; eauto. red; auto.
- (* int callee save *)
- assert (~In r destroyed_at_call).
- red; intros. eapply int_callee_save_not_destroyed; eauto.
- exploit ICS; eauto. rewrite LS1. rewrite LTL_undef_regs_others. unfold call_regs.
- rewrite AGCS; auto.
- red; intros; elim H1. apply destroyed_at_function_entry_caller_save; auto.
- (* float callee save *)
- assert (~In r destroyed_at_call).
- red; intros. eapply float_callee_save_not_destroyed; eauto.
- exploit FCS; eauto. rewrite LS1. rewrite LTL_undef_regs_others. unfold call_regs.
- rewrite AGCS; auto.
- red; intros; elim H1. apply destroyed_at_function_entry_caller_save; auto.
- (* inj *)
- auto.
- (* inj_unique *)
- auto.
- (* valid sp *)
- eauto with mem.
- (* valid sp' *)
- eapply stores_in_frame_valid with (m := m2'); eauto with mem.
- (* bounds *)
- exploit Mem.perm_alloc_inv. eexact ALLOC. eauto. rewrite dec_eq_true. auto.
- (* perms *)
- auto.
- (* incr *)
- split. auto.
- (* separated *)
- split. eapply inject_alloc_separated; eauto with mem.
- (* inject *)
- split. eapply stores_in_frame_inject; eauto.
- intros. exploit Mem.perm_alloc_inv. eexact ALLOC. eauto. rewrite dec_eq_true. auto.
- (* stores in frame *)
- auto.
+ split. exact STORE_PARENT.
+ split. exact STORE_RETADDR.
+ split. eexact SAVE_CS.
+ split. exact AGREGS'.
+ split. rewrite LS1. apply agree_locs_undef_locs; [|reflexivity].
+ constructor; intros. unfold call_regs. apply AGCS.
+ unfold mreg_within_bounds in H; tauto.
+ unfold call_regs. apply AGCS. auto.
+ split. exact SEPFINAL.
+ split. exact SAME. exact INCR.
Qed.
(** The following lemmas show the correctness of the register reloading
@@ -1665,11 +1180,6 @@ Qed.
Section RESTORE_CALLEE_SAVE.
-Variable bound: frame_env -> Z.
-Variable number: mreg -> Z.
-Variable mkindex: Z -> frame_index.
-Variable ty: typ.
-Variable csregs: list mreg.
Variable j: meminj.
Variable cs: list stackframe.
Variable fb: block.
@@ -1677,133 +1187,80 @@ Variable sp: block.
Variable ls0: locset.
Variable m: mem.
-Hypothesis mkindex_valid:
- forall r, In r csregs -> number r < bound fe -> index_valid (mkindex (number r)).
-Hypothesis mkindex_typ:
- forall z, type_of_index (mkindex z) = ty.
-Hypothesis number_within_bounds:
- forall r, In r csregs ->
- (number r < bound fe <-> mreg_within_bounds b r).
-Hypothesis mkindex_val:
- forall r,
- In r csregs -> number r < bound fe ->
- index_contains_inj j m sp (mkindex (number r)) (ls0 (R r)).
-
Definition agree_unused (ls0: locset) (rs: regset) : Prop :=
forall r, ~(mreg_within_bounds b r) -> Val.inject j (ls0 (R r)) (rs r).
-Lemma restore_callee_save_regs_correct:
- forall l rs k,
- incl l csregs ->
- list_norepet l ->
+Lemma restore_callee_save_rec_correct:
+ forall l ofs rs k,
+ m |= contains_callee_saves j sp ofs l ls0 ->
agree_unused ls0 rs ->
+ (forall r, In r l -> mreg_within_bounds b r) ->
exists rs',
star step tge
- (State cs fb (Vptr sp Int.zero)
- (restore_callee_save_regs bound number mkindex ty fe l k) rs m)
+ (State cs fb (Vptr sp Int.zero) (restore_callee_save_rec l ofs k) rs m)
E0 (State cs fb (Vptr sp Int.zero) k rs' m)
/\ (forall r, In r l -> Val.inject j (ls0 (R r)) (rs' r))
/\ (forall r, ~(In r l) -> rs' r = rs r)
/\ agree_unused ls0 rs'.
Proof.
- induction l; intros; simpl restore_callee_save_regs.
- (* base case *)
- exists rs. intuition. apply star_refl.
- (* inductive case *)
- assert (R0: In a csregs). apply H; auto with coqlib.
- assert (R1: incl l csregs). eauto with coqlib.
- assert (R2: list_norepet l). inversion H0; auto.
- unfold restore_callee_save_reg.
- destruct (zlt (number a) (bound fe)).
- exploit (mkindex_val a); auto. intros [v [X Y]].
- set (rs1 := Regmap.set a v rs).
- exploit (IHl rs1 k); eauto.
- red; intros. unfold rs1. unfold Regmap.set. destruct (RegEq.eq r a).
- subst r. auto.
- auto.
- intros [rs' [A [B [C D]]]].
- exists rs'. split.
- eapply star_left.
- constructor. rewrite <- (mkindex_typ (number a)). apply index_contains_load_stack. eauto.
- eauto. traceEq.
- split. intros. destruct H2.
- subst r. rewrite C. unfold rs1. rewrite Regmap.gss. auto. inv H0; auto.
- auto.
- split. intros. simpl in H2. rewrite C. unfold rs1. apply Regmap.gso.
- apply sym_not_eq; tauto. tauto.
- auto.
- (* no load takes place *)
- exploit (IHl rs k); auto.
- intros [rs' [A [B [C D]]]].
- exists rs'. split. assumption.
- split. intros. destruct H2.
- subst r. apply D.
- rewrite <- number_within_bounds. auto. auto. auto.
- split. intros. simpl in H2. apply C. tauto.
- auto.
+ induction l as [ | r l]; simpl; intros.
+- (* base case *)
+ exists rs. intuition auto. apply star_refl.
+- (* inductive case *)
+ set (ty := mreg_type r) in *.
+ set (sz := AST.typesize ty) in *.
+ set (ofs1 := align ofs sz).
+ assert (SZPOS: sz > 0) by (apply AST.typesize_pos).
+ assert (OFSLE: ofs <= ofs1) by (apply align_le; auto).
+ assert (BOUND: mreg_within_bounds b r) by eauto.
+ exploit contains_get_stack.
+ eapply sep_proj1; eassumption.
+ intros (v & LOAD & SPEC).
+ exploit (IHl (ofs1 + sz) (rs#r <- v)).
+ eapply sep_proj2; eassumption.
+ red; intros. rewrite Regmap.gso. auto. intuition congruence.
+ eauto.
+ intros (rs' & A & B & C & D).
+ exists rs'.
+ split. eapply star_step; eauto.
+ econstructor. exact LOAD. traceEq.
+ split. intros.
+ destruct (In_dec mreg_eq r0 l). auto.
+ assert (r = r0) by tauto. subst r0.
+ rewrite C by auto. rewrite Regmap.gss. exact SPEC.
+ split. intros.
+ rewrite C by tauto. apply Regmap.gso. intuition auto.
+ exact D.
Qed.
End RESTORE_CALLEE_SAVE.
Lemma restore_callee_save_correct:
- forall j ls ls0 m sp m' sp' pa ra cs fb rs k,
- agree_frame j ls ls0 m sp m' sp' pa ra ->
+ forall m j sp ls ls0 pa ra P rs k cs fb,
+ m |= frame_contents j sp ls ls0 pa ra ** P ->
agree_unused j ls0 rs ->
exists rs',
star step tge
- (State cs fb (Vptr sp' Int.zero) (restore_callee_save fe k) rs m')
- E0 (State cs fb (Vptr sp' Int.zero) k rs' m')
+ (State cs fb (Vptr sp Int.zero) (restore_callee_save fe k) rs m)
+ E0 (State cs fb (Vptr sp Int.zero) k rs' m)
/\ (forall r,
- In r int_callee_save_regs \/ In r float_callee_save_regs ->
- Val.inject j (ls0 (R r)) (rs' r))
+ is_callee_save r = true -> Val.inject j (ls0 (R r)) (rs' r))
/\ (forall r,
- ~(In r int_callee_save_regs) ->
- ~(In r float_callee_save_regs) ->
- rs' r = rs r).
+ is_callee_save r = false -> rs' r = rs r).
Proof.
intros.
- exploit (restore_callee_save_regs_correct
- fe_num_int_callee_save
- index_int_callee_save
- FI_saved_int
- Tany32
- int_callee_save_regs
- j cs fb sp' ls0 m'); auto.
- intros. unfold mreg_within_bounds. split; intros.
- split; auto. destruct (zlt (index_float_callee_save r) 0).
- generalize (bound_float_callee_save_pos b). omega.
- eelim int_float_callee_save_disjoint. eauto.
- eapply index_float_callee_save_pos2. eauto. auto.
- destruct H2; auto.
- eapply agree_saved_int; eauto.
- apply incl_refl.
- apply int_callee_save_norepet.
- eauto.
- intros [rs1 [A [B [C D]]]].
- exploit (restore_callee_save_regs_correct
- fe_num_float_callee_save
- index_float_callee_save
- FI_saved_float
- Tany64
- float_callee_save_regs
- j cs fb sp' ls0 m'); auto.
- intros. unfold mreg_within_bounds. split; intros.
- split; auto. destruct (zlt (index_int_callee_save r) 0).
- generalize (bound_int_callee_save_pos b). omega.
- eelim int_float_callee_save_disjoint.
- eapply index_int_callee_save_pos2. eauto. eauto. auto.
- destruct H2; auto.
- eapply agree_saved_float; eauto.
- apply incl_refl.
- apply float_callee_save_norepet.
- eexact D.
- intros [rs2 [P [Q [R S]]]].
- exists rs2.
- split. unfold restore_callee_save. eapply star_trans; eauto.
- split. intros. destruct H1.
- rewrite R. apply B; auto. red; intros. exploit int_float_callee_save_disjoint; eauto.
- apply Q; auto.
- intros. rewrite R; auto.
+ unfold frame_contents, frame_contents_1 in H.
+ apply mconj_proj1 in H. rewrite ! sep_assoc in H. apply sep_pick5 in H.
+ exploit restore_callee_save_rec_correct; eauto.
+ intros; unfold mreg_within_bounds; auto.
+ intros (rs' & A & B & C & D).
+ exists rs'.
+ split. eexact A.
+ split; intros.
+ destruct (In_dec mreg_eq r (used_callee_save b)).
+ apply B; auto.
+ rewrite C by auto. apply H0. unfold mreg_within_bounds; tauto.
+ apply C. red; intros. apply (used_callee_save_prop b) in H2. congruence.
Qed.
(** As a corollary, we obtain the following correctness result for
@@ -1812,10 +1269,11 @@ Qed.
of the frame). *)
Lemma function_epilogue_correct:
- forall j ls ls0 m sp m' sp' pa ra cs fb rs k m1,
+ forall m' j sp' ls ls0 pa ra P m rs sp m1 k cs fb,
+ m' |= frame_contents j sp' ls ls0 pa ra ** minjection j m ** P ->
agree_regs j ls rs ->
- agree_frame j ls ls0 m sp m' sp' pa ra ->
- Mem.inject j m m' ->
+ agree_locs ls ls0 ->
+ j sp = Some(sp', fe.(fe_stack_data)) ->
Mem.free m sp 0 f.(Linear.fn_stacksize) = Some m1 ->
exists rs1, exists m1',
load_stack m' (Vptr sp' Int.zero) Tint tf.(fn_link_ofs) = Some pa
@@ -1826,268 +1284,138 @@ Lemma function_epilogue_correct:
E0 (State cs fb (Vptr sp' Int.zero) k rs1 m')
/\ agree_regs j (return_regs ls0 ls) rs1
/\ agree_callee_save (return_regs ls0 ls) ls0
- /\ Mem.inject j m1 m1'.
-Proof.
- intros.
- (* can free *)
- destruct (Mem.range_perm_free m' sp' 0 (fn_stacksize tf)) as [m1' FREE].
- rewrite unfold_transf_function; unfold fn_stacksize. red; intros.
- assert (EITHER: fe_stack_data fe <= ofs < fe_stack_data fe + Linear.fn_stacksize f
- \/ (ofs < fe_stack_data fe \/ fe_stack_data fe + Linear.fn_stacksize f <= ofs))
- by omega.
- destruct EITHER.
- replace ofs with ((ofs - fe_stack_data fe) + fe_stack_data fe) by omega.
- eapply Mem.perm_inject with (f := j). eapply agree_inj; eauto. eauto.
- eapply Mem.free_range_perm; eauto. omega.
- eapply agree_perm; eauto.
- (* inject after free *)
- assert (INJ1: Mem.inject j m1 m1').
- eapply Mem.free_inject with (l := (sp, 0, f.(Linear.fn_stacksize)) :: nil); eauto.
- simpl. rewrite H2. auto.
- intros. exploit agree_inj_unique; eauto. intros [P Q]; subst b1 delta.
- exists 0; exists (Linear.fn_stacksize f); split. auto with coqlib.
- eapply agree_bounds. eauto. eapply Mem.perm_max. eauto.
- (* can execute epilogue *)
- exploit restore_callee_save_correct; eauto.
- instantiate (1 := rs). red; intros.
- rewrite <- (agree_unused_reg _ _ _ _ _ _ _ _ _ H0). auto. auto.
- intros [rs1 [A [B C]]].
- (* conclusions *)
- exists rs1; exists m1'.
- split. rewrite unfold_transf_function; unfold fn_link_ofs.
- eapply index_contains_load_stack with (idx := FI_link); eauto with stacking.
- split. rewrite unfold_transf_function; unfold fn_retaddr_ofs.
- eapply index_contains_load_stack with (idx := FI_retaddr); eauto with stacking.
- split. auto.
- split. eexact A.
- split. red; intros. unfold return_regs.
- generalize (register_classification r) (int_callee_save_not_destroyed r) (float_callee_save_not_destroyed r); intros.
- destruct (in_dec mreg_eq r destroyed_at_call).
- rewrite C; auto.
- apply B. intuition.
- split. apply agree_callee_save_return_regs.
- auto.
+ /\ m1' |= minjection j m1 ** P.
+Proof.
+ intros until fb; intros SEP AGR AGL INJ FREE.
+ (* Can free *)
+ exploit free_parallel_rule.
+ rewrite <- sep_assoc. eapply mconj_proj2. eexact SEP.
+ eexact FREE.
+ eexact INJ.
+ auto. rewrite Z.max_comm; reflexivity.
+ intros (m1' & FREE' & SEP').
+ (* Reloading the callee-save registers *)
+ exploit restore_callee_save_correct.
+ eexact SEP.
+ instantiate (1 := rs).
+ red; intros. destruct AGL. rewrite <- agree_unused_reg0 by auto. apply AGR.
+ intros (rs' & LOAD_CS & CS & NCS).
+ (* Reloading the back link and return address *)
+ unfold frame_contents in SEP; apply mconj_proj1 in SEP.
+ unfold frame_contents_1 in SEP; rewrite ! sep_assoc in SEP.
+ exploit (hasvalue_get_stack Tint). eapply sep_pick3; eexact SEP. intros LOAD_LINK.
+ exploit (hasvalue_get_stack Tint). eapply sep_pick4; eexact SEP. intros LOAD_RETADDR.
+ clear SEP.
+ (* Conclusions *)
+ rewrite unfold_transf_function; simpl.
+ exists rs', m1'.
+ split. assumption.
+ split. assumption.
+ split. assumption.
+ split. eassumption.
+ split. red; unfold return_regs; intros.
+ destruct (is_callee_save r) eqn:C.
+ apply CS; auto.
+ rewrite NCS by auto. apply AGR.
+ split. red; unfold return_regs; intros.
+ destruct l; auto. rewrite H; auto.
+ assumption.
Qed.
End FRAME_PROPERTIES.
-(** * Call stack invariant *)
+(** * Call stack invariants *)
-Inductive match_globalenvs (j: meminj) (bound: block) : Prop :=
- | match_globalenvs_intro
- (DOMAIN: forall b, Plt b bound -> j b = Some(b, 0))
- (IMAGE: forall b1 b2 delta, j b1 = Some(b2, delta) -> Plt b2 bound -> b1 = b2)
- (SYMBOLS: forall id b, Genv.find_symbol ge id = Some b -> Plt b bound)
- (FUNCTIONS: forall b fd, Genv.find_funct_ptr ge b = Some fd -> Plt b bound)
- (VARINFOS: forall b gv, Genv.find_var_info ge b = Some gv -> Plt b bound).
+(** This is the memory assertion that captures the contents of the stack frames
+ mentioned in the call stacks. *)
+
+Fixpoint stack_contents (j: meminj) (cs: list Linear.stackframe) (cs': list Mach.stackframe) : massert :=
+ match cs, cs' with
+ | nil, nil => pure True
+ | Linear.Stackframe f _ ls c :: cs, Mach.Stackframe fb (Vptr sp' _) ra c' :: cs' =>
+ frame_contents f j sp' ls (parent_locset cs) (parent_sp cs') (parent_ra cs')
+ ** stack_contents j cs cs'
+ | _, _ => pure False
+ end.
-Inductive match_stacks (j: meminj) (m m': mem):
- list Linear.stackframe -> list stackframe -> signature -> block -> block -> Prop :=
- | match_stacks_empty: forall sg hi bound bound',
- Ple hi bound -> Ple hi bound' -> match_globalenvs j hi ->
+(** [match_stacks] captures additional properties (not related to memory)
+ of the Linear and Mach call stacks. *)
+
+Inductive match_stacks (j: meminj):
+ list Linear.stackframe -> list stackframe -> signature -> Prop :=
+ | match_stacks_empty: forall sg,
tailcall_possible sg ->
- match_stacks j m m' nil nil sg bound bound'
- | match_stacks_cons: forall f sp ls c cs fb sp' ra c' cs' sg bound bound' trf
+ match_stacks j nil nil sg
+ | match_stacks_cons: forall f sp ls c cs fb sp' ra c' cs' sg trf
(TAIL: is_tail c (Linear.fn_code f))
(FINDF: Genv.find_funct_ptr tge fb = Some (Internal trf))
(TRF: transf_function f = OK trf)
(TRC: transl_code (make_env (function_bounds f)) c = c')
+ (INJ: j sp = Some(sp', (fe_stack_data (make_env (function_bounds f)))))
(TY_RA: Val.has_type ra Tint)
- (FRM: agree_frame f j ls (parent_locset cs) m sp m' sp' (parent_sp cs') (parent_ra cs'))
+ (AGL: agree_locs f ls (parent_locset cs))
(ARGS: forall ofs ty,
In (S Outgoing ofs ty) (loc_arguments sg) ->
slot_within_bounds (function_bounds f) Outgoing ofs ty)
- (STK: match_stacks j m m' cs cs' (Linear.fn_sig f) sp sp')
- (BELOW: Plt sp bound)
- (BELOW': Plt sp' bound'),
- match_stacks j m m'
+ (STK: match_stacks j cs cs' (Linear.fn_sig f)),
+ match_stacks j
(Linear.Stackframe f (Vptr sp Int.zero) ls c :: cs)
(Stackframe fb (Vptr sp' Int.zero) ra c' :: cs')
- sg bound bound'.
+ sg.
-(** Invariance with respect to change of bounds. *)
+(** Invariance with respect to change of memory injection. *)
-Lemma match_stacks_change_bounds:
- forall j m1 m' cs cs' sg bound bound',
- match_stacks j m1 m' cs cs' sg bound bound' ->
- forall xbound xbound',
- Ple bound xbound -> Ple bound' xbound' ->
- match_stacks j m1 m' cs cs' sg xbound xbound'.
+Lemma stack_contents_change_meminj:
+ forall m j j', inject_incr j j' ->
+ forall cs cs' P,
+ m |= stack_contents j cs cs' ** P ->
+ m |= stack_contents j' cs cs' ** P.
Proof.
- induction 1; intros.
- apply match_stacks_empty with hi; auto. apply Ple_trans with bound; eauto. apply Ple_trans with bound'; eauto.
- econstructor; eauto. eapply Plt_le_trans; eauto. eapply Plt_le_trans; eauto.
+Local Opaque sepconj.
+ induction cs as [ | [] cs]; destruct cs' as [ | [] cs']; simpl; intros; auto.
+ destruct sp0; auto.
+ rewrite sep_assoc in *.
+ apply frame_contents_incr with (j := j); auto.
+ rewrite sep_swap. apply IHcs. rewrite sep_swap. assumption.
Qed.
-(** Invariance with respect to change of [m]. *)
-
-Lemma match_stacks_change_linear_mem:
- forall j m1 m2 m' cs cs' sg bound bound',
- match_stacks j m1 m' cs cs' sg bound bound' ->
- (forall b, Plt b bound -> Mem.valid_block m1 b -> Mem.valid_block m2 b) ->
- (forall b ofs p, Plt b bound -> Mem.perm m2 b ofs Max p -> Mem.perm m1 b ofs Max p) ->
- match_stacks j m2 m' cs cs' sg bound bound'.
-Proof.
- induction 1; intros.
- econstructor; eauto.
- econstructor; eauto.
- eapply agree_frame_invariant; eauto.
- apply IHmatch_stacks.
- intros. apply H0; auto. apply Plt_trans with sp; auto.
- intros. apply H1. apply Plt_trans with sp; auto. auto.
-Qed.
-
-(** Invariance with respect to change of [m']. *)
-
-Lemma match_stacks_change_mach_mem:
- forall j m m1' m2' cs cs' sg bound bound',
- match_stacks j m m1' cs cs' sg bound bound' ->
- (forall b, Plt b bound' -> Mem.valid_block m1' b -> Mem.valid_block m2' b) ->
- (forall b ofs k p, Plt b bound' -> Mem.perm m1' b ofs k p -> Mem.perm m2' b ofs k p) ->
- (forall chunk b ofs v, Plt b bound' -> Mem.load chunk m1' b ofs = Some v -> Mem.load chunk m2' b ofs = Some v) ->
- match_stacks j m m2' cs cs' sg bound bound'.
-Proof.
- induction 1; intros.
- econstructor; eauto.
- econstructor; eauto.
- eapply agree_frame_invariant; eauto.
- apply IHmatch_stacks.
- intros; apply H0; auto. apply Plt_trans with sp'; auto.
- intros; apply H1; auto. apply Plt_trans with sp'; auto.
- intros; apply H2; auto. apply Plt_trans with sp'; auto.
-Qed.
-
-(** A variant of the latter, for use with external calls *)
-
-Lemma match_stacks_change_mem_extcall:
- forall j m1 m2 m1' m2' cs cs' sg bound bound',
- match_stacks j m1 m1' cs cs' sg bound bound' ->
- (forall b, Plt b bound -> Mem.valid_block m1 b -> Mem.valid_block m2 b) ->
- (forall b ofs p, Plt b bound -> Mem.perm m2 b ofs Max p -> Mem.perm m1 b ofs Max p) ->
- (forall b, Plt b bound' -> Mem.valid_block m1' b -> Mem.valid_block m2' b) ->
- Mem.unchanged_on (loc_out_of_reach j m1) m1' m2' ->
- match_stacks j m2 m2' cs cs' sg bound bound'.
-Proof.
- induction 1; intros.
- econstructor; eauto.
- econstructor; eauto.
- eapply agree_frame_extcall_invariant; eauto.
- apply IHmatch_stacks.
- intros; apply H0; auto. apply Plt_trans with sp; auto.
- intros; apply H1. apply Plt_trans with sp; auto. auto.
- intros; apply H2; auto. apply Plt_trans with sp'; auto.
- auto.
-Qed.
-
-(** Invariance with respect to change of [j]. *)
-
Lemma match_stacks_change_meminj:
- forall j j' m m' m1 m1',
- inject_incr j j' ->
- inject_separated j j' m1 m1' ->
- forall cs cs' sg bound bound',
- match_stacks j m m' cs cs' sg bound bound' ->
- Ple bound' (Mem.nextblock m1') ->
- match_stacks j' m m' cs cs' sg bound bound'.
-Proof.
- induction 3; intros.
- apply match_stacks_empty with hi; auto.
- inv H3. constructor; auto.
- intros. red in H0. case_eq (j b1).
- intros [b' delta'] EQ. rewrite (H _ _ _ EQ) in H3. inv H3. eauto.
- intros EQ. exploit H0; eauto. intros [A B]. elim B. red.
- apply Plt_le_trans with hi. auto. apply Ple_trans with bound'; auto.
- econstructor; eauto.
- eapply agree_frame_inject_incr; eauto. red. eapply Plt_le_trans; eauto.
- apply IHmatch_stacks. apply Ple_trans with bound'; auto. apply Plt_Ple; auto.
-Qed.
-
-(** Preservation by parallel stores in Linear and Mach. *)
-
-Lemma match_stacks_parallel_stores:
- forall j m m' chunk addr addr' v v' m1 m1',
- Mem.inject j m m' ->
- Val.inject j addr addr' ->
- Mem.storev chunk m addr v = Some m1 ->
- Mem.storev chunk m' addr' v' = Some m1' ->
- forall cs cs' sg bound bound',
- match_stacks j m m' cs cs' sg bound bound' ->
- match_stacks j m1 m1' cs cs' sg bound bound'.
+ forall j j', inject_incr j j' ->
+ forall cs cs' sg,
+ match_stacks j cs cs' sg ->
+ match_stacks j' cs cs' sg.
Proof.
- intros until m1'. intros MINJ VINJ STORE1 STORE2.
- induction 1.
- econstructor; eauto.
- econstructor; eauto.
- eapply agree_frame_parallel_stores; eauto.
+ induction 2; intros.
+- constructor; auto.
+- econstructor; eauto.
Qed.
-(** Invariance by external calls. *)
-
-Lemma match_stack_change_extcall:
- forall ec args m1 res t m2 args' m1' res' t' m2' j j',
- external_call ec ge args m1 t res m2 ->
- external_call ec ge args' m1' t' res' m2' ->
- inject_incr j j' ->
- inject_separated j j' m1 m1' ->
- Mem.unchanged_on (loc_out_of_reach j m1) m1' m2' ->
- forall cs cs' sg bound bound',
- match_stacks j m1 m1' cs cs' sg bound bound' ->
- Ple bound (Mem.nextblock m1) -> Ple bound' (Mem.nextblock m1') ->
- match_stacks j' m2 m2' cs cs' sg bound bound'.
-Proof.
- intros.
- eapply match_stacks_change_meminj; eauto.
- eapply match_stacks_change_mem_extcall; eauto.
- intros; eapply external_call_valid_block; eauto.
- intros; eapply external_call_max_perm; eauto. red. eapply Plt_le_trans; eauto.
- intros; eapply external_call_valid_block; eauto.
-Qed.
-
-(** Invariance with respect to change of signature *)
+(** Invariance with respect to change of signature. *)
Lemma match_stacks_change_sig:
- forall sg1 j m m' cs cs' sg bound bound',
- match_stacks j m m' cs cs' sg bound bound' ->
+ forall sg1 j cs cs' sg,
+ match_stacks j cs cs' sg ->
tailcall_possible sg1 ->
- match_stacks j m m' cs cs' sg1 bound bound'.
+ match_stacks j cs cs' sg1.
Proof.
induction 1; intros.
econstructor; eauto.
econstructor; eauto. intros. elim (H0 _ H1).
Qed.
-(** [match_stacks] implies [match_globalenvs], which implies [meminj_preserves_globals]. *)
-
-Lemma match_stacks_globalenvs:
- forall j m m' cs cs' sg bound bound',
- match_stacks j m m' cs cs' sg bound bound' ->
- exists hi, match_globalenvs j hi.
-Proof.
- induction 1. exists hi; auto. auto.
-Qed.
-
-Lemma match_stacks_preserves_globals:
- forall j m m' cs cs' sg bound bound',
- match_stacks j m m' cs cs' sg bound bound' ->
- meminj_preserves_globals ge j.
-Proof.
- intros. exploit match_stacks_globalenvs; eauto. intros [hi MG]. inv MG.
- split. eauto. split. eauto. intros. symmetry. eauto.
-Qed.
-
(** Typing properties of [match_stacks]. *)
Lemma match_stacks_type_sp:
- forall j m m' cs cs' sg bound bound',
- match_stacks j m m' cs cs' sg bound bound' ->
+ forall j cs cs' sg,
+ match_stacks j cs cs' sg ->
Val.has_type (parent_sp cs') Tint.
Proof.
induction 1; simpl; auto.
Qed.
Lemma match_stacks_type_retaddr:
- forall j m m' cs cs' sg bound bound',
- match_stacks j m m' cs cs' sg bound bound' ->
+ forall j cs cs' sg,
+ match_stacks j cs cs' sg ->
Val.has_type (parent_ra cs') Tint.
Proof.
induction 1; simpl; auto.
@@ -2099,41 +1427,18 @@ Qed.
Section LABELS.
-Remark find_label_fold_right:
- forall (A: Type) (fn: A -> Mach.code -> Mach.code) lbl,
- (forall x k, Mach.find_label lbl (fn x k) = Mach.find_label lbl k) -> forall (args: list A) k,
- Mach.find_label lbl (List.fold_right fn k args) = Mach.find_label lbl k.
-Proof.
- induction args; simpl. auto.
- intros. rewrite H. auto.
-Qed.
-
Remark find_label_save_callee_save:
- forall fe lbl k,
- Mach.find_label lbl (save_callee_save fe k) = Mach.find_label lbl k.
+ forall lbl l ofs k,
+ Mach.find_label lbl (save_callee_save_rec l ofs k) = Mach.find_label lbl k.
Proof.
- intros. unfold save_callee_save, save_callee_save_int, save_callee_save_float, save_callee_save_regs.
- repeat rewrite find_label_fold_right. reflexivity.
- intros. unfold save_callee_save_reg.
- case (zlt (index_float_callee_save x) (fe_num_float_callee_save fe));
- intro; reflexivity.
- intros. unfold save_callee_save_reg.
- case (zlt (index_int_callee_save x) (fe_num_int_callee_save fe));
- intro; reflexivity.
+ induction l; simpl; auto.
Qed.
Remark find_label_restore_callee_save:
- forall fe lbl k,
- Mach.find_label lbl (restore_callee_save fe k) = Mach.find_label lbl k.
+ forall lbl l ofs k,
+ Mach.find_label lbl (restore_callee_save_rec l ofs k) = Mach.find_label lbl k.
Proof.
- intros. unfold restore_callee_save, restore_callee_save_int, restore_callee_save_float, restore_callee_save_regs.
- repeat rewrite find_label_fold_right. reflexivity.
- intros. unfold restore_callee_save_reg.
- case (zlt (index_float_callee_save x) (fe_num_float_callee_save fe));
- intro; reflexivity.
- intros. unfold restore_callee_save_reg.
- case (zlt (index_int_callee_save x) (fe_num_int_callee_save fe));
- intro; reflexivity.
+ induction l; simpl; auto.
Qed.
Lemma transl_code_eq:
@@ -2148,14 +1453,14 @@ Lemma find_label_transl_code:
option_map (transl_code fe) (Linear.find_label lbl c).
Proof.
induction c; simpl; intros.
- auto.
- rewrite transl_code_eq.
+- auto.
+- rewrite transl_code_eq.
destruct a; unfold transl_instr; auto.
destruct s; simpl; auto.
destruct s; simpl; auto.
- rewrite find_label_restore_callee_save. auto.
- simpl. case (peq lbl l); intro. reflexivity. auto.
- rewrite find_label_restore_callee_save. auto.
+ unfold restore_callee_save. rewrite find_label_restore_callee_save. auto.
+ simpl. destruct (peq lbl l). reflexivity. auto.
+ unfold restore_callee_save. rewrite find_label_restore_callee_save. auto.
Qed.
Lemma transl_find_label:
@@ -2166,7 +1471,7 @@ Lemma transl_find_label:
Some (transl_code (make_env (function_bounds f)) c).
Proof.
intros. rewrite (unfold_transf_function _ _ H). simpl.
- unfold transl_body. rewrite find_label_save_callee_save.
+ unfold transl_body. unfold save_callee_save. rewrite find_label_save_callee_save.
rewrite find_label_transl_code. rewrite H0. reflexivity.
Qed.
@@ -2187,38 +1492,20 @@ Qed.
(** Code tail property for translations *)
-Lemma is_tail_save_callee_save_regs:
- forall bound number mkindex ty fe csl k,
- is_tail k (save_callee_save_regs bound number mkindex ty fe csl k).
-Proof.
- induction csl; intros; simpl. auto with coqlib.
- unfold save_callee_save_reg. destruct (zlt (number a) (bound fe)).
- constructor; auto. auto.
-Qed.
-
Lemma is_tail_save_callee_save:
- forall fe k,
- is_tail k (save_callee_save fe k).
-Proof.
- intros. unfold save_callee_save, save_callee_save_int, save_callee_save_float.
- eapply is_tail_trans; apply is_tail_save_callee_save_regs.
-Qed.
-
-Lemma is_tail_restore_callee_save_regs:
- forall bound number mkindex ty fe csl k,
- is_tail k (restore_callee_save_regs bound number mkindex ty fe csl k).
+ forall l ofs k,
+ is_tail k (save_callee_save_rec l ofs k).
Proof.
- induction csl; intros; simpl. auto with coqlib.
- unfold restore_callee_save_reg. destruct (zlt (number a) (bound fe)).
- constructor; auto. auto.
+ induction l; intros; simpl. auto with coqlib.
+ constructor; auto.
Qed.
Lemma is_tail_restore_callee_save:
- forall fe k,
- is_tail k (restore_callee_save fe k).
+ forall l ofs k,
+ is_tail k (restore_callee_save_rec l ofs k).
Proof.
- intros. unfold restore_callee_save, restore_callee_save_int, restore_callee_save_float.
- eapply is_tail_trans; apply is_tail_restore_callee_save_regs.
+ induction l; intros; simpl. auto with coqlib.
+ constructor; auto.
Qed.
Lemma is_tail_transl_instr:
@@ -2228,8 +1515,8 @@ Proof.
intros. destruct i; unfold transl_instr; auto with coqlib.
destruct s; auto with coqlib.
destruct s; auto with coqlib.
- eapply is_tail_trans. 2: apply is_tail_restore_callee_save. auto with coqlib.
- eapply is_tail_trans. 2: apply is_tail_restore_callee_save. auto with coqlib.
+ unfold restore_callee_save. eapply is_tail_trans. 2: apply is_tail_restore_callee_save. auto with coqlib.
+ unfold restore_callee_save. eapply is_tail_trans. 2: apply is_tail_restore_callee_save. auto with coqlib.
Qed.
Lemma is_tail_transl_code:
@@ -2247,7 +1534,8 @@ Lemma is_tail_transf_function:
is_tail (transl_code (make_env (function_bounds f)) c) (fn_code tf).
Proof.
intros. rewrite (unfold_transf_function _ _ H). simpl.
- unfold transl_body. eapply is_tail_trans. 2: apply is_tail_save_callee_save.
+ unfold transl_body, save_callee_save.
+ eapply is_tail_trans. 2: apply is_tail_save_callee_save.
apply is_tail_transl_code; auto.
Qed.
@@ -2287,25 +1575,24 @@ Proof.
Qed.
Lemma find_function_translated:
- forall j ls rs m m' cs cs' sg bound bound' ros f,
+ forall j ls rs m ros f,
agree_regs j ls rs ->
- match_stacks j m m' cs cs' sg bound bound' ->
+ m |= globalenv_inject ge j ->
Linear.find_function ge ros ls = Some f ->
exists bf, exists tf,
find_function_ptr tge ros rs = Some bf
/\ Genv.find_funct_ptr tge bf = Some tf
/\ transf_fundef f = OK tf.
Proof.
- intros until f; intros AG MS FF.
- exploit match_stacks_globalenvs; eauto. intros [hi MG].
+ intros until f; intros AG [bound [_ []]] FF.
destruct ros; simpl in FF.
- exploit Genv.find_funct_inv; eauto. intros [b EQ]. rewrite EQ in FF.
+- exploit Genv.find_funct_inv; eauto. intros [b EQ]. rewrite EQ in FF.
rewrite Genv.find_funct_find_funct_ptr in FF.
exploit function_ptr_translated; eauto. intros [tf [A B]].
exists b; exists tf; split; auto. simpl.
generalize (AG m0). rewrite EQ. intro INJ. inv INJ.
- inv MG. rewrite DOMAIN in H2. inv H2. simpl. auto. eapply FUNCTIONS; eauto.
- destruct (Genv.find_symbol ge i) as [b|] eqn:?; try discriminate.
+ rewrite DOMAIN in H2. inv H2. simpl. auto. eapply FUNCTIONS; eauto.
+- destruct (Genv.find_symbol ge i) as [b|] eqn:?; try discriminate.
exploit function_ptr_translated; eauto. intros [tf [A B]].
exists b; exists tf; split; auto. simpl.
rewrite symbols_preserved. auto.
@@ -2316,16 +1603,17 @@ Qed.
Section EXTERNAL_ARGUMENTS.
Variable j: meminj.
-Variables m m': mem.
Variable cs: list Linear.stackframe.
Variable cs': list stackframe.
Variable sg: signature.
Variables bound bound': block.
-Hypothesis MS: match_stacks j m m' cs cs' sg bound bound'.
+Hypothesis MS: match_stacks j cs cs' sg.
Variable ls: locset.
Variable rs: regset.
Hypothesis AGR: agree_regs j ls rs.
Hypothesis AGCS: agree_callee_save ls (parent_locset cs).
+Variable m': mem.
+Hypothesis SEP: m' |= stack_contents j cs cs'.
Lemma transl_external_argument:
forall l,
@@ -2333,24 +1621,20 @@ Lemma transl_external_argument:
exists v, extcall_arg rs m' (parent_sp cs') l v /\ Val.inject j (ls l) v.
Proof.
intros.
- assert (loc_argument_acceptable l). apply loc_arguments_acceptable with sg; auto.
+ assert (loc_argument_acceptable l) by (apply loc_arguments_acceptable with sg; auto).
destruct l; red in H0.
- exists (rs r); split. constructor. auto.
- destruct sl; try contradiction.
+- exists (rs r); split. constructor. auto.
+- destruct sl; try contradiction.
inv MS.
- elim (H4 _ H).
- unfold parent_sp.
++ elim (H1 _ H).
++ simpl in SEP. unfold parent_sp.
assert (slot_valid f Outgoing pos ty = true).
- exploit loc_arguments_acceptable; eauto. intros [A B].
- unfold slot_valid. unfold proj_sumbool. rewrite zle_true by omega.
- destruct ty; auto; congruence.
- assert (slot_within_bounds (function_bounds f) Outgoing pos ty).
- eauto.
- exploit agree_outgoing; eauto. intros [v [A B]].
+ { destruct H0. unfold slot_valid, proj_sumbool.
+ rewrite zle_true by omega. rewrite pred_dec_true by auto. reflexivity. }
+ assert (slot_within_bounds (function_bounds f) Outgoing pos ty) by eauto.
+ exploit frame_get_outgoing; eauto. intros (v & A & B).
exists v; split.
- constructor.
- eapply index_contains_load_stack with (idx := FI_arg pos ty); eauto.
- red in AGCS. rewrite AGCS; auto.
+ constructor. exact A. red in AGCS. rewrite AGCS; auto.
Qed.
Lemma transl_external_arguments_rec:
@@ -2393,10 +1677,9 @@ Variables ls ls0: locset.
Variable rs: regset.
Variables sp sp': block.
Variables parent retaddr: val.
+Hypothesis INJ: j sp = Some(sp', fe.(fe_stack_data)).
Hypothesis AGR: agree_regs j ls rs.
-Hypothesis AGF: agree_frame f j ls ls0 m sp m' sp' parent retaddr.
-Hypothesis MINJ: Mem.inject j m m'.
-Hypothesis GINJ: meminj_preserves_globals ge j.
+Hypothesis SEP: m' |= frame_contents f j sp' ls ls0 parent retaddr ** minjection j m ** globalenv_inject ge j.
Lemma transl_builtin_arg_correct:
forall a v,
@@ -2407,35 +1690,33 @@ Lemma transl_builtin_arg_correct:
eval_builtin_arg ge rs (Vptr sp' Int.zero) m' (transl_builtin_arg fe a) v'
/\ Val.inject j v v'.
Proof.
-Local Opaque fe offset_of_index.
+ assert (SYMB: forall id ofs, Val.inject j (Senv.symbol_address ge id ofs) (Senv.symbol_address ge id ofs)).
+ { assert (G: meminj_preserves_globals ge j).
+ { eapply globalenv_inject_preserves_globals. eapply sep_proj2. eapply sep_proj2. eexact SEP. }
+ intros; unfold Senv.symbol_address; simpl; unfold Genv.symbol_address.
+ destruct (Genv.find_symbol ge id) eqn:FS; auto.
+ destruct G. econstructor. eauto. rewrite Int.add_zero; auto. }
+Local Opaque fe.
induction 1; simpl; intros VALID BOUNDS.
- assert (loc_valid f x = true) by auto.
destruct x as [r | [] ofs ty]; try discriminate.
+ exists (rs r); auto with barg.
- + exploit agree_locals; eauto. intros [v [A B]]. inv A.
- exists v; split; auto. constructor. simpl. rewrite Int.add_zero_l.
-Local Transparent fe.
- unfold fe, b. erewrite offset_of_index_no_overflow by eauto. exact H1.
+ + exploit frame_get_local; eauto. intros (v & A & B).
+ exists v; split; auto. constructor; auto.
- econstructor; eauto with barg.
- econstructor; eauto with barg.
- econstructor; eauto with barg.
- econstructor; eauto with barg.
-- simpl in H. exploit Mem.load_inject; eauto. eapply agree_inj; eauto.
- intros (v' & A & B). exists v'; split; auto. constructor.
- unfold Mem.loadv, Val.add. rewrite <- Int.add_assoc.
- unfold fe, b; erewrite shifted_stack_offset_no_overflow; eauto.
- eapply agree_bounds; eauto. eapply Mem.valid_access_perm. eapply Mem.load_valid_access; eauto.
-- econstructor; split; eauto with barg.
- unfold Val.add. rewrite ! Int.add_zero_l. econstructor. eapply agree_inj; eauto. auto.
-- assert (Val.inject j (Senv.symbol_address ge id ofs) (Senv.symbol_address ge id ofs)).
- { unfold Senv.symbol_address; simpl; unfold Genv.symbol_address.
- destruct (Genv.find_symbol ge id) eqn:FS; auto.
- econstructor. eapply (proj1 GINJ); eauto. rewrite Int.add_zero; auto. }
- exploit Mem.loadv_inject; eauto. intros (v' & A & B). exists v'; auto with barg.
+- set (ofs' := Int.add ofs (Int.repr (fe_stack_data fe))).
+ apply sep_proj2 in SEP. apply sep_proj1 in SEP. exploit loadv_parallel_rule; eauto.
+ instantiate (1 := Val.add (Vptr sp' Int.zero) (Vint ofs')).
+ simpl. rewrite ! Int.add_zero_l. econstructor; eauto.
+ intros (v' & A & B). exists v'; split; auto. constructor; auto.
- econstructor; split; eauto with barg.
- unfold Senv.symbol_address; simpl; unfold Genv.symbol_address.
- destruct (Genv.find_symbol ge id) eqn:FS; auto.
- econstructor. eapply (proj1 GINJ); eauto. rewrite Int.add_zero; auto.
+ unfold Val.add. rewrite ! Int.add_zero_l. econstructor; eauto.
+- apply sep_proj2 in SEP. apply sep_proj1 in SEP. exploit loadv_parallel_rule; eauto.
+ intros (v' & A & B). exists v'; auto with barg.
+- econstructor; split; eauto with barg.
- destruct IHeval_builtin_arg1 as (v1 & A1 & B1); auto using in_or_app.
destruct IHeval_builtin_arg2 as (v2 & A2 & B2); auto using in_or_app.
exists (Val.longofwords v1 v2); split; auto with barg.
@@ -2472,44 +1753,56 @@ End BUILTIN_ARGUMENTS.
>>
Matching between source and target states is defined by [match_states]
below. It implies:
+- Satisfaction of the separation logic assertions that describe the contents
+ of memory. This is a separating conjunction of facts about:
+-- the current stack frame
+-- the frames in the call stack
+-- the injection from the Linear memory state into the Mach memory state
+-- the preservation of the global environment.
- Agreement between, on the Linear side, the location sets [ls]
and [parent_locset s] of the current function and its caller,
- and on the Mach side the register set [rs] and the contents of
- the memory area corresponding to the stack frame.
+ and on the Mach side the register set [rs].
- The Linear code [c] is a suffix of the code of the
function [f] being executed.
-- Memory injection between the Linear and the Mach memory states.
- Well-typedness of [f].
*)
Inductive match_states: Linear.state -> Mach.state -> Prop :=
| match_states_intro:
forall cs f sp c ls m cs' fb sp' rs m' j tf
- (MINJ: Mem.inject j m m')
- (STACKS: match_stacks j m m' cs cs' f.(Linear.fn_sig) sp sp')
+ (STACKS: match_stacks j cs cs' f.(Linear.fn_sig))
(TRANSL: transf_function f = OK tf)
(FIND: Genv.find_funct_ptr tge fb = Some (Internal tf))
(AGREGS: agree_regs j ls rs)
- (AGFRAME: agree_frame f j ls (parent_locset cs) m sp m' sp' (parent_sp cs') (parent_ra cs'))
- (TAIL: is_tail c (Linear.fn_code f)),
+ (AGLOCS: agree_locs f ls (parent_locset cs))
+ (INJSP: j sp = Some(sp', fe_stack_data (make_env (function_bounds f))))
+ (TAIL: is_tail c (Linear.fn_code f))
+ (SEP: m' |= frame_contents f j sp' ls (parent_locset cs) (parent_sp cs') (parent_ra cs')
+ ** stack_contents j cs cs'
+ ** minjection j m
+ ** globalenv_inject ge j),
match_states (Linear.State cs f (Vptr sp Int.zero) c ls m)
- (Mach.State cs' fb (Vptr sp' Int.zero) (transl_code (make_env (function_bounds f)) c) rs m')
+ (Mach.State cs' fb (Vptr sp' Int.zero) (transl_code (make_env (function_bounds f)) c) rs m')
| match_states_call:
forall cs f ls m cs' fb rs m' j tf
- (MINJ: Mem.inject j m m')
- (STACKS: match_stacks j m m' cs cs' (Linear.funsig f) (Mem.nextblock m) (Mem.nextblock m'))
+ (STACKS: match_stacks j cs cs' (Linear.funsig f))
(TRANSL: transf_fundef f = OK tf)
(FIND: Genv.find_funct_ptr tge fb = Some tf)
(AGREGS: agree_regs j ls rs)
- (AGLOCS: agree_callee_save ls (parent_locset cs)),
+ (AGLOCS: agree_callee_save ls (parent_locset cs))
+ (SEP: m' |= stack_contents j cs cs'
+ ** minjection j m
+ ** globalenv_inject ge j),
match_states (Linear.Callstate cs f ls m)
- (Mach.Callstate cs' fb rs m')
+ (Mach.Callstate cs' fb rs m')
| match_states_return:
forall cs ls m cs' rs m' j sg
- (MINJ: Mem.inject j m m')
- (STACKS: match_stacks j m m' cs cs' sg (Mem.nextblock m) (Mem.nextblock m'))
+ (STACKS: match_stacks j cs cs' sg)
(AGREGS: agree_regs j ls rs)
- (AGLOCS: agree_callee_save ls (parent_locset cs)),
+ (AGLOCS: agree_callee_save ls (parent_locset cs))
+ (SEP: m' |= stack_contents j cs cs'
+ ** minjection j m
+ ** globalenv_inject ge j),
match_states (Linear.Returnstate cs ls m)
(Mach.Returnstate cs' rs m').
@@ -2518,13 +1811,6 @@ Theorem transf_step_correct:
forall (WTS: wt_state s1) s1' (MS: match_states s1 s1'),
exists s2', plus step tge s1' t s2' /\ match_states s2 s2'.
Proof.
-(*
- assert (USEWTF: forall f i c,
- wt_function f = true -> is_tail (i :: c) (Linear.fn_code f) ->
- wt_instr f i = true).
- intros. unfold wt_function, wt_code in H. rewrite forallb_forall in H.
- apply H. eapply is_tail_in; eauto.
-*)
induction 1; intros;
try inv MS;
try rewrite transl_code_eq;
@@ -2533,98 +1819,78 @@ Proof.
unfold transl_instr.
- (* Lgetstack *)
- destruct BOUND.
+ destruct BOUND as [BOUND1 BOUND2].
exploit wt_state_getstack; eauto. intros SV.
unfold destroyed_by_getstack; destruct sl.
+ (* Lgetstack, local *)
- exploit agree_locals; eauto. intros [v [A B]].
+ exploit frame_get_local; eauto. intros (v & A & B).
econstructor; split.
- apply plus_one. apply exec_Mgetstack.
- eapply index_contains_load_stack; eauto.
+ apply plus_one. apply exec_Mgetstack. exact A.
econstructor; eauto with coqlib.
apply agree_regs_set_reg; auto.
- apply agree_frame_set_reg; auto.
+ apply agree_locs_set_reg; auto.
+ (* Lgetstack, incoming *)
unfold slot_valid in SV. InvBooleans.
exploit incoming_slot_in_parameters; eauto. intros IN_ARGS.
inversion STACKS; clear STACKS.
- elim (H6 _ IN_ARGS).
- subst bound bound' s cs'.
- exploit agree_outgoing. eexact FRM. eapply ARGS; eauto.
- exploit loc_arguments_acceptable; eauto. intros [A B].
- unfold slot_valid, proj_sumbool. rewrite zle_true.
- destruct ty; reflexivity || congruence. omega.
- intros [v [A B]].
+ elim (H1 _ IN_ARGS).
+ subst s cs'.
+ exploit frame_get_outgoing.
+ apply sep_proj2 in SEP. simpl in SEP. rewrite sep_assoc in SEP. eexact SEP.
+ eapply ARGS; eauto.
+ eapply slot_outgoing_argument_valid; eauto.
+ intros (v & A & B).
econstructor; split.
- apply plus_one. eapply exec_Mgetparam; eauto.
+ apply plus_one. eapply exec_Mgetparam; eauto.
rewrite (unfold_transf_function _ _ TRANSL). unfold fn_link_ofs.
- eapply index_contains_load_stack with (idx := FI_link). eapply TRANSL. eapply agree_link; eauto.
- simpl parent_sp.
- change (offset_of_index (make_env (function_bounds f)) (FI_arg ofs ty))
- with (offset_of_index (make_env (function_bounds f0)) (FI_arg ofs ty)).
- eapply index_contains_load_stack with (idx := FI_arg ofs ty). eauto. eauto.
- exploit agree_incoming; eauto. intros EQ; simpl in EQ.
+ eapply frame_get_parent. eexact SEP.
econstructor; eauto with coqlib. econstructor; eauto.
- apply agree_regs_set_reg. apply agree_regs_set_reg. auto. auto. congruence.
- eapply agree_frame_set_reg; eauto. eapply agree_frame_set_reg; eauto.
- apply caller_save_reg_within_bounds.
- apply temp_for_parent_frame_caller_save.
+ apply agree_regs_set_reg. apply agree_regs_set_reg. auto. auto.
+ erewrite agree_incoming by eauto. exact B.
+ apply agree_locs_set_reg; auto. apply agree_locs_undef_locs; auto.
+ (* Lgetstack, outgoing *)
- exploit agree_outgoing; eauto. intros [v [A B]].
+ exploit frame_get_outgoing; eauto. intros (v & A & B).
econstructor; split.
- apply plus_one. apply exec_Mgetstack.
- eapply index_contains_load_stack; eauto.
+ apply plus_one. apply exec_Mgetstack. exact A.
econstructor; eauto with coqlib.
apply agree_regs_set_reg; auto.
- apply agree_frame_set_reg; auto.
+ apply agree_locs_set_reg; auto.
- (* Lsetstack *)
exploit wt_state_setstack; eauto. intros (SV & SW).
- set (idx := match sl with
- | Local => FI_local ofs ty
- | Incoming => FI_link (*dummy*)
- | Outgoing => FI_arg ofs ty
- end).
- assert (index_valid f idx).
- { unfold idx; destruct sl.
- apply index_local_valid; auto.
- red; auto.
- apply index_arg_valid; auto. }
- exploit store_index_succeeds; eauto. eapply agree_perm; eauto.
- instantiate (1 := rs0 src). intros [m1' STORE].
+ set (ofs' := match sl with
+ | Local => offset_local (make_env (function_bounds f)) ofs
+ | Incoming => 0 (* dummy *)
+ | Outgoing => offset_arg ofs
+ end).
+ eapply frame_undef_regs with (rl := destroyed_by_setstack ty) in SEP.
+ assert (A: exists m'',
+ store_stack m' (Vptr sp' Int.zero) ty (Int.repr ofs') (rs0 src) = Some m''
+ /\ m'' |= frame_contents f j sp' (Locmap.set (S sl ofs ty) (rs (R src))
+ (LTL.undef_regs (destroyed_by_setstack ty) rs))
+ (parent_locset s) (parent_sp cs') (parent_ra cs')
+ ** stack_contents j s cs' ** minjection j m ** globalenv_inject ge j).
+ { unfold ofs'; destruct sl; try discriminate.
+ eapply frame_set_local; eauto.
+ eapply frame_set_outgoing; eauto. }
+ clear SEP; destruct A as (m'' & STORE & SEP).
econstructor; split.
- apply plus_one. destruct sl; simpl in SW.
- econstructor. eapply store_stack_succeeds with (idx := idx); eauto. eauto.
- discriminate.
- econstructor. eapply store_stack_succeeds with (idx := idx); eauto. auto.
- econstructor.
- eapply Mem.store_outside_inject; eauto.
- intros. exploit agree_inj_unique; eauto. intros [EQ1 EQ2]; subst b' delta.
- rewrite size_type_chunk in H2.
- exploit offset_of_index_disj_stack_data_2; eauto.
- exploit agree_bounds. eauto. apply Mem.perm_cur_max. eauto.
- omega.
- apply match_stacks_change_mach_mem with m'; auto.
- eauto with mem. eauto with mem. intros. rewrite <- H1; eapply Mem.load_store_other; eauto. left; apply Plt_ne; auto.
- eauto. eauto.
- apply agree_regs_set_slot. apply agree_regs_undef_regs; auto.
- destruct sl.
- + eapply agree_frame_set_local. eapply agree_frame_undef_locs; eauto.
- apply destroyed_by_setstack_caller_save. auto. auto. auto.
- assumption.
- + simpl in SW; discriminate.
- + eapply agree_frame_set_outgoing. eapply agree_frame_undef_locs; eauto.
- apply destroyed_by_setstack_caller_save. auto. auto. auto.
- assumption.
- + eauto with coqlib.
+ apply plus_one. destruct sl; try discriminate.
+ econstructor. eexact STORE. eauto.
+ econstructor. eexact STORE. eauto.
+ econstructor. eauto. eauto. eauto.
+ apply agree_regs_set_slot. apply agree_regs_undef_regs. auto.
+ apply agree_locs_set_slot. apply agree_locs_undef_locs. auto. apply destroyed_by_setstack_caller_save. auto.
+ eauto. eauto with coqlib. eauto.
- (* Lop *)
assert (exists v',
eval_operation ge (Vptr sp' Int.zero) (transl_op (make_env (function_bounds f)) op) rs0##args m' = Some v'
/\ Val.inject j v v').
eapply eval_operation_inject; eauto.
- eapply match_stacks_preserves_globals; eauto.
- eapply agree_inj; eauto. eapply agree_reglist; eauto.
+ eapply globalenv_inject_preserves_globals. eapply sep_proj2. eapply sep_proj2. eapply sep_proj2. eexact SEP.
+ eapply agree_reglist; eauto.
+ apply sep_proj2 in SEP. apply sep_proj2 in SEP. apply sep_proj1 in SEP. exact SEP.
destruct H0 as [v' [A B]].
econstructor; split.
apply plus_one. econstructor.
@@ -2633,56 +1899,58 @@ Proof.
econstructor; eauto with coqlib.
apply agree_regs_set_reg; auto.
rewrite transl_destroyed_by_op. apply agree_regs_undef_regs; auto.
- apply agree_frame_set_reg; auto. apply agree_frame_undef_locs; auto.
- apply destroyed_by_op_caller_save.
+ apply agree_locs_set_reg; auto. apply agree_locs_undef_locs. auto. apply destroyed_by_op_caller_save.
+ apply frame_set_reg. apply frame_undef_regs. exact SEP.
- (* Lload *)
assert (exists a',
eval_addressing ge (Vptr sp' Int.zero) (transl_addr (make_env (function_bounds f)) addr) rs0##args = Some a'
/\ Val.inject j a a').
eapply eval_addressing_inject; eauto.
- eapply match_stacks_preserves_globals; eauto.
- eapply agree_inj; eauto. eapply agree_reglist; eauto.
+ eapply globalenv_inject_preserves_globals. eapply sep_proj2. eapply sep_proj2. eapply sep_proj2. eexact SEP.
+ eapply agree_reglist; eauto.
destruct H1 as [a' [A B]].
- exploit Mem.loadv_inject; eauto. intros [v' [C D]].
+ exploit loadv_parallel_rule.
+ apply sep_proj2 in SEP. apply sep_proj2 in SEP. apply sep_proj1 in SEP. eexact SEP.
+ eauto. eauto.
+ intros [v' [C D]].
econstructor; split.
apply plus_one. econstructor.
instantiate (1 := a'). rewrite <- A. apply eval_addressing_preserved. exact symbols_preserved.
eexact C. eauto.
econstructor; eauto with coqlib.
apply agree_regs_set_reg. rewrite transl_destroyed_by_load. apply agree_regs_undef_regs; auto. auto.
- apply agree_frame_set_reg. apply agree_frame_undef_locs; auto.
- apply destroyed_by_load_caller_save. auto.
+ apply agree_locs_set_reg. apply agree_locs_undef_locs. auto. apply destroyed_by_load_caller_save. auto.
- (* Lstore *)
assert (exists a',
eval_addressing ge (Vptr sp' Int.zero) (transl_addr (make_env (function_bounds f)) addr) rs0##args = Some a'
/\ Val.inject j a a').
eapply eval_addressing_inject; eauto.
- eapply match_stacks_preserves_globals; eauto.
- eapply agree_inj; eauto. eapply agree_reglist; eauto.
+ eapply globalenv_inject_preserves_globals. eapply sep_proj2. eapply sep_proj2. eapply sep_proj2. eexact SEP.
+ eapply agree_reglist; eauto.
destruct H1 as [a' [A B]].
- exploit Mem.storev_mapped_inject; eauto. intros [m1' [C D]].
+ rewrite sep_swap3 in SEP.
+ exploit storev_parallel_rule. eexact SEP. eauto. eauto. apply AGREGS.
+ clear SEP; intros (m1' & C & SEP).
+ rewrite sep_swap3 in SEP.
econstructor; split.
apply plus_one. econstructor.
instantiate (1 := a'). rewrite <- A. apply eval_addressing_preserved. exact symbols_preserved.
eexact C. eauto.
- econstructor. eauto.
- eapply match_stacks_parallel_stores. eexact MINJ. eexact B. eauto. eauto. auto.
- eauto. eauto.
- rewrite transl_destroyed_by_store.
- apply agree_regs_undef_regs; auto.
- apply agree_frame_undef_locs; auto.
- eapply agree_frame_parallel_stores; eauto.
- apply destroyed_by_store_caller_save.
- eauto with coqlib.
+ econstructor. eauto. eauto. eauto.
+ rewrite transl_destroyed_by_store. apply agree_regs_undef_regs; auto.
+ apply agree_locs_undef_locs. auto. apply destroyed_by_store_caller_save.
+ auto. eauto with coqlib.
+ eapply frame_undef_regs; eauto.
- (* Lcall *)
- exploit find_function_translated; eauto. intros [bf [tf' [A [B C]]]].
+ exploit find_function_translated; eauto.
+ eapply sep_proj2. eapply sep_proj2. eapply sep_proj2. eexact SEP.
+ intros [bf [tf' [A [B C]]]].
exploit is_tail_transf_function; eauto. intros IST.
rewrite transl_code_eq in IST. simpl in IST.
- exploit return_address_offset_exists. eexact IST.
- intros [ra D].
+ exploit return_address_offset_exists. eexact IST. intros [ra D].
econstructor; split.
apply plus_one. econstructor; eauto.
econstructor; eauto.
@@ -2691,54 +1959,45 @@ Proof.
intros; red.
apply Zle_trans with (size_arguments (Linear.funsig f')); auto.
apply loc_arguments_bounded; auto.
- eapply agree_valid_linear; eauto.
- eapply agree_valid_mach; eauto.
simpl; red; auto.
+ simpl. rewrite sep_assoc. exact SEP.
- (* Ltailcall *)
+ rewrite (sep_swap (stack_contents j s cs')) in SEP.
exploit function_epilogue_correct; eauto.
- intros [rs1 [m1' [P [Q [R [S [T [U V]]]]]]]].
- exploit find_function_translated; eauto. intros [bf [tf' [A [B C]]]].
+ clear SEP. intros (rs1 & m1' & P & Q & R & S & T & U & SEP).
+ rewrite sep_swap in SEP.
+ exploit find_function_translated; eauto.
+ eapply sep_proj2. eapply sep_proj2. eexact SEP.
+ intros [bf [tf' [A [B C]]]].
econstructor; split.
eapply plus_right. eexact S. econstructor; eauto. traceEq.
econstructor; eauto.
apply match_stacks_change_sig with (Linear.fn_sig f); auto.
- apply match_stacks_change_bounds with stk sp'.
- apply match_stacks_change_linear_mem with m.
- apply match_stacks_change_mach_mem with m'0.
- auto.
- eauto with mem. intros. eapply Mem.perm_free_1; eauto. left; apply Plt_ne; auto.
- intros. rewrite <- H1. eapply Mem.load_free; eauto. left; apply Plt_ne; auto.
- eauto with mem. intros. eapply Mem.perm_free_3; eauto.
- apply Plt_Ple. change (Mem.valid_block m' stk). eapply Mem.valid_block_free_1; eauto. eapply agree_valid_linear; eauto.
- apply Plt_Ple. change (Mem.valid_block m1' sp'). eapply Mem.valid_block_free_1; eauto. eapply agree_valid_mach; eauto.
apply zero_size_arguments_tailcall_possible. eapply wt_state_tailcall; eauto.
- (* Lbuiltin *)
destruct BOUND as [BND1 BND2].
- exploit transl_builtin_args_correct; eauto.
- eapply match_stacks_preserves_globals; eauto.
- rewrite <- forallb_forall. eapply wt_state_builtin; eauto.
+ exploit transl_builtin_args_correct.
+ eauto. eauto. rewrite sep_swap in SEP; apply sep_proj2 in SEP; eexact SEP.
+ eauto. rewrite <- forallb_forall. eapply wt_state_builtin; eauto.
+ exact BND2.
intros [vargs' [P Q]].
- exploit external_call_mem_inject; eauto.
- eapply match_stacks_preserves_globals; eauto.
- intros [j' [res' [m1' [A [B [C [D [E [F G]]]]]]]]].
+ rewrite <- sep_assoc, sep_comm, sep_assoc in SEP.
+ exploit external_call_parallel_rule; eauto.
+ clear SEP; intros (j' & res' & m1' & EC & RES & SEP & INCR & ISEP).
+ rewrite <- sep_assoc, sep_comm, sep_assoc in SEP.
econstructor; split.
apply plus_one. econstructor; eauto.
eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved.
eapply external_call_symbols_preserved; eauto. apply senv_preserved.
- econstructor; eauto with coqlib.
- eapply match_stack_change_extcall; eauto.
- apply Plt_Ple. change (Mem.valid_block m sp0). eapply agree_valid_linear; eauto.
- apply Plt_Ple. change (Mem.valid_block m'0 sp'). eapply agree_valid_mach; eauto.
+ eapply match_states_intro with (j := j'); eauto with coqlib.
+ eapply match_stacks_change_meminj; eauto.
apply agree_regs_set_res; auto. apply agree_regs_undef_regs; auto. eapply agree_regs_inject_incr; eauto.
- eapply agree_frame_inject_incr; eauto.
- apply agree_frame_set_res; auto. apply agree_frame_undef_regs; auto.
- apply agree_frame_extcall_invariant with m m'0; auto.
- eapply external_call_valid_block; eauto.
- intros. eapply external_call_max_perm; eauto. eapply agree_valid_linear; eauto.
- eapply external_call_valid_block; eauto.
- eapply agree_valid_mach; eauto.
+ apply agree_locs_set_res; auto. apply agree_locs_undef_regs; auto.
+ apply frame_set_res. apply frame_undef_regs. apply frame_contents_incr with j; auto.
+ rewrite sep_swap2. apply stack_contents_change_meminj with j; auto. rewrite sep_swap2.
+ exact SEP.
- (* Llabel *)
econstructor; split.
@@ -2755,21 +2014,24 @@ Proof.
- (* Lcond, true *)
econstructor; split.
apply plus_one. eapply exec_Mcond_true; eauto.
- eapply eval_condition_inject; eauto. eapply agree_reglist; eauto.
+ eapply eval_condition_inject with (m1 := m). eapply agree_reglist; eauto. apply sep_pick3 in SEP; exact SEP. auto.
eapply transl_find_label; eauto.
- econstructor. eauto. eauto. eauto. eauto.
+ econstructor. eauto. eauto. eauto.
apply agree_regs_undef_regs; auto.
- apply agree_frame_undef_locs; auto. apply destroyed_by_cond_caller_save.
+ apply agree_locs_undef_locs. auto. apply destroyed_by_cond_caller_save.
+ auto.
eapply find_label_tail; eauto.
+ apply frame_undef_regs; auto.
- (* Lcond, false *)
econstructor; split.
apply plus_one. eapply exec_Mcond_false; eauto.
- eapply eval_condition_inject; eauto. eapply agree_reglist; eauto.
- econstructor. eauto. eauto. eauto. eauto.
+ eapply eval_condition_inject with (m1 := m). eapply agree_reglist; eauto. apply sep_pick3 in SEP; exact SEP. auto.
+ econstructor. eauto. eauto. eauto.
apply agree_regs_undef_regs; auto.
- apply agree_frame_undef_locs; auto. apply destroyed_by_cond_caller_save.
- eauto with coqlib.
+ apply agree_locs_undef_locs. auto. apply destroyed_by_cond_caller_save.
+ auto. eauto with coqlib.
+ apply frame_undef_regs; auto.
- (* Ljumptable *)
assert (rs0 arg = Vint n).
@@ -2777,78 +2039,67 @@ Proof.
econstructor; split.
apply plus_one; eapply exec_Mjumptable; eauto.
apply transl_find_label; eauto.
- econstructor. eauto. eauto. eauto. eauto.
+ econstructor. eauto. eauto. eauto.
apply agree_regs_undef_regs; auto.
- apply agree_frame_undef_locs; auto. apply destroyed_by_jumptable_caller_save.
- eapply find_label_tail; eauto.
+ apply agree_locs_undef_locs. auto. apply destroyed_by_jumptable_caller_save.
+ auto. eapply find_label_tail; eauto.
+ apply frame_undef_regs; auto.
- (* Lreturn *)
+ rewrite (sep_swap (stack_contents j s cs')) in SEP.
exploit function_epilogue_correct; eauto.
- intros [rs1 [m1' [P [Q [R [S [T [U V]]]]]]]].
+ intros (rs' & m1' & A & B & C & D & E & F & G).
econstructor; split.
- eapply plus_right. eexact S. econstructor; eauto.
- traceEq.
+ eapply plus_right. eexact D. econstructor; eauto. traceEq.
econstructor; eauto.
- apply match_stacks_change_bounds with stk sp'.
- apply match_stacks_change_linear_mem with m.
- apply match_stacks_change_mach_mem with m'0.
- eauto.
- eauto with mem. intros. eapply Mem.perm_free_1; eauto. left; apply Plt_ne; auto.
- intros. rewrite <- H1. eapply Mem.load_free; eauto. left; apply Plt_ne; auto.
- eauto with mem. intros. eapply Mem.perm_free_3; eauto.
- apply Plt_Ple. change (Mem.valid_block m' stk). eapply Mem.valid_block_free_1; eauto. eapply agree_valid_linear; eauto.
- apply Plt_Ple. change (Mem.valid_block m1' sp'). eapply Mem.valid_block_free_1; eauto. eapply agree_valid_mach; eauto.
+ rewrite sep_swap; exact G.
- (* internal function *)
revert TRANSL. unfold transf_fundef, transf_partial_fundef.
- caseEq (transf_function f); simpl; try congruence.
- intros tfn TRANSL EQ. inversion EQ; clear EQ; subst tf.
- exploit function_prologue_correct; eauto. eapply wt_callstate_wt_regs; eauto.
+ destruct (transf_function f) as [tfn|] eqn:TRANSL; simpl; try congruence.
+ intros EQ; inversion EQ; clear EQ; subst tf.
+ rewrite sep_comm, sep_assoc in SEP.
+ exploit function_prologue_correct; eauto.
+ red; intros; eapply wt_callstate_wt_regs; eauto.
eapply match_stacks_type_sp; eauto.
eapply match_stacks_type_retaddr; eauto.
- intros [j' [rs' [m2' [sp' [m3' [m4' [m5' [A [B [C [D [E [F [G [J [K L]]]]]]]]]]]]]]]].
+ clear SEP;
+ intros (j' & rs' & m2' & sp' & m3' & m4' & m5' & A & B & C & D & E & F & SEP & J & K).
+ rewrite (sep_comm (globalenv_inject ge j')) in SEP.
+ rewrite (sep_swap (minjection j' m')) in SEP.
econstructor; split.
eapply plus_left. econstructor; eauto.
rewrite (unfold_transf_function _ _ TRANSL). unfold fn_code. unfold transl_body.
eexact D. traceEq.
- generalize (Mem.alloc_result _ _ _ _ _ H). intro SP_EQ.
- generalize (Mem.alloc_result _ _ _ _ _ A). intro SP'_EQ.
- econstructor; eauto.
- apply match_stacks_change_mach_mem with m'0.
- apply match_stacks_change_linear_mem with m.
- rewrite SP_EQ; rewrite SP'_EQ.
- eapply match_stacks_change_meminj; eauto. apply Ple_refl.
- eauto with mem. intros. exploit Mem.perm_alloc_inv. eexact H. eauto.
- rewrite dec_eq_false; auto. apply Plt_ne; auto.
- intros. eapply stores_in_frame_valid; eauto with mem.
- intros. eapply stores_in_frame_perm; eauto with mem.
- intros. rewrite <- H1. transitivity (Mem.load chunk m2' b ofs). eapply stores_in_frame_contents; eauto.
- eapply Mem.load_alloc_unchanged; eauto. red. congruence.
- auto with coqlib.
+ eapply match_states_intro with (j := j'); eauto with coqlib.
+ eapply match_stacks_change_meminj; eauto.
+ rewrite sep_swap in SEP. rewrite sep_swap. eapply stack_contents_change_meminj; eauto.
- (* external function *)
simpl in TRANSL. inversion TRANSL; subst tf.
- exploit transl_external_arguments; eauto. intros [vl [ARGS VINJ]].
- exploit external_call_mem_inject'; eauto.
- eapply match_stacks_preserves_globals; eauto.
- intros [j' [res' [m1' [A [B [C [D [E [F G]]]]]]]]].
+ exploit transl_external_arguments; eauto. apply sep_proj1 in SEP; eauto. intros [vl [ARGS VINJ]].
+ rewrite sep_comm, sep_assoc in SEP.
+ inv H0.
+ exploit external_call_parallel_rule; eauto.
+ eapply decode_longs_inject; eauto.
+ intros (j' & res' & m1' & A & B & C & D & E).
econstructor; split.
apply plus_one. eapply exec_function_external; eauto.
- eapply external_call_symbols_preserved'; eauto. apply senv_preserved.
- econstructor; eauto.
- apply match_stacks_change_bounds with (Mem.nextblock m) (Mem.nextblock m'0).
- inv H0; inv A. eapply match_stack_change_extcall; eauto. apply Ple_refl. apply Ple_refl.
- eapply external_call_nextblock'; eauto.
- eapply external_call_nextblock'; eauto.
- apply agree_regs_set_regs; auto. apply agree_regs_inject_incr with j; auto.
+ eapply external_call_symbols_preserved'. econstructor; eauto. apply senv_preserved.
+ eapply match_states_return with (j := j').
+ eapply match_stacks_change_meminj; eauto.
+ apply agree_regs_set_regs. apply agree_regs_inject_incr with j; auto. apply encode_long_inject; auto.
apply agree_callee_save_set_result; auto.
+ apply stack_contents_change_meminj with j; auto.
+ rewrite sep_comm, sep_assoc; auto.
- (* return *)
- inv STACKS. simpl in AGLOCS.
+ inv STACKS. simpl in AGLOCS. simpl in SEP. rewrite sep_assoc in SEP.
econstructor; split.
apply plus_one. apply exec_return.
econstructor; eauto.
- apply agree_frame_return with rs0; auto.
+ apply agree_locs_return with rs0; auto.
+ apply frame_contents_exten with rs0 (parent_locset s); auto.
Qed.
Lemma transf_initial_states:
@@ -2862,18 +2113,21 @@ Proof.
eapply (Genv.init_mem_transf_partial TRANSF); eauto.
rewrite (match_program_main TRANSF).
rewrite symbols_preserved. eauto.
- econstructor; eauto.
+ set (j := Mem.flat_inj (Mem.nextblock m0)).
+ eapply match_states_call with (j := j); eauto.
+ constructor. red; intros. rewrite H3, loc_arguments_main in H. contradiction.
+ red; simpl; auto.
+ red; simpl; auto.
+ simpl. rewrite sep_pure. split; auto. split;[|split].
eapply Genv.initmem_inject; eauto.
- apply match_stacks_empty with (Mem.nextblock m0). apply Ple_refl. apply Ple_refl.
- constructor.
- intros. unfold Mem.flat_inj. apply pred_dec_true; auto.
- unfold Mem.flat_inj; intros. destruct (plt b1 (Mem.nextblock m0)); congruence.
- intros. change (Mem.valid_block m0 b0). eapply Genv.find_symbol_not_fresh; eauto.
- intros. change (Mem.valid_block m0 b0). eapply Genv.find_funct_ptr_not_fresh; eauto.
- intros. change (Mem.valid_block m0 b0). eapply Genv.find_var_info_not_fresh; eauto.
- rewrite H3. red; intros. rewrite loc_arguments_main in H. contradiction.
- unfold Locmap.init. red; intros; auto.
- unfold parent_locset. red; auto.
+ simpl. exists (Mem.nextblock m0); split. apply Ple_refl.
+ unfold j, Mem.flat_inj; constructor; intros.
+ apply pred_dec_true; auto.
+ destruct (plt b1 (Mem.nextblock m0)); congruence.
+ change (Mem.valid_block m0 b0). eapply Genv.find_symbol_not_fresh; eauto.
+ change (Mem.valid_block m0 b0). eapply Genv.find_funct_ptr_not_fresh; eauto.
+ change (Mem.valid_block m0 b0). eapply Genv.find_var_info_not_fresh; eauto.
+ red; simpl; tauto.
Qed.
Lemma transf_final_states:
diff --git a/common/Separation.v b/common/Separation.v
new file mode 100644
index 00000000..4d87443b
--- /dev/null
+++ b/common/Separation.v
@@ -0,0 +1,916 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU General Public License as published by *)
+(* the Free Software Foundation, either version 2 of the License, or *)
+(* (at your option) any later version. This file is also distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(** Assertions on memory states, in the style of separation logic *)
+
+(** This library defines a number of useful logical assertions about
+ CompCert memory states, such as "block [b] at offset [ofs] contains
+ value [v]". Assertions can be grouped using a separating conjunction
+ operator in the style of separation logic.
+
+ Currently, this library is used only in module [Stackingproof]
+ to reason about the shapes of stack frames generated during the
+ [Stacking] pass.
+
+ This is not a full-fledged separation logic because there is no
+ program logic (Hoare triples) to speak of. Also, there is no general
+ frame rule; instead, a weak form of the frame rule is provided
+ by the lemmas that help us reason about the logical assertions. *)
+
+Require Import Setoid Program.Basics.
+Require Import Coqlib Decidableplus.
+Require Import AST Integers Values Memory Events Globalenvs.
+
+(** * Assertions about memory *)
+
+(** An assertion is composed of:
+- a predicate over memory states (of type [mem -> Prop])
+- a set of (block, offset) memory locations that represents the memory footprint of the assertion
+- a proof that the predicate is invariant by changes of memory outside of the footprint
+- a proof that the footprint contains only valid memory blocks.
+
+This presentation (where the footprint is part of the assertion) makes
+it possible to define separating conjunction without explicitly
+defining a separation algebra over CompCert memory states (i.e. the
+notion of splitting a memory state into two disjoint halves). *)
+
+Record massert : Type := {
+ m_pred : mem -> Prop;
+ m_footprint: block -> Z -> Prop;
+ m_invar: forall m m', m_pred m -> Mem.unchanged_on m_footprint m m' -> m_pred m';
+ m_valid: forall m b ofs, m_pred m -> m_footprint b ofs -> Mem.valid_block m b
+}.
+
+Notation "m |= p" := (m_pred p m) (at level 74, no associativity) : sep_scope.
+
+(** Implication and logical equivalence between memory predicates *)
+
+Definition massert_imp (P Q: massert) : Prop :=
+ (forall m, m_pred P m -> m_pred Q m) /\ (forall b ofs, m_footprint Q b ofs -> m_footprint P b ofs).
+Definition massert_eqv (P Q: massert) : Prop :=
+ massert_imp P Q /\ massert_imp Q P.
+
+Remark massert_imp_refl: forall p, massert_imp p p.
+Proof.
+ unfold massert_imp; auto.
+Qed.
+
+Remark massert_imp_trans: forall p q r, massert_imp p q -> massert_imp q r -> massert_imp p r.
+Proof.
+ unfold massert_imp; intros; firstorder auto.
+Qed.
+
+Remark massert_eqv_refl: forall p, massert_eqv p p.
+Proof.
+ unfold massert_eqv, massert_imp; intros. tauto.
+Qed.
+
+Remark massert_eqv_sym: forall p q, massert_eqv p q -> massert_eqv q p.
+Proof.
+ unfold massert_eqv, massert_imp; intros. tauto.
+Qed.
+
+Remark massert_eqv_trans: forall p q r, massert_eqv p q -> massert_eqv q r -> massert_eqv p r.
+Proof.
+ unfold massert_eqv, massert_imp; intros. firstorder auto.
+Qed.
+
+(** Record [massert_eqv] and [massert_imp] as relations so that they can be used by rewriting tactics. *)
+Add Relation massert massert_imp
+ reflexivity proved by massert_imp_refl
+ transitivity proved by massert_imp_trans
+as massert_imp_prel.
+
+Add Relation massert massert_eqv
+ reflexivity proved by massert_eqv_refl
+ symmetry proved by massert_eqv_sym
+ transitivity proved by massert_eqv_trans
+as massert_eqv_prel.
+
+Add Morphism m_pred
+ with signature massert_imp ==> eq ==> impl
+ as m_pred_morph_1.
+Proof.
+ intros P Q [A B]. auto.
+Qed.
+
+Add Morphism m_pred
+ with signature massert_eqv ==> eq ==> iff
+ as m_pred_morph_2.
+Proof.
+ intros P Q [[A B] [C D]]. split; auto.
+Qed.
+
+Hint Resolve massert_imp_refl massert_eqv_refl.
+
+(** * Separating conjunction *)
+
+Definition disjoint_footprint (P Q: massert) : Prop :=
+ forall b ofs, m_footprint P b ofs -> m_footprint Q b ofs -> False.
+
+Program Definition sepconj (P Q: massert) : massert := {|
+ m_pred := fun m => m_pred P m /\ m_pred Q m /\ disjoint_footprint P Q;
+ m_footprint := fun b ofs => m_footprint P b ofs \/ m_footprint Q b ofs
+|}.
+Next Obligation.
+ repeat split; auto.
+ apply (m_invar P) with m; auto. eapply Mem.unchanged_on_implies; eauto. simpl; auto.
+ apply (m_invar Q) with m; auto. eapply Mem.unchanged_on_implies; eauto. simpl; auto.
+Qed.
+Next Obligation.
+ destruct H0; [eapply (m_valid P) | eapply (m_valid Q)]; eauto.
+Qed.
+
+Add Morphism sepconj
+ with signature massert_imp ==> massert_imp ==> massert_imp
+ as sepconj_morph_1.
+Proof.
+ intros P1 P2 [A B] Q1 Q2 [C D].
+ red; simpl; split; intros.
+- intuition auto. red; intros. apply (H2 b ofs); auto.
+- intuition auto.
+Qed.
+
+Add Morphism sepconj
+ with signature massert_eqv ==> massert_eqv ==> massert_eqv
+ as sepconj_morph_2.
+Proof.
+ intros. destruct H, H0. split; apply sepconj_morph_1; auto.
+Qed.
+
+Infix "**" := sepconj (at level 60, right associativity) : sep_scope.
+
+Local Open Scope sep_scope.
+
+Lemma sep_imp:
+ forall P P' Q Q' m,
+ m |= P ** Q -> massert_imp P P' -> massert_imp Q Q' -> m |= P' ** Q'.
+Proof.
+ intros. rewrite <- H0, <- H1; auto.
+Qed.
+
+Lemma sep_comm_1:
+ forall P Q, massert_imp (P ** Q) (Q ** P).
+Proof.
+ unfold massert_imp; simpl; split; intros.
+- intuition auto. red; intros; eapply H2; eauto.
+- intuition auto.
+Qed.
+
+Lemma sep_comm:
+ forall P Q, massert_eqv (P ** Q) (Q ** P).
+Proof.
+ intros; split; apply sep_comm_1.
+Qed.
+
+Lemma sep_assoc_1:
+ forall P Q R, massert_imp ((P ** Q) ** R) (P ** (Q ** R)).
+Proof.
+ intros. unfold massert_imp, sepconj, disjoint_footprint; simpl; firstorder auto.
+Qed.
+
+Lemma sep_assoc_2:
+ forall P Q R, massert_imp (P ** (Q ** R)) ((P ** Q) ** R).
+Proof.
+ intros. unfold massert_imp, sepconj, disjoint_footprint; simpl; firstorder auto.
+Qed.
+
+Lemma sep_assoc:
+ forall P Q R, massert_eqv ((P ** Q) ** R) (P ** (Q ** R)).
+Proof.
+ intros; split. apply sep_assoc_1. apply sep_assoc_2.
+Qed.
+
+Lemma sep_swap:
+ forall P Q R, massert_eqv (P ** Q ** R) (Q ** P ** R).
+Proof.
+ intros. rewrite <- sep_assoc. rewrite (sep_comm P). rewrite sep_assoc. reflexivity.
+Qed.
+
+Definition sep_swap12 := sep_swap.
+
+Lemma sep_swap23:
+ forall P Q R S, massert_eqv (P ** Q ** R ** S) (P ** R ** Q ** S).
+Proof.
+ intros. rewrite (sep_swap Q). reflexivity.
+Qed.
+
+Lemma sep_swap34:
+ forall P Q R S T, massert_eqv (P ** Q ** R ** S ** T) (P ** Q ** S ** R ** T).
+Proof.
+ intros. rewrite (sep_swap R). reflexivity.
+Qed.
+
+Lemma sep_swap45:
+ forall P Q R S T U, massert_eqv (P ** Q ** R ** S ** T ** U) (P ** Q ** R ** T ** S ** U).
+Proof.
+ intros. rewrite (sep_swap S). reflexivity.
+Qed.
+
+Definition sep_swap2 := sep_swap.
+
+Lemma sep_swap3:
+ forall P Q R S, massert_eqv (P ** Q ** R ** S) (R ** Q ** P ** S).
+Proof.
+ intros. rewrite sep_swap. rewrite (sep_swap P). rewrite sep_swap. reflexivity.
+Qed.
+
+Lemma sep_swap4:
+ forall P Q R S T, massert_eqv (P ** Q ** R ** S ** T) (S ** Q ** R ** P ** T).
+Proof.
+ intros. rewrite sep_swap. rewrite (sep_swap3 P). rewrite sep_swap. reflexivity.
+Qed.
+
+Lemma sep_swap5:
+ forall P Q R S T U, massert_eqv (P ** Q ** R ** S ** T ** U) (T ** Q ** R ** S ** P ** U).
+Proof.
+ intros. rewrite sep_swap. rewrite (sep_swap4 P). rewrite sep_swap. reflexivity.
+Qed.
+
+Lemma sep_drop:
+ forall P Q m, m |= P ** Q -> m |= Q.
+Proof.
+ simpl; intros. tauto.
+Qed.
+
+Lemma sep_drop2:
+ forall P Q R m, m |= P ** Q ** R -> m |= P ** R.
+Proof.
+ intros. rewrite sep_swap in H. eapply sep_drop; eauto.
+Qed.
+
+Lemma sep_proj1:
+ forall Q P m, m |= P ** Q -> m |= P.
+Proof.
+ intros. destruct H; auto.
+Qed.
+
+Lemma sep_proj2:
+ forall P Q m, m |= P ** Q -> m |= Q.
+Proof sep_drop.
+
+Definition sep_pick1 := sep_proj1.
+
+Lemma sep_pick2:
+ forall P Q R m, m |= P ** Q ** R -> m |= Q.
+Proof.
+ intros. eapply sep_proj1; eapply sep_proj2; eauto.
+Qed.
+
+Lemma sep_pick3:
+ forall P Q R S m, m |= P ** Q ** R ** S -> m |= R.
+Proof.
+ intros. eapply sep_pick2; eapply sep_proj2; eauto.
+Qed.
+
+Lemma sep_pick4:
+ forall P Q R S T m, m |= P ** Q ** R ** S ** T -> m |= S.
+Proof.
+ intros. eapply sep_pick3; eapply sep_proj2; eauto.
+Qed.
+
+Lemma sep_pick5:
+ forall P Q R S T U m, m |= P ** Q ** R ** S ** T ** U -> m |= T.
+Proof.
+ intros. eapply sep_pick4; eapply sep_proj2; eauto.
+Qed.
+
+Lemma sep_preserved:
+ forall m m' P Q,
+ m |= P ** Q ->
+ (m |= P -> m' |= P) ->
+ (m |= Q -> m' |= Q) ->
+ m' |= P ** Q.
+Proof.
+ simpl; intros. intuition auto.
+Qed.
+
+(** * Basic memory assertions. *)
+
+(** Pure logical assertion *)
+
+Program Definition pure (P: Prop) : massert := {|
+ m_pred := fun m => P;
+ m_footprint := fun b ofs => False
+|}.
+Next Obligation.
+ tauto.
+Qed.
+
+Lemma sep_pure:
+ forall P Q m, m |= pure P ** Q <-> P /\ m |= Q.
+Proof.
+ simpl; intros. intuition auto. red; simpl; tauto.
+Qed.
+
+(** A range of bytes, with full permissions and unspecified contents. *)
+
+Program Definition range (b: block) (lo hi: Z) : massert := {|
+ m_pred := fun m =>
+ 0 <= lo /\ hi <= Int.modulus
+ /\ (forall i k p, lo <= i < hi -> Mem.perm m b i k p);
+ m_footprint := fun b' ofs' => b' = b /\ lo <= ofs' < hi
+|}.
+Next Obligation.
+ split; auto. split; auto. intros. eapply Mem.perm_unchanged_on; eauto. simpl; auto.
+Qed.
+Next Obligation.
+ apply Mem.perm_valid_block with ofs Cur Freeable; auto.
+Qed.
+
+Lemma alloc_rule:
+ forall m lo hi b m' P,
+ Mem.alloc m lo hi = (m', b) ->
+ 0 <= lo -> hi <= Int.modulus ->
+ m |= P ->
+ m' |= range b lo hi ** P.
+Proof.
+ intros; simpl. split; [|split].
+- split; auto. split; auto. intros.
+ apply Mem.perm_implies with Freeable; auto with mem.
+ eapply Mem.perm_alloc_2; eauto.
+- apply (m_invar P) with m; auto. eapply Mem.alloc_unchanged_on; eauto.
+- red; simpl. intros. destruct H3; subst b0.
+ eelim Mem.fresh_block_alloc; eauto. eapply (m_valid P); eauto.
+Qed.
+
+Lemma range_split:
+ forall b lo hi P mid m,
+ lo <= mid <= hi ->
+ m |= range b lo hi ** P ->
+ m |= range b lo mid ** range b mid hi ** P.
+Proof.
+ intros. rewrite <- sep_assoc. eapply sep_imp; eauto.
+ split; simpl; intros.
+- intuition auto.
++ omega.
++ apply H5; omega.
++ omega.
++ apply H5; omega.
++ red; simpl; intros; omega.
+- intuition omega.
+Qed.
+
+Lemma range_drop_left:
+ forall b lo hi P mid m,
+ lo <= mid <= hi ->
+ m |= range b lo hi ** P ->
+ m |= range b mid hi ** P.
+Proof.
+ intros. apply sep_drop with (range b lo mid). apply range_split; auto.
+Qed.
+
+Lemma range_drop_right:
+ forall b lo hi P mid m,
+ lo <= mid <= hi ->
+ m |= range b lo hi ** P ->
+ m |= range b lo mid ** P.
+Proof.
+ intros. apply sep_drop2 with (range b mid hi). apply range_split; auto.
+Qed.
+
+Lemma range_split_2:
+ forall b lo hi P mid al m,
+ lo <= align mid al <= hi ->
+ al > 0 ->
+ m |= range b lo hi ** P ->
+ m |= range b lo mid ** range b (align mid al) hi ** P.
+Proof.
+ intros. rewrite <- sep_assoc. eapply sep_imp; eauto.
+ assert (mid <= align mid al) by (apply align_le; auto).
+ split; simpl; intros.
+- intuition auto.
++ omega.
++ apply H7; omega.
++ omega.
++ apply H7; omega.
++ red; simpl; intros; omega.
+- intuition omega.
+Qed.
+
+Lemma range_preserved:
+ forall m m' b lo hi,
+ m |= range b lo hi ->
+ (forall i k p, lo <= i < hi -> Mem.perm m b i k p -> Mem.perm m' b i k p) ->
+ m' |= range b lo hi.
+Proof.
+ intros. destruct H as (A & B & C). simpl; intuition auto.
+Qed.
+
+(** A memory area that contains a value sastifying a given predicate *)
+
+Program Definition contains (chunk: memory_chunk) (b: block) (ofs: Z) (spec: val -> Prop) : massert := {|
+ m_pred := fun m =>
+ 0 <= ofs <= Int.max_unsigned
+ /\ Mem.valid_access m chunk b ofs Freeable
+ /\ exists v, Mem.load chunk m b ofs = Some v /\ spec v;
+ m_footprint := fun b' ofs' => b' = b /\ ofs <= ofs' < ofs + size_chunk chunk
+|}.
+Next Obligation.
+ rename H2 into v. split;[|split].
+- auto.
+- destruct H1; split; auto. red; intros; eapply Mem.perm_unchanged_on; eauto. simpl; auto.
+- exists v. split; auto. eapply Mem.load_unchanged_on; eauto. simpl; auto.
+Qed.
+Next Obligation.
+ eauto with mem.
+Qed.
+
+Lemma contains_no_overflow:
+ forall spec m chunk b ofs,
+ m |= contains chunk b ofs spec ->
+ 0 <= ofs <= Int.max_unsigned.
+Proof.
+ intros. simpl in H. tauto.
+Qed.
+
+Lemma load_rule:
+ forall spec m chunk b ofs,
+ m |= contains chunk b ofs spec ->
+ exists v, Mem.load chunk m b ofs = Some v /\ spec v.
+Proof.
+ intros. destruct H as (D & E & v & F & G).
+ exists v; auto.
+Qed.
+
+Lemma loadv_rule:
+ forall spec m chunk b ofs,
+ m |= contains chunk b ofs spec ->
+ exists v, Mem.loadv chunk m (Vptr b (Int.repr ofs)) = Some v /\ spec v.
+Proof.
+ intros. exploit load_rule; eauto. intros (v & A & B). exists v; split; auto.
+ simpl. rewrite Int.unsigned_repr; auto. eapply contains_no_overflow; eauto.
+Qed.
+
+Lemma store_rule:
+ forall chunk m b ofs v (spec1 spec: val -> Prop) P,
+ m |= contains chunk b ofs spec1 ** P ->
+ spec (Val.load_result chunk v) ->
+ exists m',
+ Mem.store chunk m b ofs v = Some m' /\ m' |= contains chunk b ofs spec ** P.
+Proof.
+ intros. destruct H as (A & B & C). destruct A as (D & E & v0 & F & G).
+ assert (H: Mem.valid_access m chunk b ofs Writable) by eauto with mem.
+ destruct (Mem.valid_access_store _ _ _ _ v H) as [m' STORE].
+ exists m'; split; auto. simpl. intuition auto.
+- eapply Mem.store_valid_access_1; eauto.
+- exists (Val.load_result chunk v); split; auto. eapply Mem.load_store_same; eauto.
+- apply (m_invar P) with m; auto.
+ eapply Mem.store_unchanged_on; eauto.
+ intros; red; intros. apply (C b i); simpl; auto.
+Qed.
+
+Lemma storev_rule:
+ forall chunk m b ofs v (spec1 spec: val -> Prop) P,
+ m |= contains chunk b ofs spec1 ** P ->
+ spec (Val.load_result chunk v) ->
+ exists m',
+ Mem.storev chunk m (Vptr b (Int.repr ofs)) v = Some m' /\ m' |= contains chunk b ofs spec ** P.
+Proof.
+ intros. exploit store_rule; eauto. intros (m' & A & B). exists m'; split; auto.
+ simpl. rewrite Int.unsigned_repr; auto. eapply contains_no_overflow. eapply sep_pick1; eauto.
+Qed.
+
+Lemma range_contains:
+ forall chunk b ofs P m,
+ m |= range b ofs (ofs + size_chunk chunk) ** P ->
+ (align_chunk chunk | ofs) ->
+ m |= contains chunk b ofs (fun v => True) ** P.
+Proof.
+ intros. destruct H as (A & B & C). destruct A as (D & E & F).
+ split; [|split].
+- assert (Mem.valid_access m chunk b ofs Freeable).
+ { split; auto. red; auto. }
+ split. generalize (size_chunk_pos chunk). unfold Int.max_unsigned. omega.
+ split. auto.
++ destruct (Mem.valid_access_load m chunk b ofs) as [v LOAD].
+ eauto with mem.
+ exists v; auto.
+- auto.
+- auto.
+Qed.
+
+Lemma contains_imp:
+ forall (spec1 spec2: val -> Prop) chunk b ofs,
+ (forall v, spec1 v -> spec2 v) ->
+ massert_imp (contains chunk b ofs spec1) (contains chunk b ofs spec2).
+Proof.
+ intros; split; simpl; intros.
+- intuition auto. destruct H4 as (v & A & B). exists v; auto.
+- auto.
+Qed.
+
+(** A memory area that contains a given value *)
+
+Definition hasvalue (chunk: memory_chunk) (b: block) (ofs: Z) (v: val) : massert :=
+ contains chunk b ofs (fun v' => v' = v).
+
+Lemma store_rule':
+ forall chunk m b ofs v (spec1: val -> Prop) P,
+ m |= contains chunk b ofs spec1 ** P ->
+ exists m',
+ Mem.store chunk m b ofs v = Some m' /\ m' |= hasvalue chunk b ofs (Val.load_result chunk v) ** P.
+Proof.
+ intros. eapply store_rule; eauto.
+Qed.
+
+Lemma storev_rule':
+ forall chunk m b ofs v (spec1: val -> Prop) P,
+ m |= contains chunk b ofs spec1 ** P ->
+ exists m',
+ Mem.storev chunk m (Vptr b (Int.repr ofs)) v = Some m' /\ m' |= hasvalue chunk b ofs (Val.load_result chunk v) ** P.
+Proof.
+ intros. eapply storev_rule; eauto.
+Qed.
+
+(** Non-separating conjunction *)
+
+Program Definition mconj (P Q: massert) : massert := {|
+ m_pred := fun m => m_pred P m /\ m_pred Q m;
+ m_footprint := fun b ofs => m_footprint P b ofs \/ m_footprint Q b ofs
+|}.
+Next Obligation.
+ split.
+ apply (m_invar P) with m; auto. eapply Mem.unchanged_on_implies; eauto. simpl; auto.
+ apply (m_invar Q) with m; auto. eapply Mem.unchanged_on_implies; eauto. simpl; auto.
+Qed.
+Next Obligation.
+ destruct H0; [eapply (m_valid P) | eapply (m_valid Q)]; eauto.
+Qed.
+
+Lemma mconj_intro:
+ forall P Q R m,
+ m |= P ** R -> m |= Q ** R -> m |= mconj P Q ** R.
+Proof.
+ intros. destruct H as (A & B & C). destruct H0 as (D & E & F).
+ split; [|split].
+- simpl; auto.
+- auto.
+- red; simpl; intros. destruct H; [eelim C | eelim F]; eauto.
+Qed.
+
+Lemma mconj_proj1:
+ forall P Q R m, m |= mconj P Q ** R -> m |= P ** R.
+Proof.
+ intros. destruct H as (A & B & C); simpl in A.
+ simpl. intuition auto.
+ red; intros; eapply C; eauto; simpl; auto.
+Qed.
+
+Lemma mconj_proj2:
+ forall P Q R m, m |= mconj P Q ** R -> m |= Q ** R.
+Proof.
+ intros. destruct H as (A & B & C); simpl in A.
+ simpl. intuition auto.
+ red; intros; eapply C; eauto; simpl; auto.
+Qed.
+
+Lemma frame_mconj:
+ forall P P' Q R m m',
+ m |= mconj P Q ** R ->
+ m' |= P' ** R ->
+ m' |= Q ->
+ m' |= mconj P' Q ** R.
+Proof.
+ intros. destruct H as (A & B & C); simpl in A.
+ destruct H0 as (D & E & F).
+ simpl. intuition auto.
+ red; simpl; intros. destruct H2. eapply F; eauto. eapply C; simpl; eauto.
+Qed.
+
+Add Morphism mconj
+ with signature massert_imp ==> massert_imp ==> massert_imp
+ as mconj_morph_1.
+Proof.
+ intros P1 P2 [A B] Q1 Q2 [C D].
+ red; simpl; intuition auto.
+Qed.
+
+Add Morphism mconj
+ with signature massert_eqv ==> massert_eqv ==> massert_eqv
+ as mconj_morph_2.
+Proof.
+ intros. destruct H, H0. split; apply mconj_morph_1; auto.
+Qed.
+
+(** The image of a memory injection *)
+
+Program Definition minjection (j: meminj) (m0: mem) : massert := {|
+ m_pred := fun m => Mem.inject j m0 m;
+ m_footprint := fun b ofs => exists b0 delta, j b0 = Some(b, delta) /\ Mem.perm m0 b0 (ofs - delta) Max Nonempty
+|}.
+Next Obligation.
+ set (img := fun b' ofs => exists b delta, j b = Some(b', delta) /\ Mem.perm m0 b (ofs - delta) Max Nonempty) in *.
+ assert (IMG: forall b1 b2 delta ofs k p,
+ j b1 = Some (b2, delta) -> Mem.perm m0 b1 ofs k p -> img b2 (ofs + delta)).
+ { intros. red. exists b1, delta; split; auto.
+ replace (ofs + delta - delta) with ofs by omega.
+ eauto with mem. }
+ destruct H. constructor.
+- destruct mi_inj. constructor; intros.
++ eapply Mem.perm_unchanged_on; eauto. eapply IMG; eauto.
++ eauto.
++ rewrite (Mem.unchanged_on_contents _ _ _ H0); eauto.
+- assumption.
+- intros. eapply Mem.valid_block_unchanged_on; eauto.
+- assumption.
+- assumption.
+Qed.
+Next Obligation.
+ eapply Mem.valid_block_inject_2; eauto.
+Qed.
+
+Lemma loadv_parallel_rule:
+ forall j m1 m2 chunk addr1 v1 addr2,
+ m2 |= minjection j m1 ->
+ Mem.loadv chunk m1 addr1 = Some v1 ->
+ Val.inject j addr1 addr2 ->
+ exists v2, Mem.loadv chunk m2 addr2 = Some v2 /\ Val.inject j v1 v2.
+Proof.
+ intros. simpl in H. eapply Mem.loadv_inject; eauto.
+Qed.
+
+Lemma storev_parallel_rule:
+ forall j m1 m2 P chunk addr1 v1 m1' addr2 v2,
+ m2 |= minjection j m1 ** P ->
+ Mem.storev chunk m1 addr1 v1 = Some m1' ->
+ Val.inject j addr1 addr2 ->
+ Val.inject j v1 v2 ->
+ exists m2', Mem.storev chunk m2 addr2 v2 = Some m2' /\ m2' |= minjection j m1' ** P.
+Proof.
+ intros. destruct H as (A & B & C). simpl in A.
+ exploit Mem.storev_mapped_inject; eauto. intros (m2' & STORE & INJ).
+ inv H1; simpl in STORE; try discriminate.
+ assert (VALID: Mem.valid_access m1 chunk b1 (Int.unsigned ofs1) Writable)
+ by eauto with mem.
+ assert (EQ: Int.unsigned (Int.add ofs1 (Int.repr delta)) = Int.unsigned ofs1 + delta).
+ { eapply Mem.address_inject'; eauto with mem. }
+ exists m2'; split; auto.
+ split; [|split].
+- exact INJ.
+- apply (m_invar P) with m2; auto.
+ eapply Mem.store_unchanged_on; eauto.
+ intros; red; intros. eelim C; eauto. simpl.
+ exists b1, delta; split; auto. destruct VALID as [V1 V2].
+ apply Mem.perm_cur_max. apply Mem.perm_implies with Writable; auto with mem.
+ apply V1. omega.
+- red; simpl; intros. destruct H1 as (b0 & delta0 & U & V).
+ eelim C; eauto. simpl. exists b0, delta0; eauto with mem.
+Qed.
+
+Lemma alloc_parallel_rule:
+ forall m1 sz1 m1' b1 m2 sz2 m2' b2 P j lo hi delta,
+ m2 |= minjection j m1 ** P ->
+ Mem.alloc m1 0 sz1 = (m1', b1) ->
+ Mem.alloc m2 0 sz2 = (m2', b2) ->
+ (8 | delta) ->
+ lo = delta ->
+ hi = delta + Zmax 0 sz1 ->
+ 0 <= sz2 <= Int.max_unsigned ->
+ 0 <= delta -> hi <= sz2 ->
+ exists j',
+ m2' |= range b2 0 lo ** range b2 hi sz2 ** minjection j' m1' ** P
+ /\ inject_incr j j'
+ /\ j' b1 = Some(b2, delta)
+ /\ (forall b, b <> b1 -> j' b = j b).
+Proof.
+ intros until delta; intros SEP ALLOC1 ALLOC2 ALIGN LO HI RANGE1 RANGE2 RANGE3.
+ assert (RANGE4: lo <= hi) by xomega.
+ assert (FRESH1: ~Mem.valid_block m1 b1) by (eapply Mem.fresh_block_alloc; eauto).
+ assert (FRESH2: ~Mem.valid_block m2 b2) by (eapply Mem.fresh_block_alloc; eauto).
+ destruct SEP as (INJ & SP & DISJ). simpl in INJ.
+ exploit Mem.alloc_left_mapped_inject.
+- eapply Mem.alloc_right_inject; eauto.
+- eexact ALLOC1.
+- instantiate (1 := b2). eauto with mem.
+- instantiate (1 := delta). xomega.
+- intros. assert (0 <= ofs < sz2) by (eapply Mem.perm_alloc_3; eauto). omega.
+- intros. apply Mem.perm_implies with Freeable; auto with mem.
+ eapply Mem.perm_alloc_2; eauto. xomega.
+- red; intros. apply Zdivides_trans with 8; auto.
+ exists (8 / align_chunk chunk). destruct chunk; reflexivity.
+- intros. elim FRESH2. eapply Mem.valid_block_inject_2; eauto.
+- intros (j' & INJ' & J1 & J2 & J3).
+ exists j'; split; auto.
+ rewrite <- ! sep_assoc.
+ split; [|split].
++ simpl. intuition auto; try (unfold Int.max_unsigned in *; omega).
+* apply Mem.perm_implies with Freeable; auto with mem.
+ eapply Mem.perm_alloc_2; eauto. omega.
+* apply Mem.perm_implies with Freeable; auto with mem.
+ eapply Mem.perm_alloc_2; eauto. omega.
+* red; simpl; intros. destruct H1, H2. omega.
+* red; simpl; intros.
+ assert (b = b2) by tauto. subst b.
+ assert (0 <= ofs < lo \/ hi <= ofs < sz2) by tauto. clear H1.
+ destruct H2 as (b0 & delta0 & D & E).
+ eapply Mem.perm_alloc_inv in E; eauto.
+ destruct (eq_block b0 b1).
+ subst b0. rewrite J2 in D. inversion D; clear D; subst delta0. xomega.
+ rewrite J3 in D by auto. elim FRESH2. eapply Mem.valid_block_inject_2; eauto.
++ apply (m_invar P) with m2; auto. eapply Mem.alloc_unchanged_on; eauto.
++ red; simpl; intros.
+ assert (VALID: Mem.valid_block m2 b) by (eapply (m_valid P); eauto).
+ destruct H as [A | (b0 & delta0 & A & B)].
+* assert (b = b2) by tauto. subst b. contradiction.
+* eelim DISJ; eauto. simpl.
+ eapply Mem.perm_alloc_inv in B; eauto.
+ destruct (eq_block b0 b1).
+ subst b0. rewrite J2 in A. inversion A; clear A; subst b delta0. contradiction.
+ rewrite J3 in A by auto. exists b0, delta0; auto.
+Qed.
+
+Lemma free_parallel_rule:
+ forall j m1 b1 sz1 m1' m2 b2 sz2 lo hi delta P,
+ m2 |= range b2 0 lo ** range b2 hi sz2 ** minjection j m1 ** P ->
+ Mem.free m1 b1 0 sz1 = Some m1' ->
+ j b1 = Some (b2, delta) ->
+ lo = delta -> hi = delta + Zmax 0 sz1 ->
+ exists m2',
+ Mem.free m2 b2 0 sz2 = Some m2'
+ /\ m2' |= minjection j m1' ** P.
+Proof.
+ intros. rewrite <- ! sep_assoc in H.
+ destruct H as (A & B & C).
+ destruct A as (D & E & F).
+ destruct D as (J & K & L).
+ destruct J as (_ & _ & J). destruct K as (_ & _ & K).
+ simpl in E.
+ assert (PERM: Mem.range_perm m2 b2 0 sz2 Cur Freeable).
+ { red; intros.
+ destruct (zlt ofs lo). apply J; omega.
+ destruct (zle hi ofs). apply K; omega.
+ replace ofs with ((ofs - delta) + delta) by omega.
+ eapply Mem.perm_inject; eauto.
+ eapply Mem.free_range_perm; eauto. xomega.
+ }
+ destruct (Mem.range_perm_free _ _ _ _ PERM) as [m2' FREE].
+ exists m2'; split; auto. split; [|split].
+- simpl. eapply Mem.free_right_inject; eauto. eapply Mem.free_left_inject; eauto.
+ intros. apply (F b2 (ofs + delta0)).
++ simpl.
+ destruct (zlt (ofs + delta0) lo). intuition auto.
+ destruct (zle hi (ofs + delta0)). intuition auto.
+ destruct (eq_block b0 b1).
+* subst b0. rewrite H1 in H; inversion H; clear H; subst delta0.
+ eelim (Mem.perm_free_2 m1); eauto. xomega.
+* exploit Mem.mi_no_overlap; eauto.
+ apply Mem.perm_max with k. apply Mem.perm_implies with p; auto with mem.
+ eapply Mem.perm_free_3; eauto.
+ apply Mem.perm_cur_max. apply Mem.perm_implies with Freeable; auto with mem.
+ eapply (Mem.free_range_perm m1); eauto.
+ instantiate (1 := ofs + delta0 - delta). xomega.
+ intros [X|X]. congruence. omega.
++ simpl. exists b0, delta0; split; auto.
+ replace (ofs + delta0 - delta0) with ofs by omega.
+ apply Mem.perm_max with k. apply Mem.perm_implies with p; auto with mem.
+ eapply Mem.perm_free_3; eauto.
+- apply (m_invar P) with m2; auto.
+ eapply Mem.free_unchanged_on; eauto.
+ intros; red; intros. eelim C; eauto. simpl.
+ destruct (zlt i lo). intuition auto.
+ destruct (zle hi i). intuition auto.
+ right; exists b1, delta; split; auto.
+ apply Mem.perm_cur_max. apply Mem.perm_implies with Freeable; auto with mem.
+ eapply Mem.free_range_perm; eauto. xomega.
+- red; simpl; intros. eelim C; eauto.
+ simpl. right. destruct H as (b0 & delta0 & U & V).
+ exists b0, delta0; split; auto.
+ eapply Mem.perm_free_3; eauto.
+Qed.
+
+(** Preservation of a global environment by a memory injection *)
+
+Inductive globalenv_preserved {F V: Type} (ge: Genv.t F V) (j: meminj) (bound: block) : Prop :=
+ | globalenv_preserved_intro
+ (DOMAIN: forall b, Plt b bound -> j b = Some(b, 0))
+ (IMAGE: forall b1 b2 delta, j b1 = Some(b2, delta) -> Plt b2 bound -> b1 = b2)
+ (SYMBOLS: forall id b, Genv.find_symbol ge id = Some b -> Plt b bound)
+ (FUNCTIONS: forall b fd, Genv.find_funct_ptr ge b = Some fd -> Plt b bound)
+ (VARINFOS: forall b gv, Genv.find_var_info ge b = Some gv -> Plt b bound).
+
+Program Definition globalenv_inject {F V: Type} (ge: Genv.t F V) (j: meminj) : massert := {|
+ m_pred := fun m => exists bound, Ple bound (Mem.nextblock m) /\ globalenv_preserved ge j bound;
+ m_footprint := fun b ofs => False
+|}.
+Next Obligation.
+ rename H into bound. exists bound; split; auto. eapply Ple_trans; eauto. eapply Mem.unchanged_on_nextblock; eauto.
+Qed.
+Next Obligation.
+ tauto.
+Qed.
+
+Lemma globalenv_inject_preserves_globals:
+ forall (F V: Type) (ge: Genv.t F V) j m,
+ m |= globalenv_inject ge j ->
+ meminj_preserves_globals ge j.
+Proof.
+ intros. destruct H as (bound & A & B). destruct B.
+ split; [|split]; intros.
+- eauto.
+- eauto.
+- symmetry; eauto.
+Qed.
+
+Lemma globalenv_inject_incr:
+ forall j m0 (F V: Type) (ge: Genv.t F V) m j' P,
+ inject_incr j j' ->
+ inject_separated j j' m0 m ->
+ m |= globalenv_inject ge j ** P ->
+ m |= globalenv_inject ge j' ** P.
+Proof.
+ intros. destruct H1 as (A & B & C). destruct A as (bound & D & E).
+ split; [|split]; auto.
+ exists bound; split; auto.
+ inv E; constructor; intros.
+- eauto.
+- destruct (j b1) as [[b0 delta0]|] eqn:JB1.
++ erewrite H in H1 by eauto. inv H1. eauto.
++ exploit H0; eauto. intros (X & Y). elim Y. apply Plt_le_trans with bound; auto.
+- eauto.
+- eauto.
+- eauto.
+Qed.
+
+Lemma external_call_parallel_rule:
+ forall (F V: Type) ef (ge: Genv.t F V) vargs1 m1 t vres1 m1' m2 j P vargs2,
+ external_call ef ge vargs1 m1 t vres1 m1' ->
+ m2 |= minjection j m1 ** globalenv_inject ge j ** P ->
+ Val.inject_list j vargs1 vargs2 ->
+ exists j' vres2 m2',
+ external_call ef ge vargs2 m2 t vres2 m2'
+ /\ Val.inject j' vres1 vres2
+ /\ m2' |= minjection j' m1' ** globalenv_inject ge j' ** P
+ /\ inject_incr j j'
+ /\ inject_separated j j' m1 m2.
+Proof.
+ intros until vargs2; intros CALL SEP ARGS.
+ destruct SEP as (A & B & C). simpl in A.
+ exploit external_call_mem_inject; eauto.
+ eapply globalenv_inject_preserves_globals. eapply sep_pick1; eauto.
+ intros (j' & vres2 & m2' & CALL' & RES & INJ' & UNCH1 & UNCH2 & INCR & ISEP).
+ assert (MAXPERMS: forall b ofs p,
+ Mem.valid_block m1 b -> Mem.perm m1' b ofs Max p -> Mem.perm m1 b ofs Max p).
+ { intros. eapply external_call_max_perm; eauto. }
+ exists j', vres2, m2'; intuition auto.
+ split; [|split].
+- exact INJ'.
+- apply m_invar with (m0 := m2).
++ apply globalenv_inject_incr with j m1; auto.
++ eapply Mem.unchanged_on_implies; eauto.
+ intros; red; intros; red; intros.
+ eelim C; eauto. simpl. exists b0, delta; auto.
+- red; intros. destruct H as (b0 & delta & J' & E).
+ destruct (j b0) as [[b' delta'] | ] eqn:J.
++ erewrite INCR in J' by eauto. inv J'.
+ eelim C; eauto. simpl. exists b0, delta; split; auto. apply MAXPERMS; auto.
+ eapply Mem.valid_block_inject_1; eauto.
++ exploit ISEP; eauto. intros (X & Y). elim Y. eapply m_valid; eauto.
+Qed.
+
+Lemma alloc_parallel_rule_2:
+ forall (F V: Type) (ge: Genv.t F V) m1 sz1 m1' b1 m2 sz2 m2' b2 P j lo hi delta,
+ m2 |= minjection j m1 ** globalenv_inject ge j ** P ->
+ Mem.alloc m1 0 sz1 = (m1', b1) ->
+ Mem.alloc m2 0 sz2 = (m2', b2) ->
+ (8 | delta) ->
+ lo = delta ->
+ hi = delta + Zmax 0 sz1 ->
+ 0 <= sz2 <= Int.max_unsigned ->
+ 0 <= delta -> hi <= sz2 ->
+ exists j',
+ m2' |= range b2 0 lo ** range b2 hi sz2 ** minjection j' m1' ** globalenv_inject ge j' ** P
+ /\ inject_incr j j'
+ /\ j' b1 = Some(b2, delta).
+Proof.
+ intros.
+ set (j1 := fun b => if eq_block b b1 then Some(b2, delta) else j b).
+ assert (X: inject_incr j j1).
+ { unfold j1; red; intros. destruct (eq_block b b1); auto.
+ subst b. eelim Mem.fresh_block_alloc. eexact H0.
+ eapply Mem.valid_block_inject_1. eauto. apply sep_proj1 in H. eexact H. }
+ assert (Y: inject_separated j j1 m1 m2).
+ { unfold j1; red; intros. destruct (eq_block b0 b1).
+ - inversion H9; clear H9; subst b3 delta0 b0. split; eapply Mem.fresh_block_alloc; eauto.
+ - congruence. }
+ rewrite sep_swap in H. eapply globalenv_inject_incr with (j' := j1) in H; eauto. rewrite sep_swap in H.
+ clear X Y.
+ exploit alloc_parallel_rule; eauto.
+ intros (j' & A & B & C & D).
+ exists j'; split; auto.
+ rewrite sep_swap4 in A. rewrite sep_swap4. apply globalenv_inject_incr with j1 m1; auto.
+- red; unfold j1; intros. destruct (eq_block b b1). congruence. rewrite D; auto.
+- red; unfold j1; intros. destruct (eq_block b0 b1). congruence. rewrite D in H9 by auto. congruence.
+Qed.
diff --git a/extraction/extraction.v b/extraction/extraction.v
index 22a69c49..6788bd60 100644
--- a/extraction/extraction.v
+++ b/extraction/extraction.v
@@ -159,6 +159,8 @@ Separate Extraction
Ctyping.typecheck_program
Ctyping.epostincr Ctyping.epostdecr Ctyping.epreincr Ctyping.epredecr
Ctypes.make_program
+ Conventions1.int_caller_save_regs Conventions1.float_caller_save_regs
+ Conventions1.int_callee_save_regs Conventions1.float_callee_save_regs
Conventions1.dummy_int_reg Conventions1.dummy_float_reg
RTL.instr_defs RTL.instr_uses
Machregs.mregs_for_operation Machregs.mregs_for_builtin
diff --git a/ia32/Asmgenproof1.v b/ia32/Asmgenproof1.v
index d2a8206e..60cc266e 100644
--- a/ia32/Asmgenproof1.v
+++ b/ia32/Asmgenproof1.v
@@ -38,7 +38,7 @@ Lemma agree_nextinstr_nf:
Proof.
intros. unfold nextinstr_nf. apply agree_nextinstr.
apply agree_undef_nondata_regs. auto.
- intro. simpl. ElimOrEq; auto.
+ simpl; intros. intuition (subst r; auto).
Qed.
(** Useful properties of the PC register. *)
diff --git a/ia32/Conventions1.v b/ia32/Conventions1.v
index 11420d48..e9969ab8 100644
--- a/ia32/Conventions1.v
+++ b/ia32/Conventions1.v
@@ -14,6 +14,7 @@
machine registers and stack slots. *)
Require Import Coqlib.
+Require Import Decidableplus.
Require Import AST.
Require Import Events.
Require Import Locations.
@@ -29,6 +30,14 @@ Require Import Locations.
of callee- and caller-save registers.
*)
+Definition is_callee_save (r: mreg) : bool :=
+ match r with
+ | AX | CX | DX => false
+ | BX | SI | DI | BP => true
+ | X0 | X1 | X2 | X3 | X4 | X5 | X6 | X7 => false
+ | FP0 => false
+ end.
+
Definition int_caller_save_regs := AX :: CX :: DX :: nil.
Definition float_caller_save_regs := X0 :: X1 :: X2 :: X3 :: X4 :: X5 :: X6 :: X7 :: nil.
@@ -38,161 +47,11 @@ Definition int_callee_save_regs := BX :: SI :: DI :: BP :: nil.
Definition float_callee_save_regs : list mreg := nil.
Definition destroyed_at_call :=
- FP0 :: int_caller_save_regs ++ float_caller_save_regs.
+ List.filter (fun r => negb (is_callee_save r)) all_mregs.
Definition dummy_int_reg := AX. (**r Used in [Regalloc]. *)
Definition dummy_float_reg := X0. (**r Used in [Regalloc]. *)
-(** The [index_int_callee_save] and [index_float_callee_save] associate
- a unique positive integer to callee-save registers. This integer is
- used in [Stacking] to determine where to save these registers in
- the activation record if they are used by the current function. *)
-
-Definition index_int_callee_save (r: mreg) :=
- match r with
- | BX => 0 | SI => 1 | DI => 2 | BP => 3 | _ => -1
- end.
-
-Definition index_float_callee_save (r: mreg) := -1.
-
-Ltac ElimOrEq :=
- match goal with
- | |- (?x = ?y) \/ _ -> _ =>
- let H := fresh in
- (intro H; elim H; clear H;
- [intro H; rewrite <- H; clear H | ElimOrEq])
- | |- False -> _ =>
- let H := fresh in (intro H; contradiction)
- end.
-
-Ltac OrEq :=
- match goal with
- | |- (?x = ?x) \/ _ => left; reflexivity
- | |- (?x = ?y) \/ _ => right; OrEq
- | |- False => fail
- end.
-
-Ltac NotOrEq :=
- match goal with
- | |- (?x = ?y) \/ _ -> False =>
- let H := fresh in (
- intro H; elim H; clear H; [intro; discriminate | NotOrEq])
- | |- False -> False =>
- contradiction
- end.
-
-Lemma index_int_callee_save_pos:
- forall r, In r int_callee_save_regs -> index_int_callee_save r >= 0.
-Proof.
- intro r. simpl; ElimOrEq; unfold index_int_callee_save; omega.
-Qed.
-
-Lemma index_float_callee_save_pos:
- forall r, In r float_callee_save_regs -> index_float_callee_save r >= 0.
-Proof.
- intro r. simpl; ElimOrEq; unfold index_float_callee_save; omega.
-Qed.
-
-Lemma index_int_callee_save_pos2:
- forall r, index_int_callee_save r >= 0 -> In r int_callee_save_regs.
-Proof.
- destruct r; simpl; intro; omegaContradiction || OrEq.
-Qed.
-
-Lemma index_float_callee_save_pos2:
- forall r, index_float_callee_save r >= 0 -> In r float_callee_save_regs.
-Proof.
- unfold index_float_callee_save; intros. omegaContradiction.
-Qed.
-
-Lemma index_int_callee_save_inj:
- forall r1 r2,
- In r1 int_callee_save_regs ->
- In r2 int_callee_save_regs ->
- r1 <> r2 ->
- index_int_callee_save r1 <> index_int_callee_save r2.
-Proof.
- intros r1 r2.
- simpl; ElimOrEq; ElimOrEq; unfold index_int_callee_save;
- intros; congruence.
-Qed.
-
-Lemma index_float_callee_save_inj:
- forall r1 r2,
- In r1 float_callee_save_regs ->
- In r2 float_callee_save_regs ->
- r1 <> r2 ->
- index_float_callee_save r1 <> index_float_callee_save r2.
-Proof.
- simpl; intros. contradiction.
-Qed.
-
-(** The following lemmas show that
- (destroyed at call, integer callee-save, float callee-save)
- is a partition of the set of machine registers. *)
-
-Lemma int_float_callee_save_disjoint:
- list_disjoint int_callee_save_regs float_callee_save_regs.
-Proof.
- red; intros r1 r2. simpl; ElimOrEq; ElimOrEq; discriminate.
-Qed.
-
-Lemma register_classification:
- forall r,
- In r destroyed_at_call \/ In r int_callee_save_regs \/ In r float_callee_save_regs.
-Proof.
- destruct r;
- try (left; simpl; OrEq);
- try (right; left; simpl; OrEq);
- try (right; right; simpl; OrEq).
-Qed.
-
-Lemma int_callee_save_not_destroyed:
- forall r,
- In r destroyed_at_call -> In r int_callee_save_regs -> False.
-Proof.
- intros. revert H0 H. simpl. ElimOrEq; NotOrEq.
-Qed.
-
-Lemma float_callee_save_not_destroyed:
- forall r,
- In r destroyed_at_call -> In r float_callee_save_regs -> False.
-Proof.
- intros. revert H0 H. simpl. ElimOrEq; NotOrEq.
-Qed.
-
-Lemma int_callee_save_type:
- forall r, In r int_callee_save_regs -> mreg_type r = Tany32.
-Proof.
- intro. simpl; ElimOrEq; reflexivity.
-Qed.
-
-Lemma float_callee_save_type:
- forall r, In r float_callee_save_regs -> mreg_type r = Tany64.
-Proof.
- intro. simpl; ElimOrEq; reflexivity.
-Qed.
-
-Ltac NoRepet :=
- match goal with
- | |- list_norepet nil =>
- apply list_norepet_nil
- | |- list_norepet (?a :: ?b) =>
- apply list_norepet_cons; [simpl; intuition discriminate | NoRepet]
- end.
-
-Lemma int_callee_save_norepet:
- list_norepet int_callee_save_regs.
-Proof.
- unfold int_callee_save_regs; NoRepet.
-Qed.
-
-Lemma float_callee_save_norepet:
- list_norepet float_callee_save_regs.
-Proof.
- unfold float_callee_save_regs; NoRepet.
-Qed.
-
(** * Function calling conventions *)
(** The functions in this section determine the locations (machine registers
@@ -239,12 +98,12 @@ Qed.
Lemma loc_result_caller_save:
forall (s: signature) (r: mreg),
- In r (loc_result s) -> In r destroyed_at_call.
+ In r (loc_result s) -> is_callee_save r = false.
Proof.
intros.
assert (r = AX \/ r = DX \/ r = FP0 \/ r = X0).
unfold loc_result in H. destruct (sig_res s) as [[]|]; simpl in H; intuition.
- destruct H0 as [A | [A | [A | A]]]; subst r; simpl; OrEq.
+ destruct H0 as [A | [A | [A | A]]]; subst r; reflexivity.
Qed.
(** ** Location of function arguments *)
@@ -287,8 +146,8 @@ Definition size_arguments (s: signature) : Z :=
Definition loc_argument_acceptable (l: loc) : Prop :=
match l with
- | R r => In r destroyed_at_call
- | S Outgoing ofs ty => ofs >= 0 /\ ty <> Tlong
+ | R r => is_callee_save r = false
+ | S Outgoing ofs ty => ofs >= 0 /\ (typealign ty | ofs)
| _ => False
end.
@@ -296,7 +155,7 @@ Remark loc_arguments_rec_charact:
forall tyl ofs l,
In l (loc_arguments_rec tyl ofs) ->
match l with
- | S Outgoing ofs' ty => ofs' >= ofs /\ ty <> Tlong
+ | S Outgoing ofs' ty => ofs' >= ofs /\ typealign ty = 1
| _ => False
end.
Proof.
@@ -307,12 +166,12 @@ Proof.
| R _ => False
| S Local _ _ => False
| S Incoming _ _ => False
- | S Outgoing ofs' ty => ofs' >= ofs /\ ty <> Tlong
+ | S Outgoing ofs' ty => ofs' >= ofs /\ typealign ty = 1
end).
{ intros. exploit IHtyl; eauto. destruct l; auto. destruct sl; intuition omega
. }
destruct a; simpl in H; repeat (destruct H);
- ((eapply REC; eauto; omega) || (split; [omega|congruence])).
+ ((eapply REC; eauto; omega) || (split; [omega|reflexivity])).
Qed.
Lemma loc_arguments_acceptable:
@@ -322,7 +181,7 @@ Proof.
unfold loc_arguments; intros.
exploit loc_arguments_rec_charact; eauto.
unfold loc_argument_acceptable.
- destruct l; tauto.
+ destruct l as [r | [] ofs ty]; intuition auto. rewrite H2; apply Z.divide_1_l.
Qed.
Hint Resolve loc_arguments_acceptable: locs.
diff --git a/ia32/Machregs.v b/ia32/Machregs.v
index 34eb0ac8..fb80a1fd 100644
--- a/ia32/Machregs.v
+++ b/ia32/Machregs.v
@@ -12,6 +12,7 @@
Require Import String.
Require Import Coqlib.
+Require Import Decidableplus.
Require Import Maps.
Require Import AST.
Require Import Integers.
@@ -41,6 +42,25 @@ Lemma mreg_eq: forall (r1 r2: mreg), {r1 = r2} + {r1 <> r2}.
Proof. decide equality. Defined.
Global Opaque mreg_eq.
+Definition all_mregs :=
+ AX :: BX :: CX :: DX :: SI :: DI :: BP
+ :: X0 :: X1 :: X2 :: X3 :: X4 :: X5 :: X6 :: X7
+ :: FP0 :: nil.
+
+Lemma all_mregs_complete:
+ forall (r: mreg), In r all_mregs.
+Proof.
+ assert (forall r, proj_sumbool (In_dec mreg_eq r all_mregs) = true) by (destruct r; reflexivity).
+ intros. specialize (H r). InvBooleans. auto.
+Qed.
+
+Instance Decidable_eq_mreg : forall (x y: mreg), Decidable (eq x y) := Decidable_eq mreg_eq.
+
+Instance Finite_mreg : Finite mreg := {
+ Finite_elements := all_mregs;
+ Finite_elements_spec := all_mregs_complete
+}.
+
Definition mreg_type (r: mreg): typ :=
match r with
| AX | BX | CX | DX | SI | DI | BP => Tany32
@@ -62,7 +82,7 @@ Module IndexedMreg <: INDEXED_TYPE.
Lemma index_inj:
forall r1 r2, index r1 = index r2 -> r1 = r2.
Proof.
- destruct r1; destruct r2; simpl; intro; discriminate || reflexivity.
+ decide_goal.
Qed.
End IndexedMreg.
diff --git a/ia32/Machregsaux.ml b/ia32/Machregsaux.ml
index 6485e752..3ec9596a 100644
--- a/ia32/Machregsaux.ml
+++ b/ia32/Machregsaux.ml
@@ -30,7 +30,4 @@ let name_of_register r =
let register_by_name s =
Machregs.register_by_name (coqstring_of_camlstring (String.uppercase s))
-let can_reserve_register r =
- List.mem r Conventions1.int_callee_save_regs
- || List.mem r Conventions1.float_callee_save_regs
-
+let can_reserve_register r = Conventions1.is_callee_save r
diff --git a/ia32/Stacklayout.v b/ia32/Stacklayout.v
index f9d1dafe..f19f036c 100644
--- a/ia32/Stacklayout.v
+++ b/ia32/Stacklayout.v
@@ -13,6 +13,7 @@
(** Machine- and ABI-dependent layout information for activation records. *)
Require Import Coqlib.
+Require Import Memory Separation.
Require Import Bounds.
(** The general shape of activation records is as follows,
@@ -24,107 +25,118 @@ Require Import Bounds.
- Local stack slots.
- Space for the stack-allocated data declared in Cminor
- Return address.
-
-The [frame_env] compilation environment records the positions of
-the boundaries between these areas of the activation record.
*)
Definition fe_ofs_arg := 0.
-Record frame_env : Type := mk_frame_env {
- fe_size: Z;
- fe_ofs_link: Z;
- fe_ofs_retaddr: Z;
- fe_ofs_local: Z;
- fe_ofs_int_callee_save: Z;
- fe_num_int_callee_save: Z;
- fe_ofs_float_callee_save: Z;
- fe_num_float_callee_save: Z;
- fe_stack_data: Z
-}.
-
(** Computation of the frame environment from the bounds of the current
function. *)
-Definition make_env (b: bounds) :=
+Definition make_env (b: bounds) : frame_env :=
let olink := 4 * b.(bound_outgoing) in (* back link *)
- let oics := olink + 4 in (* integer callee-saves *)
- let ofcs := align (oics + 4 * b.(bound_int_callee_save)) 8 in (* float callee-saves *)
- let ol := ofcs + 8 * b.(bound_float_callee_save) in (* locals *)
+ let ocs := olink + 4 in (* callee-saves *)
+ let ol := align (size_callee_save_area b ocs) 8 in (* locals *)
let ostkdata := align (ol + 4 * b.(bound_local)) 8 in (* stack data *)
let oretaddr := align (ostkdata + b.(bound_stack_data)) 4 in (* return address *)
let sz := oretaddr + 4 in (* total size *)
- mk_frame_env sz olink oretaddr
- ol
- oics b.(bound_int_callee_save)
- ofcs b.(bound_float_callee_save)
- ostkdata.
+ {| fe_size := sz;
+ fe_ofs_link := olink;
+ fe_ofs_retaddr := oretaddr;
+ fe_ofs_local := ol;
+ fe_ofs_callee_save := ocs;
+ fe_stack_data := ostkdata;
+ fe_used_callee_save := b.(used_callee_save) |}.
(** Separation property *)
-Remark frame_env_separated:
- forall b,
+Local Open Scope sep_scope.
+
+Lemma frame_env_separated:
+ forall b sp m P,
let fe := make_env b in
- 0 <= fe_ofs_arg
- /\ fe_ofs_arg + 4 * b.(bound_outgoing) <= fe.(fe_ofs_link)
- /\ fe.(fe_ofs_link) + 4 <= fe.(fe_ofs_int_callee_save)
- /\ fe.(fe_ofs_int_callee_save) + 4 * b.(bound_int_callee_save) <= fe.(fe_ofs_float_callee_save)
- /\ fe.(fe_ofs_float_callee_save) + 8 * b.(bound_float_callee_save) <= fe.(fe_ofs_local)
- /\ fe.(fe_ofs_local) + 4 * b.(bound_local) <= fe.(fe_stack_data)
- /\ fe.(fe_stack_data) + b.(bound_stack_data) <= fe.(fe_ofs_retaddr)
- /\ fe.(fe_ofs_retaddr) + 4 <= fe.(fe_size).
+ m |= range sp 0 (fe_stack_data fe) ** range sp (fe_stack_data fe + bound_stack_data b) (fe_size fe) ** P ->
+ m |= range sp (fe_ofs_local fe) (fe_ofs_local fe + 4 * bound_local b)
+ ** range sp fe_ofs_arg (fe_ofs_arg + 4 * bound_outgoing b)
+ ** range sp (fe_ofs_link fe) (fe_ofs_link fe + 4)
+ ** range sp (fe_ofs_retaddr fe) (fe_ofs_retaddr fe + 4)
+ ** range sp (fe_ofs_callee_save fe) (size_callee_save_area b (fe_ofs_callee_save fe))
+ ** P.
Proof.
- intros.
- generalize (align_le (fe.(fe_ofs_int_callee_save) + 4 * b.(bound_int_callee_save)) 8 (refl_equal _)).
- generalize (align_le (fe.(fe_ofs_local) + 4 * b.(bound_local)) 8 (refl_equal _)).
- generalize (align_le (fe.(fe_stack_data) + b.(bound_stack_data)) 4 (refl_equal _)).
- unfold fe, make_env, fe_size, fe_ofs_link, fe_ofs_retaddr,
- fe_ofs_local, fe_ofs_int_callee_save, fe_num_int_callee_save,
- fe_ofs_float_callee_save, fe_num_float_callee_save,
- fe_stack_data, fe_ofs_arg.
- intros.
- generalize (bound_local_pos b); intro;
- generalize (bound_int_callee_save_pos b); intro;
- generalize (bound_float_callee_save_pos b); intro;
- generalize (bound_outgoing_pos b); intro;
- generalize (bound_stack_data_pos b); intro.
- omega.
+Local Opaque Z.add Z.mul sepconj range.
+ intros; simpl.
+ set (olink := 4 * b.(bound_outgoing)).
+ set (ocs := olink + 4).
+ set (ol := align (size_callee_save_area b ocs) 8).
+ set (ostkdata := align (ol + 4 * b.(bound_local)) 8).
+ set (oretaddr := align (ostkdata + b.(bound_stack_data)) 4).
+ generalize b.(bound_local_pos) b.(bound_outgoing_pos) b.(bound_stack_data_pos); intros.
+ assert (0 <= olink) by (unfold olink; omega).
+ assert (olink + 4 <= ocs) by (unfold ocs; omega).
+ assert (ocs <= size_callee_save_area b ocs) by (apply size_callee_save_area_incr).
+ assert (size_callee_save_area b ocs <= ol) by (apply align_le; omega).
+ assert (ol + 4 * b.(bound_local) <= ostkdata) by (apply align_le; omega).
+ assert (ostkdata + bound_stack_data b <= oretaddr) by (apply align_le; omega).
+(* Reorder as:
+ outgoing
+ back link
+ callee-save
+ local
+ retaddr *)
+ rewrite sep_swap12.
+ rewrite sep_swap23.
+ rewrite sep_swap45.
+ rewrite sep_swap34.
+(* Apply range_split and range_split2 repeatedly *)
+ unfold fe_ofs_arg.
+ apply range_split. omega.
+ apply range_split. omega.
+ apply range_split_2. fold ol. omega. omega.
+ apply range_drop_right with ostkdata. omega.
+ rewrite sep_swap.
+ apply range_drop_left with (ostkdata + bound_stack_data b). omega.
+ rewrite sep_swap.
+ exact H.
Qed.
-(** Alignment property *)
-
-Remark frame_env_aligned:
+Lemma frame_env_range:
forall b,
let fe := make_env b in
- (4 | fe.(fe_ofs_link))
- /\ (4 | fe.(fe_ofs_int_callee_save))
- /\ (8 | fe.(fe_ofs_float_callee_save))
- /\ (8 | fe.(fe_ofs_local))
- /\ (8 | fe.(fe_stack_data))
- /\ (4 | fe.(fe_ofs_retaddr))
- /\ (4 | fe.(fe_size)).
+ 0 <= fe_stack_data fe /\ fe_stack_data fe + bound_stack_data b <= fe_size fe.
Proof.
- intros.
- unfold fe, make_env, fe_size, fe_ofs_link, fe_ofs_retaddr,
- fe_ofs_local, fe_ofs_int_callee_save,
- fe_num_int_callee_save,
- fe_ofs_float_callee_save, fe_num_float_callee_save,
- fe_stack_data.
- set (x1 := 4 * bound_outgoing b).
- assert (4 | x1). unfold x1; exists (bound_outgoing b); ring.
- set (x2 := x1 + 4).
- assert (4 | x2). unfold x2; apply Zdivide_plus_r; auto. exists 1; auto.
- set (x3 := x2 + 4 * bound_int_callee_save b).
- set (x4 := align x3 8).
- assert (8 | x4). unfold x4. apply align_divides. omega.
- set (x5 := x4 + 8 * bound_float_callee_save b).
- assert (8 | x5). unfold x5; apply Zdivide_plus_r; auto. exists (bound_float_callee_save b); ring.
- set (x6 := align (x5 + 4 * bound_local b) 8).
- assert (8 | x6). unfold x6; apply align_divides; omega.
- set (x7 := align (x6 + bound_stack_data b) 4).
- assert (4 | x7). unfold x7; apply align_divides; omega.
- set (x8 := x7 + 4).
- assert (4 | x8). unfold x8; apply Zdivide_plus_r; auto. exists 1; auto.
- tauto.
+ intros; simpl.
+ set (olink := 4 * b.(bound_outgoing)).
+ set (ocs := olink + 4).
+ set (ol := align (size_callee_save_area b ocs) 8).
+ set (ostkdata := align (ol + 4 * b.(bound_local)) 8).
+ set (oretaddr := align (ostkdata + b.(bound_stack_data)) 4).
+ generalize b.(bound_local_pos) b.(bound_outgoing_pos) b.(bound_stack_data_pos); intros.
+ assert (0 <= olink) by (unfold olink; omega).
+ assert (olink + 4 <= ocs) by (unfold ocs; omega).
+ assert (ocs <= size_callee_save_area b ocs) by (apply size_callee_save_area_incr).
+ assert (size_callee_save_area b ocs <= ol) by (apply align_le; omega).
+ assert (ol + 4 * b.(bound_local) <= ostkdata) by (apply align_le; omega).
+ assert (ostkdata + bound_stack_data b <= oretaddr) by (apply align_le; omega).
+ split. omega. omega.
Qed.
+Lemma frame_env_aligned:
+ forall b,
+ let fe := make_env b in
+ (8 | fe_ofs_arg)
+ /\ (8 | fe_ofs_local fe)
+ /\ (8 | fe_stack_data fe)
+ /\ (4 | fe_ofs_link fe)
+ /\ (4 | fe_ofs_retaddr fe).
+Proof.
+ intros; simpl.
+ set (olink := 4 * b.(bound_outgoing)).
+ set (ocs := olink + 4).
+ set (ol := align (size_callee_save_area b ocs) 8).
+ set (ostkdata := align (ol + 4 * b.(bound_local)) 8).
+ set (oretaddr := align (ostkdata + b.(bound_stack_data)) 4).
+ split. apply Zdivide_0.
+ split. apply align_divides; omega.
+ split. apply align_divides; omega.
+ split. apply Z.divide_factor_l.
+ apply align_divides; omega.
+Qed.
diff --git a/lib/Decidableplus.v b/lib/Decidableplus.v
new file mode 100644
index 00000000..932b885a
--- /dev/null
+++ b/lib/Decidableplus.v
@@ -0,0 +1,244 @@
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU General Public License as published by *)
+(* the Free Software Foundation, either version 2 of the License, or *)
+(* (at your option) any later version. This file is also distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(** This library provides type classes and tactics to decide logical
+ propositions by reflection into computable Boolean equalities.
+ It extends the [DecidableClass] module from the standard library
+ of Coq 8.5 with more instances of decidable properties, including
+ universal and existential quantification over finite types. *)
+
+(** Temporarily and for compatibility with Coq 8.4, this file includes
+ a copy of the relevant definitions from the Coq 8.5 [DecidableClass]
+ library. This library is copyright INRIA. *)
+
+Require Import Coqlib.
+
+Class Decidable (P : Prop) := {
+ Decidable_witness : bool;
+ Decidable_spec : Decidable_witness = true <-> P
+}.
+
+Lemma Decidable_sound : forall P (H : Decidable P),
+ Decidable_witness = true -> P.
+Proof.
+ intros. rewrite <- Decidable_spec. auto.
+Qed.
+
+Lemma Decidable_complete : forall P (H : Decidable P),
+ P -> Decidable_witness = true.
+Proof.
+ intros. rewrite Decidable_spec. auto.
+Qed.
+
+Lemma Decidable_sound_alt : forall P (H : Decidable P),
+ ~ P -> Decidable_witness = false.
+Proof.
+ intros. destruct Decidable_witness eqn:E; auto. elim H0. eapply Decidable_sound; eauto.
+Qed.
+
+Lemma Decidable_complete_alt : forall P (H : Decidable P),
+ Decidable_witness = false -> ~ P.
+Proof.
+ intros; red; intros. rewrite (Decidable_complete P H) in H0 by auto. discriminate.
+Qed.
+
+Definition decide P {H : Decidable P} := Decidable_witness (Decidable:=H).
+
+Ltac _decide_ P H :=
+ let b := fresh "b" in
+ set (b := decide P) in *;
+ assert (H : decide P = b) by reflexivity;
+ clearbody b;
+ destruct b; [apply Decidable_sound in H|apply Decidable_complete_alt in H].
+
+Tactic Notation "decide" constr(P) "as" ident(H) :=
+ _decide_ P H.
+
+Tactic Notation "decide" constr(P) :=
+ let H := fresh "H" in _decide_ P H.
+
+Ltac decide_goal := eapply Decidable_sound; reflexivity.
+
+(** Deciding logical connectives *)
+
+Program Instance Decidable_not (P: Prop) (dP: Decidable P) : Decidable (~ P) := {
+ Decidable_witness := negb (@Decidable_witness P dP)
+}.
+Next Obligation.
+ rewrite negb_true_iff. split. apply Decidable_complete_alt. apply Decidable_sound_alt.
+Qed.
+
+Program Instance Decidable_equiv (P Q: Prop) (dP: Decidable P) (dQ: Decidable Q) : Decidable (P <-> Q) := {
+ Decidable_witness := Bool.eqb (@Decidable_witness P dP) (@Decidable_witness Q dQ)
+}.
+Next Obligation.
+ rewrite eqb_true_iff.
+ split; intros.
+ split; intros; eapply Decidable_sound; [rewrite <- H | rewrite H]; eapply Decidable_complete; eauto.
+ destruct (@Decidable_witness Q dQ) eqn:D.
+ eapply Decidable_complete; rewrite H; eapply Decidable_sound; eauto.
+ eapply Decidable_sound_alt; rewrite H; eapply Decidable_complete_alt; eauto.
+Qed.
+
+Program Instance Decidable_and (P Q: Prop) (dP: Decidable P) (dQ: Decidable Q) : Decidable (P /\ Q) := {
+ Decidable_witness := @Decidable_witness P dP && @Decidable_witness Q dQ
+}.
+Next Obligation.
+ rewrite andb_true_iff. rewrite ! Decidable_spec. tauto.
+Qed.
+
+Program Instance Decidable_or (P Q: Prop) (dP: Decidable P) (dQ: Decidable Q) : Decidable (P \/ Q) := {
+ Decidable_witness := @Decidable_witness P dP || @Decidable_witness Q dQ
+}.
+Next Obligation.
+ rewrite orb_true_iff. rewrite ! Decidable_spec. tauto.
+Qed.
+
+Program Instance Decidable_implies (P Q: Prop) (dP: Decidable P) (dQ: Decidable Q) : Decidable (P -> Q) := {
+ Decidable_witness := if @Decidable_witness P dP then @Decidable_witness Q dQ else true
+}.
+Next Obligation.
+ split.
+- intros. rewrite Decidable_complete in H by auto. eapply Decidable_sound; eauto.
+- intros. destruct (@Decidable_witness P dP) eqn:WP; auto.
+ eapply Decidable_complete. apply H. eapply Decidable_sound; eauto.
+Qed.
+
+(** Deciding equalities. *)
+
+Program Definition Decidable_eq {A: Type} (eqdec: forall (x y: A), {x=y} + {x<>y}) (x y: A) : Decidable (eq x y) := {|
+ Decidable_witness := proj_sumbool (eqdec x y)
+|}.
+Next Obligation.
+ split; intros. InvBooleans. auto. subst y. apply dec_eq_true.
+Qed.
+
+Program Instance Decidable_eq_bool : forall (x y : bool), Decidable (eq x y) := {
+ Decidable_witness := Bool.eqb x y
+}.
+Next Obligation.
+ apply eqb_true_iff.
+Qed.
+
+Program Instance Decidable_eq_nat : forall (x y : nat), Decidable (eq x y) := {
+ Decidable_witness := beq_nat x y
+}.
+Next Obligation.
+ apply beq_nat_true_iff.
+Qed.
+
+Program Instance Decidable_eq_positive : forall (x y : positive), Decidable (eq x y) := {
+ Decidable_witness := Pos.eqb x y
+}.
+Next Obligation.
+ apply Pos.eqb_eq.
+Qed.
+
+Program Instance Decidable_eq_Z : forall (x y : Z), Decidable (eq x y) := {
+ Decidable_witness := Z.eqb x y
+}.
+Next Obligation.
+ apply Z.eqb_eq.
+Qed.
+
+(** Deciding order on Z *)
+
+Program Instance Decidable_le_Z : forall (x y: Z), Decidable (x <= y) := {
+ Decidable_witness := Z.leb x y
+}.
+Next Obligation.
+ apply Z.leb_le.
+Qed.
+
+Program Instance Decidable_lt_Z : forall (x y: Z), Decidable (x < y) := {
+ Decidable_witness := Z.ltb x y
+}.
+Next Obligation.
+ apply Z.ltb_lt.
+Qed.
+
+(** Deciding properties over lists *)
+
+Program Instance Decidable_forall_in_list :
+ forall (A: Type) (l: list A) (P: A -> Prop) (dP: forall x:A, Decidable (P x)),
+ Decidable (forall x:A, In x l -> P x) := {
+ Decidable_witness := List.forallb (fun x => @Decidable_witness (P x) (dP x)) l
+}.
+Next Obligation.
+ rewrite List.forallb_forall. split; intros.
+- eapply Decidable_sound; eauto.
+- eapply Decidable_complete; eauto.
+Qed.
+
+Program Instance Decidable_exists_in_list :
+ forall (A: Type) (l: list A) (P: A -> Prop) (dP: forall x:A, Decidable (P x)),
+ Decidable (exists x:A, In x l /\ P x) := {
+ Decidable_witness := List.existsb (fun x => @Decidable_witness (P x) (dP x)) l
+}.
+Next Obligation.
+ rewrite List.existsb_exists. split.
+- intros (x & U & V). exists x; split; auto. eapply Decidable_sound; eauto.
+- intros (x & U & V). exists x; split; auto. eapply Decidable_complete; eauto.
+Qed.
+
+(** Types with finitely many elements. *)
+
+Class Finite (T: Type) := {
+ Finite_elements: list T;
+ Finite_elements_spec: forall x:T, In x Finite_elements
+}.
+
+(** Deciding forall and exists quantification over finite types. *)
+
+Program Instance Decidable_forall : forall (T: Type) (fT: Finite T) (P: T -> Prop) (dP: forall x:T, Decidable (P x)), Decidable (forall x, P x) := {
+ Decidable_witness := List.forallb (fun x => @Decidable_witness (P x) (dP x)) (@Finite_elements T fT)
+}.
+Next Obligation.
+ rewrite List.forallb_forall. split; intros.
+- eapply Decidable_sound; eauto. apply H. apply Finite_elements_spec.
+- eapply Decidable_complete; eauto.
+Qed.
+
+Program Instance Decidable_exists : forall (T: Type) (fT: Finite T) (P: T -> Prop) (dP: forall x:T, Decidable (P x)), Decidable (exists x, P x) := {
+ Decidable_witness := List.existsb (fun x => @Decidable_witness (P x) (dP x)) (@Finite_elements T fT)
+}.
+Next Obligation.
+ rewrite List.existsb_exists. split.
+- intros (x & A & B). exists x. eapply Decidable_sound; eauto.
+- intros (x & A). exists x; split. eapply Finite_elements_spec. eapply Decidable_complete; eauto.
+Qed.
+
+(** Some examples of finite types. *)
+
+Program Instance Finite_bool : Finite bool := {
+ Finite_elements := false :: true :: nil
+}.
+Next Obligation.
+ destruct x; auto.
+Qed.
+
+Program Instance Finite_pair : forall (A B: Type) (fA: Finite A) (fB: Finite B), Finite (A * B) := {
+ Finite_elements := list_prod (@Finite_elements A fA) (@Finite_elements B fB)
+}.
+Next Obligation.
+ apply List.in_prod; eapply Finite_elements_spec.
+Qed.
+
+Program Instance Finite_option : forall (A: Type) (fA: Finite A), Finite (option A) := {
+ Finite_elements := None :: List.map (@Some A) (@Finite_elements A fA)
+}.
+Next Obligation.
+ destruct x; auto. right; apply List.in_map; eapply Finite_elements_spec.
+Qed.
diff --git a/powerpc/Conventions1.v b/powerpc/Conventions1.v
index 4ee25a32..e78395bf 100644
--- a/powerpc/Conventions1.v
+++ b/powerpc/Conventions1.v
@@ -14,6 +14,7 @@
machine registers and stack slots. *)
Require Import Coqlib.
+Require Import Decidableplus.
Require Import AST.
Require Import Events.
Require Import Locations.
@@ -29,6 +30,17 @@ Require Import Locations.
of callee- and caller-save registers.
*)
+Definition is_callee_save (r: mreg): bool :=
+ match r with
+ | R3 | R4 | R5 | R6 | R7 | R8 | R9 | R10 | R11 | R12 => false
+ | R14 | R15 | R16 | R17 | R18 | R19 | R20 | R21 | R22 | R23 | R24
+ | R25 | R26 | R27 | R28 | R29 | R30 | R31 => true
+ | F0 | F1 | F2 | F3 | F4 | F5 | F6 | F7
+ | F8 | F9 | F10 | F11 | F12 | F13 => false
+ | F14 | F15 | F16 | F17 | F18 | F19 | F20 | F21 | F22 | F23
+ | F24 | F25 | F26 | F27 | F28 | F29 | F30 | F31 => true
+ end.
+
Definition int_caller_save_regs :=
R3 :: R4 :: R5 :: R6 :: R7 :: R8 :: R9 :: R10 :: R11 :: R12 :: nil.
@@ -44,174 +56,11 @@ Definition float_callee_save_regs :=
F22 :: F21 :: F20 :: F19 :: F18 :: F17 :: F16 :: F15 :: F14 :: nil.
Definition destroyed_at_call :=
- int_caller_save_regs ++ float_caller_save_regs.
+ List.filter (fun r => negb (is_callee_save r)) all_mregs.
Definition dummy_int_reg := R3. (**r Used in [Coloring]. *)
Definition dummy_float_reg := F0. (**r Used in [Coloring]. *)
-(** The [index_int_callee_save] and [index_float_callee_save] associate
- a unique positive integer to callee-save registers. This integer is
- used in [Stacking] to determine where to save these registers in
- the activation record if they are used by the current function. *)
-
-Definition index_int_callee_save (r: mreg) :=
- match r with
- | R14 => 17 | R15 => 16 | R16 => 15 | R17 => 14
- | R18 => 13 | R19 => 12 | R20 => 11 | R21 => 10
- | R22 => 9 | R23 => 8 | R24 => 7 | R25 => 6
- | R26 => 5 | R27 => 4 | R28 => 3 | R29 => 2
- | R30 => 1 | R31 => 0 | _ => -1
- end.
-
-Definition index_float_callee_save (r: mreg) :=
- match r with
- | F14 => 17 | F15 => 16 | F16 => 15 | F17 => 14
- | F18 => 13 | F19 => 12 | F20 => 11 | F21 => 10
- | F22 => 9 | F23 => 8 | F24 => 7 | F25 => 6
- | F26 => 5 | F27 => 4 | F28 => 3 | F29 => 2
- | F30 => 1 | F31 => 0 | _ => -1
- end.
-
-Ltac ElimOrEq :=
- match goal with
- | |- (?x = ?y) \/ _ -> _ =>
- let H := fresh in
- (intro H; elim H; clear H;
- [intro H; rewrite <- H; clear H | ElimOrEq])
- | |- False -> _ =>
- let H := fresh in (intro H; contradiction)
- end.
-
-Ltac OrEq :=
- match goal with
- | |- (?x = ?x) \/ _ => left; reflexivity
- | |- (?x = ?y) \/ _ => right; OrEq
- | |- False => fail
- end.
-
-Ltac NotOrEq :=
- match goal with
- | |- (?x = ?y) \/ _ -> False =>
- let H := fresh in (
- intro H; elim H; clear H; [intro; discriminate | NotOrEq])
- | |- False -> False =>
- contradiction
- end.
-
-Lemma index_int_callee_save_pos:
- forall r, In r int_callee_save_regs -> index_int_callee_save r >= 0.
-Proof.
- intro r. simpl; ElimOrEq; unfold index_int_callee_save; omega.
-Qed.
-
-Lemma index_float_callee_save_pos:
- forall r, In r float_callee_save_regs -> index_float_callee_save r >= 0.
-Proof.
- intro r. simpl; ElimOrEq; unfold index_float_callee_save; omega.
-Qed.
-
-Lemma index_int_callee_save_pos2:
- forall r, index_int_callee_save r >= 0 -> In r int_callee_save_regs.
-Proof.
- destruct r; simpl; intro; omegaContradiction || OrEq.
-Qed.
-
-Lemma index_float_callee_save_pos2:
- forall r, index_float_callee_save r >= 0 -> In r float_callee_save_regs.
-Proof.
- destruct r; simpl; intro; omegaContradiction || OrEq.
-Qed.
-
-Lemma index_int_callee_save_inj:
- forall r1 r2,
- In r1 int_callee_save_regs ->
- In r2 int_callee_save_regs ->
- r1 <> r2 ->
- index_int_callee_save r1 <> index_int_callee_save r2.
-Proof.
- intros r1 r2.
- simpl; ElimOrEq; ElimOrEq; unfold index_int_callee_save;
- intros; congruence.
-Qed.
-
-Lemma index_float_callee_save_inj:
- forall r1 r2,
- In r1 float_callee_save_regs ->
- In r2 float_callee_save_regs ->
- r1 <> r2 ->
- index_float_callee_save r1 <> index_float_callee_save r2.
-Proof.
- intros r1 r2.
- simpl; ElimOrEq; ElimOrEq; unfold index_float_callee_save;
- intros; congruence.
-Qed.
-
-(** The following lemmas show that
- (temporaries, destroyed at call, integer callee-save, float callee-save)
- is a partition of the set of machine registers. *)
-
-Lemma int_float_callee_save_disjoint:
- list_disjoint int_callee_save_regs float_callee_save_regs.
-Proof.
- red; intros r1 r2. simpl; ElimOrEq; ElimOrEq; discriminate.
-Qed.
-
-Lemma register_classification:
- forall r,
- In r destroyed_at_call \/ In r int_callee_save_regs \/ In r float_callee_save_regs.
-Proof.
- destruct r;
- try (left; simpl; OrEq);
- try (right; left; simpl; OrEq);
- try (right; right; simpl; OrEq).
-Qed.
-
-Lemma int_callee_save_not_destroyed:
- forall r,
- In r destroyed_at_call -> In r int_callee_save_regs -> False.
-Proof.
- intros. revert H0 H. simpl. ElimOrEq; NotOrEq.
-Qed.
-
-Lemma float_callee_save_not_destroyed:
- forall r,
- In r destroyed_at_call -> In r float_callee_save_regs -> False.
-Proof.
- intros. revert H0 H. simpl. ElimOrEq; NotOrEq.
-Qed.
-
-Lemma int_callee_save_type:
- forall r, In r int_callee_save_regs -> mreg_type r = Tany32.
-Proof.
- intro. simpl; ElimOrEq; reflexivity.
-Qed.
-
-Lemma float_callee_save_type:
- forall r, In r float_callee_save_regs -> mreg_type r = Tany64.
-Proof.
- intro. simpl; ElimOrEq; reflexivity.
-Qed.
-
-Ltac NoRepet :=
- match goal with
- | |- list_norepet nil =>
- apply list_norepet_nil
- | |- list_norepet (?a :: ?b) =>
- apply list_norepet_cons; [simpl; intuition discriminate | NoRepet]
- end.
-
-Lemma int_callee_save_norepet:
- list_norepet int_callee_save_regs.
-Proof.
- unfold int_callee_save_regs; NoRepet.
-Qed.
-
-Lemma float_callee_save_norepet:
- list_norepet float_callee_save_regs.
-Proof.
- unfold float_callee_save_regs; NoRepet.
-Qed.
-
(** * Function calling conventions *)
(** The functions in this section determine the locations (machine registers
@@ -258,12 +107,12 @@ Qed.
Lemma loc_result_caller_save:
forall (s: signature) (r: mreg),
- In r (loc_result s) -> In r destroyed_at_call.
+ In r (loc_result s) -> is_callee_save r = false.
Proof.
intros.
assert (r = R3 \/ r = R4 \/ r = F1).
unfold loc_result in H. destruct (sig_res s); [destruct t|idtac]; simpl in H; intuition.
- destruct H0 as [A | [A | A]]; subst r; simpl; OrEq.
+ destruct H0 as [A | [A | A]]; subst r; reflexivity.
Qed.
(** ** Location of function arguments *)
@@ -347,20 +196,13 @@ Fixpoint size_arguments_rec (tyl: list typ) (ir fr ofs: Z) {struct tyl} : Z :=
Definition size_arguments (s: signature) : Z :=
size_arguments_rec s.(sig_args) 0 0 0.
-(** A tail-call is possible for a signature if the corresponding
- arguments are all passed in registers. *)
-
-Definition tailcall_possible (s: signature) : Prop :=
- forall l, In l (loc_arguments s) ->
- match l with R _ => True | S _ _ _ => False end.
-
(** Argument locations are either caller-save registers or [Outgoing]
stack slots at nonnegative offsets. *)
Definition loc_argument_acceptable (l: loc) : Prop :=
match l with
- | R r => In r destroyed_at_call
- | S Outgoing ofs ty => ofs >= 0 /\ ty <> Tlong
+ | R r => is_callee_save r = false
+ | S Outgoing ofs ty => ofs >= 0 /\ (typealign ty | ofs)
| _ => False
end.
@@ -369,7 +211,7 @@ Remark loc_arguments_rec_charact:
In l (loc_arguments_rec tyl ir fr ofs) ->
match l with
| R r => In r int_param_regs \/ In r float_param_regs
- | S Outgoing ofs' ty => ofs' >= ofs /\ ty <> Tlong
+ | S Outgoing ofs' ty => ofs' >= ofs /\ (typealign ty | ofs')
| S _ _ _ => False
end.
Proof.
@@ -381,13 +223,13 @@ Opaque list_nth_z.
destruct (list_nth_z int_param_regs ir) as [r|] eqn:E; destruct H.
subst. left. eapply list_nth_z_in; eauto.
eapply IHtyl; eauto.
- subst. split. omega. congruence.
+ subst. split. omega. apply Z.divide_1_l.
exploit IHtyl; eauto. destruct l; auto. destruct sl; auto. intuition omega.
- (* float *)
destruct (list_nth_z float_param_regs fr) as [r|] eqn:E; destruct H.
subst. right. eapply list_nth_z_in; eauto.
eapply IHtyl; eauto.
- subst. split. apply Zle_ge. apply align_le. omega. congruence.
+ subst. split. apply Zle_ge. apply align_le. omega. apply Z.divide_1_l.
exploit IHtyl; eauto. destruct l; auto. destruct sl; auto.
assert (ofs <= align ofs 2) by (apply align_le; omega).
intuition omega.
@@ -399,18 +241,18 @@ Opaque list_nth_z.
destruct H. subst; left; eapply list_nth_z_in; eauto.
eapply IHtyl; eauto.
assert (ofs <= align ofs 2) by (apply align_le; omega).
- destruct H. subst. split. omega. congruence.
- destruct H. subst. split. omega. congruence.
+ destruct H. subst. split. omega. apply Z.divide_1_l.
+ destruct H. subst. split. omega. apply Z.divide_1_l.
exploit IHtyl; eauto. destruct l; auto. destruct sl; auto. intuition omega.
assert (ofs <= align ofs 2) by (apply align_le; omega).
- destruct H. subst. split. omega. congruence.
- destruct H. subst. split. omega. congruence.
+ destruct H. subst. split. omega. apply Z.divide_1_l.
+ destruct H. subst. split. omega. apply Z.divide_1_l.
exploit IHtyl; eauto. destruct l; auto. destruct sl; auto. intuition omega.
- (* single *)
destruct (list_nth_z float_param_regs fr) as [r|] eqn:E; destruct H.
subst. right. eapply list_nth_z_in; eauto.
eapply IHtyl; eauto.
- subst. split. apply Zle_ge. apply align_le. omega. congruence.
+ subst. split. apply Zle_ge. apply align_le. omega. apply Z.divide_1_l.
exploit IHtyl; eauto. destruct l; auto. destruct sl; auto.
assert (ofs <= align ofs 2) by (apply align_le; omega).
intuition omega.
@@ -418,13 +260,13 @@ Opaque list_nth_z.
destruct (list_nth_z int_param_regs ir) as [r|] eqn:E; destruct H.
subst. left. eapply list_nth_z_in; eauto.
eapply IHtyl; eauto.
- subst. split. omega. congruence.
+ subst. split. omega. apply Z.divide_1_l.
exploit IHtyl; eauto. destruct l; auto. destruct sl; auto. intuition omega.
- (* any64 *)
destruct (list_nth_z float_param_regs fr) as [r|] eqn:E; destruct H.
subst. right. eapply list_nth_z_in; eauto.
eapply IHtyl; eauto.
- subst. split. apply Zle_ge. apply align_le. omega. congruence.
+ subst. split. apply Zle_ge. apply align_le. omega. apply Z.divide_1_l.
exploit IHtyl; eauto. destruct l; auto. destruct sl; auto.
assert (ofs <= align ofs 2) by (apply align_le; omega).
intuition omega.
@@ -435,10 +277,12 @@ Lemma loc_arguments_acceptable:
In l (loc_arguments s) -> loc_argument_acceptable l.
Proof.
unfold loc_arguments; intros.
+ assert (A: forall r, In r int_param_regs -> is_callee_save r = false) by decide_goal.
+ assert (B: forall r, In r float_param_regs -> is_callee_save r = false) by decide_goal.
generalize (loc_arguments_rec_charact _ _ _ _ _ H).
destruct l.
- intro H0; elim H0; simpl; ElimOrEq; OrEq.
- destruct sl; try contradiction. simpl. intuition omega.
+ intros [C|C]; simpl; auto.
+ destruct sl; try contradiction. simpl; auto.
Qed.
Hint Resolve loc_arguments_acceptable: locs.
diff --git a/powerpc/Machregs.v b/powerpc/Machregs.v
index 4ee6493c..24065254 100644
--- a/powerpc/Machregs.v
+++ b/powerpc/Machregs.v
@@ -12,6 +12,7 @@
Require Import String.
Require Import Coqlib.
+Require Import Decidableplus.
Require Import Maps.
Require Import AST.
Require Import Op.
@@ -53,6 +54,34 @@ Lemma mreg_eq: forall (r1 r2: mreg), {r1 = r2} + {r1 <> r2}.
Proof. decide equality. Defined.
Global Opaque mreg_eq.
+Definition all_mregs :=
+ R3 :: R4 :: R5 :: R6 :: R7 :: R8 :: R9 :: R10
+ :: R11 :: R12 :: R14 :: R15 :: R16 :: R17 :: R18 :: R19 :: R20
+ :: R21 :: R22 :: R23 :: R24 :: R25 :: R26 :: R27 :: R28
+ :: R29 :: R30 :: R31
+ :: F0 :: F1 :: F2 :: F3 :: F4
+ :: F5 :: F6 :: F7 :: F8
+ :: F9 :: F10 :: F11 :: F12
+ :: F13 :: F14 :: F15
+ :: F16 :: F17 :: F18 :: F19
+ :: F20 :: F21 :: F22 :: F23
+ :: F24 :: F25 :: F26 :: F27
+ :: F28 :: F29 :: F30 :: F31 :: nil.
+
+Lemma all_mregs_complete:
+ forall (r: mreg), In r all_mregs.
+Proof.
+ assert (forall r, proj_sumbool (In_dec mreg_eq r all_mregs) = true) by (destruct r; reflexivity).
+ intros. specialize (H r). InvBooleans. auto.
+Qed.
+
+Instance Decidable_eq_mreg : forall (x y: mreg), Decidable (eq x y) := Decidable_eq mreg_eq.
+
+Instance Finite_mreg : Finite mreg := {
+ Finite_elements := all_mregs;
+ Finite_elements_spec := all_mregs_complete
+}.
+
Definition mreg_type (r: mreg): typ :=
match r with
| R3 | R4 | R5 | R6 | R7 | R8 | R9 | R10 | R11 | R12
@@ -92,7 +121,7 @@ Module IndexedMreg <: INDEXED_TYPE.
Lemma index_inj:
forall r1 r2, index r1 = index r2 -> r1 = r2.
Proof.
- destruct r1; destruct r2; simpl; intro; discriminate || reflexivity.
+ decide_goal.
Qed.
End IndexedMreg.
diff --git a/powerpc/Stacklayout.v b/powerpc/Stacklayout.v
index a751fd98..2b78fd11 100644
--- a/powerpc/Stacklayout.v
+++ b/powerpc/Stacklayout.v
@@ -13,6 +13,7 @@
(** Machine- and ABI-dependent layout information for activation records. *)
Require Import Coqlib.
+Require Import Memory Separation.
Require Import Bounds.
(** In the PowerPC/EABI application binary interface,
@@ -25,8 +26,7 @@ Require Import Bounds.
frame, we will not use these 4 bytes, and just reserve them.
- Space for outgoing arguments to function calls.
- Local stack slots.
-- Saved values of integer callee-save registers used by the function.
-- Saved values of float callee-save registers used by the function.
+- Saved values of callee-save registers used by the function.
- Space for the stack-allocated data declared in Cminor.
The [frame_env] compilation environment records the positions of
@@ -35,100 +35,111 @@ the boundaries between areas in the frame part.
Definition fe_ofs_arg := 8.
-Record frame_env : Type := mk_frame_env {
- fe_size: Z;
- fe_ofs_link: Z;
- fe_ofs_retaddr: Z;
- fe_ofs_local: Z;
- fe_ofs_int_callee_save: Z;
- fe_num_int_callee_save: Z;
- fe_ofs_float_callee_save: Z;
- fe_num_float_callee_save: Z;
- fe_stack_data: Z
-}.
-
(** Computation of the frame environment from the bounds of the current
function. *)
Definition make_env (b: bounds) :=
let ol := align (8 + 4 * b.(bound_outgoing)) 8 in (* locals *)
let ora := ol + 4 * b.(bound_local) in (* saved return address *)
- let oics := ora + 4 in (* integer callee-saves *)
- let oendi := oics + 4 * b.(bound_int_callee_save) in
- let ofcs := align oendi 8 in (* float callee-saves *)
- let ostkdata := ofcs + 8 * b.(bound_float_callee_save) in (* stack data *)
+ let ocs := ora + 4 in (* callee-saves *)
+ let oendcs := size_callee_save_area b ocs in
+ let ostkdata := align oendcs 8 in (* stack data *)
let sz := align (ostkdata + b.(bound_stack_data)) 16 in
- mk_frame_env sz 0 ora
- ol
- oics b.(bound_int_callee_save)
- ofcs b.(bound_float_callee_save)
- ostkdata.
+ {| fe_size := sz;
+ fe_ofs_link := 0;
+ fe_ofs_retaddr := ora;
+ fe_ofs_local := ol;
+ fe_ofs_callee_save := ocs;
+ fe_stack_data := ostkdata;
+ fe_used_callee_save := b.(used_callee_save) |}.
(** Separation property *)
-Remark frame_env_separated:
- forall b,
+Local Open Scope sep_scope.
+
+Lemma frame_env_separated:
+ forall b sp m P,
let fe := make_env b in
- 0 <= fe.(fe_ofs_link)
- /\ fe.(fe_ofs_link) + 4 <= fe_ofs_arg
- /\ fe_ofs_arg + 4 * b.(bound_outgoing) <= fe.(fe_ofs_local)
- /\ fe.(fe_ofs_local) + 4 * b.(bound_local) <= fe.(fe_ofs_retaddr)
- /\ fe.(fe_ofs_retaddr) + 4 <= fe.(fe_ofs_int_callee_save)
- /\ fe.(fe_ofs_int_callee_save) + 4 * b.(bound_int_callee_save) <= fe.(fe_ofs_float_callee_save)
- /\ fe.(fe_ofs_float_callee_save) + 8 * b.(bound_float_callee_save) <= fe.(fe_stack_data)
- /\ fe.(fe_stack_data) + b.(bound_stack_data) <= fe.(fe_size)
- /\ fe.(fe_ofs_retaddr) + 4 <= fe.(fe_size).
+ m |= range sp 0 (fe_stack_data fe) ** range sp (fe_stack_data fe + bound_stack_data b) (fe_size fe) ** P ->
+ m |= range sp (fe_ofs_local fe) (fe_ofs_local fe + 4 * bound_local b)
+ ** range sp fe_ofs_arg (fe_ofs_arg + 4 * bound_outgoing b)
+ ** range sp (fe_ofs_link fe) (fe_ofs_link fe + 4)
+ ** range sp (fe_ofs_retaddr fe) (fe_ofs_retaddr fe + 4)
+ ** range sp (fe_ofs_callee_save fe) (size_callee_save_area b (fe_ofs_callee_save fe))
+ ** P.
Proof.
- intros.
- generalize (align_le (8 + 4 * b.(bound_outgoing)) 8 (refl_equal _)).
- generalize (align_le (fe.(fe_ofs_int_callee_save) + 4 * b.(bound_int_callee_save)) 8 (refl_equal _)).
- generalize (align_le (fe.(fe_stack_data) + b.(bound_stack_data)) 16 (refl_equal _)).
- unfold fe, make_env, fe_size, fe_ofs_link, fe_ofs_retaddr,
- fe_ofs_local, fe_ofs_int_callee_save,
- fe_num_int_callee_save,
- fe_ofs_float_callee_save, fe_num_float_callee_save,
- fe_stack_data, fe_ofs_arg.
- intros.
- generalize (bound_local_pos b); intro;
- generalize (bound_int_callee_save_pos b); intro;
- generalize (bound_float_callee_save_pos b); intro;
- generalize (bound_outgoing_pos b); intro;
- generalize (bound_stack_data_pos b); intro.
- omega.
+Local Opaque Z.add Z.mul sepconj range.
+ intros; simpl.
+ set (ol := align (8 + 4 * b.(bound_outgoing)) 8).
+ set (ora := ol + 4 * b.(bound_local)).
+ set (ocs := ora + 4).
+ set (oendcs := size_callee_save_area b ocs).
+ set (ostkdata := align oendcs 8).
+ generalize b.(bound_local_pos) b.(bound_outgoing_pos) b.(bound_stack_data_pos); intros.
+ unfold fe_ofs_arg.
+ assert (8 + 4 * b.(bound_outgoing) <= ol) by (apply align_le; omega).
+ assert (ol <= ora) by (unfold ora; omega).
+ assert (ora <= ocs) by (unfold ocs; omega).
+ assert (ocs <= oendcs) by (apply size_callee_save_area_incr).
+ assert (oendcs <= ostkdata) by (apply align_le; omega).
+(* Reorder as:
+ back link
+ outgoing
+ locals
+ retaddr
+ callee-save *)
+ rewrite sep_swap3.
+(* Apply range_split and range_split2 repeatedly *)
+ apply range_drop_right with 8. omega.
+ apply range_split. omega.
+ apply range_split_2. fold ol; omega. omega.
+ apply range_split. omega.
+ apply range_split. omega.
+ apply range_drop_right with ostkdata. omega.
+ eapply sep_drop2. eexact H.
Qed.
-(** Alignment property *)
+Lemma frame_env_range:
+ forall b,
+ let fe := make_env b in
+ 0 <= fe_stack_data fe /\ fe_stack_data fe + bound_stack_data b <= fe_size fe.
+Proof.
+ intros; simpl.
+ set (ol := align (8 + 4 * b.(bound_outgoing)) 8).
+ set (ora := ol + 4 * b.(bound_local)).
+ set (ocs := ora + 4).
+ set (oendcs := size_callee_save_area b ocs).
+ set (ostkdata := align oendcs 8).
+ generalize b.(bound_local_pos) b.(bound_outgoing_pos) b.(bound_stack_data_pos); intros.
+ unfold fe_ofs_arg.
+ assert (8 + 4 * b.(bound_outgoing) <= ol) by (apply align_le; omega).
+ assert (ol <= ora) by (unfold ora; omega).
+ assert (ora <= ocs) by (unfold ocs; omega).
+ assert (ocs <= oendcs) by (apply size_callee_save_area_incr).
+ assert (oendcs <= ostkdata) by (apply align_le; omega).
+ split. omega. apply align_le. omega.
+Qed.
-Remark frame_env_aligned:
+Lemma frame_env_aligned:
forall b,
let fe := make_env b in
- (4 | fe.(fe_ofs_link))
- /\ (8 | fe.(fe_ofs_local))
- /\ (4 | fe.(fe_ofs_int_callee_save))
- /\ (8 | fe.(fe_ofs_float_callee_save))
- /\ (4 | fe.(fe_ofs_retaddr))
- /\ (8 | fe.(fe_stack_data))
- /\ (16 | fe.(fe_size)).
+ (8 | fe_ofs_arg)
+ /\ (8 | fe_ofs_local fe)
+ /\ (8 | fe_stack_data fe)
+ /\ (4 | fe_ofs_link fe)
+ /\ (4 | fe_ofs_retaddr fe).
Proof.
- intros.
- unfold fe, make_env, fe_size, fe_ofs_link, fe_ofs_retaddr,
- fe_ofs_local, fe_ofs_int_callee_save,
- fe_num_int_callee_save,
- fe_ofs_float_callee_save, fe_num_float_callee_save,
- fe_stack_data.
- set (x1 := align (8 + 4 * bound_outgoing b) 8).
- assert (8 | x1). unfold x1; apply align_divides. omega.
- set (x2 := x1 + 4 * bound_local b).
- assert (4 | x2). unfold x2; apply Zdivide_plus_r; auto.
- apply Zdivides_trans with 8. exists 2; auto. auto.
- exists (bound_local b); ring.
- set (x3 := x2 + 4).
- assert (4 | x3). unfold x3; apply Zdivide_plus_r; auto. exists 1; auto.
- set (x4 := align (x3 + 4 * bound_int_callee_save b) 8).
- assert (8 | x4). unfold x4. apply align_divides. omega.
- set (x5 := x4 + 8 * bound_float_callee_save b).
- assert (8 | x5). unfold x5. apply Zdivide_plus_r; auto. exists (bound_float_callee_save b); ring.
- set (x6 := align (x5 + bound_stack_data b) 16).
- assert (16 | x6). unfold x6; apply align_divides. omega.
- intuition.
+ intros; simpl.
+ set (ol := align (8 + 4 * b.(bound_outgoing)) 8).
+ set (ora := ol + 4 * b.(bound_local)).
+ set (ocs := ora + 4).
+ set (oendcs := size_callee_save_area b ocs).
+ set (ostkdata := align oendcs 8).
+ split. exists (fe_ofs_arg / 8); reflexivity.
+ split. apply align_divides; omega.
+ split. apply align_divides; omega.
+ split. apply Zdivide_0.
+ apply Z.divide_add_r.
+ apply Zdivide_trans with 8. exists 2; auto. apply align_divides; omega.
+ apply Z.divide_factor_l.
Qed.