diff options
| -rw-r--r-- | .depend | 40 | ||||
| -rw-r--r-- | Makefile | 5 | ||||
| -rw-r--r-- | arm/Conventions1.v | 235 | ||||
| -rw-r--r-- | arm/Machregs.v | 23 | ||||
| -rw-r--r-- | arm/Stacklayout.v | 171 | ||||
| -rw-r--r-- | backend/Allocation.v | 5 | ||||
| -rw-r--r-- | backend/Allocproof.v | 22 | ||||
| -rw-r--r-- | backend/Bounds.v | 334 | ||||
| -rw-r--r-- | backend/IRC.ml | 4 | ||||
| -rw-r--r-- | backend/LTL.v | 5 | ||||
| -rw-r--r-- | backend/Lineartyping.v | 7 | ||||
| -rw-r--r-- | backend/Locations.v | 22 | ||||
| -rw-r--r-- | backend/Stacking.v | 113 | ||||
| -rw-r--r-- | backend/Stackingproof.v | 2806 | ||||
| -rw-r--r-- | common/Separation.v | 916 | ||||
| -rw-r--r-- | extraction/extraction.v | 2 | ||||
| -rw-r--r-- | ia32/Asmgenproof1.v | 2 | ||||
| -rw-r--r-- | ia32/Conventions1.v | 177 | ||||
| -rw-r--r-- | ia32/Machregs.v | 22 | ||||
| -rw-r--r-- | ia32/Machregsaux.ml | 5 | ||||
| -rw-r--r-- | ia32/Stacklayout.v | 174 | ||||
| -rw-r--r-- | lib/Decidableplus.v | 244 | ||||
| -rw-r--r-- | powerpc/Conventions1.v | 218 | ||||
| -rw-r--r-- | powerpc/Machregs.v | 31 | ||||
| -rw-r--r-- | powerpc/Stacklayout.v | 171 |
25 files changed, 2973 insertions, 2781 deletions
@@ -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 @@ -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. |