diff options
76 files changed, 10378 insertions, 6210 deletions
@@ -2,6 +2,7 @@ lib/Coqlib.vo: lib/Coqlib.v lib/Floats.vo: lib/Floats.v lib/Coqlib.vo lib/Integers.vo lib/Inclusion.vo: lib/Inclusion.v lib/Integers.vo: lib/Integers.v lib/Coqlib.vo +lib/Intv.vo: lib/Intv.v lib/Coqlib.vo lib/Iteration.vo: lib/Iteration.v lib/Coqlib.vo lib/Lattice.vo: lib/Lattice.v lib/Coqlib.vo lib/Maps.vo lib/Maps.vo: lib/Maps.v lib/Coqlib.vo @@ -11,87 +12,87 @@ lib/UnionFind.vo: lib/UnionFind.v lib/Coqlib.vo common/AST.vo: common/AST.v lib/Coqlib.vo common/Errors.vo lib/Integers.vo lib/Floats.vo common/Determinism.vo: common/Determinism.v lib/Coqlib.vo common/AST.vo lib/Integers.vo common/Values.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo common/Errors.vo: common/Errors.v lib/Coqlib.vo -common/Events.vo: common/Events.v lib/Coqlib.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Mem.vo -common/Globalenvs.vo: common/Globalenvs.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Mem.vo -common/Mem2.vo: common/Mem2.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo +common/Events.vo: common/Events.v lib/Coqlib.vo lib/Intv.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo +common/Globalenvs.vo: common/Globalenvs.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo +common/Memdata.vo: common/Memdata.v lib/Coqlib.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo +common/Memory.vo: common/Memory.v lib/Coqlib.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memdata.vo common/Memtype.vo +common/Memtype.vo: common/Memtype.v lib/Coqlib.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memdata.vo common/Mem.vo: common/Mem.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Smallstep.vo: common/Smallstep.v lib/Coqlib.vo common/AST.vo common/Events.vo common/Globalenvs.vo lib/Integers.vo common/Switch.vo: common/Switch.v lib/Coqlib.vo lib/Integers.vo lib/Ordered.vo common/Values.vo: common/Values.v lib/Coqlib.vo common/AST.vo lib/Integers.vo lib/Floats.vo $(ARCH)/$(VARIANT)/Conventions.vo: $(ARCH)/$(VARIANT)/Conventions.v lib/Coqlib.vo common/AST.vo backend/Locations.vo $(ARCH)/$(VARIANT)/Stacklayout.vo: $(ARCH)/$(VARIANT)/Stacklayout.v lib/Coqlib.vo backend/Bounds.vo -$(ARCH)/Asmgenproof1.vo: $(ARCH)/Asmgenproof1.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Mem.vo common/Globalenvs.vo $(ARCH)/Op.vo backend/Locations.vo backend/Mach.vo backend/Machconcr.vo backend/Machtyping.vo $(ARCH)/Asm.vo $(ARCH)/Asmgen.vo $(ARCH)/$(VARIANT)/Conventions.vo -$(ARCH)/Asmgenproof.vo: $(ARCH)/Asmgenproof.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Mem.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Locations.vo backend/Mach.vo backend/Machconcr.vo backend/Machtyping.vo $(ARCH)/Asm.vo $(ARCH)/Asmgen.vo $(ARCH)/Asmgenretaddr.vo $(ARCH)/Asmgenproof1.vo -$(ARCH)/Asmgenretaddr.vo: $(ARCH)/Asmgenretaddr.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Mem.vo common/Globalenvs.vo $(ARCH)/Op.vo backend/Locations.vo backend/Mach.vo $(ARCH)/Asm.vo $(ARCH)/Asmgen.vo -$(ARCH)/Asmgen.vo: $(ARCH)/Asmgen.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Mem.vo common/Globalenvs.vo $(ARCH)/Op.vo backend/Locations.vo backend/Mach.vo $(ARCH)/Asm.vo -$(ARCH)/Asm.vo: $(ARCH)/Asm.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Mem.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo backend/Locations.vo $(ARCH)/$(VARIANT)/Stacklayout.vo $(ARCH)/$(VARIANT)/Conventions.vo -$(ARCH)/ConstpropOpproof.vo: $(ARCH)/ConstpropOpproof.v lib/Coqlib.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Mem.vo common/Globalenvs.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo $(ARCH)/ConstpropOp.vo backend/Constprop.vo +$(ARCH)/Asmgenproof1.vo: $(ARCH)/Asmgenproof1.v lib/Coqlib.vo lib/Maps.vo common/AST.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 backend/Machconcr.vo backend/Machtyping.vo $(ARCH)/Asm.vo $(ARCH)/Asmgen.vo $(ARCH)/$(VARIANT)/Conventions.vo +$(ARCH)/Asmgenproof.vo: $(ARCH)/Asmgenproof.v lib/Coqlib.vo lib/Maps.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/Machconcr.vo backend/Machtyping.vo $(ARCH)/Asm.vo $(ARCH)/Asmgen.vo $(ARCH)/Asmgenretaddr.vo $(ARCH)/Asmgenproof1.vo +$(ARCH)/Asmgenretaddr.vo: $(ARCH)/Asmgenretaddr.v lib/Coqlib.vo lib/Maps.vo common/AST.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 +$(ARCH)/Asmgen.vo: $(ARCH)/Asmgen.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo common/AST.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)/Asm.vo: $(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)/$(VARIANT)/Stacklayout.vo $(ARCH)/$(VARIANT)/Conventions.vo +$(ARCH)/ConstpropOpproof.vo: $(ARCH)/ConstpropOpproof.v lib/Coqlib.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Globalenvs.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo $(ARCH)/ConstpropOp.vo backend/Constprop.vo $(ARCH)/ConstpropOp.vo: $(ARCH)/ConstpropOp.v lib/Coqlib.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo $(ARCH)/Op.vo backend/Registers.vo $(ARCH)/extractionMachdep.vo: $(ARCH)/extractionMachdep.v $(ARCH)/Machregs.vo: $(ARCH)/Machregs.v lib/Coqlib.vo lib/Maps.vo common/AST.vo -$(ARCH)/Op.vo: $(ARCH)/Op.v lib/Coqlib.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Mem.vo common/Globalenvs.vo -$(ARCH)/SelectOpproof.vo: $(ARCH)/SelectOpproof.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Mem.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo backend/Cminor.vo $(ARCH)/Op.vo backend/CminorSel.vo $(ARCH)/SelectOp.vo -$(ARCH)/SelectOp.vo: $(ARCH)/SelectOp.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Mem.vo common/Globalenvs.vo backend/Cminor.vo $(ARCH)/Op.vo backend/CminorSel.vo +$(ARCH)/Op.vo: $(ARCH)/Op.v lib/Coqlib.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memdata.vo common/Memory.vo common/Globalenvs.vo +$(ARCH)/SelectOpproof.vo: $(ARCH)/SelectOpproof.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/Cminor.vo $(ARCH)/Op.vo backend/CminorSel.vo $(ARCH)/SelectOp.vo +$(ARCH)/SelectOp.vo: $(ARCH)/SelectOp.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Globalenvs.vo backend/Cminor.vo $(ARCH)/Op.vo backend/CminorSel.vo backend/Allocation.vo: backend/Allocation.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo lib/Lattice.vo common/AST.vo lib/Integers.vo common/Values.vo common/Globalenvs.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo backend/RTLtyping.vo backend/Kildall.vo backend/Locations.vo $(ARCH)/$(VARIANT)/Conventions.vo backend/Coloring.vo backend/LTL.vo -backend/Allocproof.vo: backend/Allocproof.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Mem.vo common/Events.vo common/Smallstep.vo common/Globalenvs.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo backend/RTLtyping.vo backend/Locations.vo $(ARCH)/$(VARIANT)/Conventions.vo backend/Coloring.vo backend/Coloringproof.vo backend/Allocation.vo backend/LTL.vo +backend/Allocproof.vo: backend/Allocproof.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Memory.vo common/Events.vo common/Smallstep.vo common/Globalenvs.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo backend/RTLtyping.vo backend/Locations.vo $(ARCH)/$(VARIANT)/Conventions.vo backend/Coloring.vo backend/Coloringproof.vo backend/Allocation.vo backend/LTL.vo backend/Alloctyping.vo: backend/Alloctyping.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo common/AST.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo backend/Locations.vo backend/LTL.vo backend/Coloring.vo backend/Coloringproof.vo backend/Allocation.vo backend/Allocproof.vo backend/RTLtyping.vo backend/LTLtyping.vo $(ARCH)/$(VARIANT)/Conventions.vo backend/Bounds.vo: backend/Bounds.v lib/Coqlib.vo lib/Maps.vo common/AST.vo $(ARCH)/Op.vo backend/Locations.vo backend/Linear.vo backend/Lineartyping.vo $(ARCH)/$(VARIANT)/Conventions.vo -backend/CminorSel.vo: backend/CminorSel.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Events.vo common/Values.vo common/Mem.vo backend/Cminor.vo $(ARCH)/Op.vo common/Globalenvs.vo common/Switch.vo common/Smallstep.vo -backend/Cminor.vo: 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/Mem.vo common/Globalenvs.vo common/Smallstep.vo common/Switch.vo +backend/CminorSel.vo: backend/CminorSel.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 backend/Cminor.vo $(ARCH)/Op.vo common/Globalenvs.vo common/Switch.vo common/Smallstep.vo +backend/Cminor.vo: 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 backend/Coloringproof.vo: backend/Coloringproof.v lib/Coqlib.vo lib/Maps.vo common/AST.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo backend/RTLtyping.vo backend/Locations.vo $(ARCH)/$(VARIANT)/Conventions.vo backend/InterfGraph.vo backend/Coloring.vo backend/Coloring.vo: backend/Coloring.v lib/Coqlib.vo lib/Maps.vo common/AST.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo backend/RTLtyping.vo backend/Locations.vo $(ARCH)/$(VARIANT)/Conventions.vo backend/InterfGraph.vo -backend/Constpropproof.vo: backend/Constpropproof.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Events.vo common/Mem.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo lib/Lattice.vo backend/Kildall.vo $(ARCH)/ConstpropOp.vo backend/Constprop.vo $(ARCH)/ConstpropOpproof.vo +backend/Constpropproof.vo: backend/Constpropproof.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Events.vo common/Memory.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo lib/Lattice.vo backend/Kildall.vo $(ARCH)/ConstpropOp.vo backend/Constprop.vo $(ARCH)/ConstpropOpproof.vo backend/Constprop.vo: backend/Constprop.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Globalenvs.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo lib/Lattice.vo backend/Kildall.vo $(ARCH)/ConstpropOp.vo -backend/CSEproof.vo: backend/CSEproof.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Mem.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo backend/Kildall.vo backend/CSE.vo -backend/CSE.vo: backend/CSE.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Mem.vo common/Globalenvs.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo backend/Kildall.vo +backend/CSEproof.vo: backend/CSEproof.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 $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo backend/Kildall.vo backend/CSE.vo +backend/CSE.vo: backend/CSE.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Globalenvs.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo backend/Kildall.vo backend/InterfGraph.vo: backend/InterfGraph.v lib/Coqlib.vo lib/Maps.vo lib/Ordered.vo backend/Registers.vo backend/Locations.vo backend/Kildall.vo: backend/Kildall.v lib/Coqlib.vo lib/Iteration.vo lib/Maps.vo lib/Lattice.vo lib/Ordered.vo -backend/Linearizeproof.vo: backend/Linearizeproof.v lib/Coqlib.vo lib/Maps.vo lib/Ordered.vo common/AST.vo lib/Integers.vo common/Values.vo common/Mem.vo common/Events.vo common/Globalenvs.vo common/Errors.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Locations.vo backend/LTL.vo backend/LTLtyping.vo backend/LTLin.vo backend/Linearize.vo lib/Lattice.vo +backend/Linearizeproof.vo: backend/Linearizeproof.v lib/Coqlib.vo lib/Maps.vo lib/Ordered.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/LTLtyping.vo backend/LTLin.vo backend/Linearize.vo lib/Lattice.vo backend/Linearizetyping.vo: backend/Linearizetyping.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo common/AST.vo $(ARCH)/Op.vo backend/Locations.vo backend/LTL.vo backend/LTLtyping.vo backend/LTLin.vo backend/Linearize.vo backend/LTLintyping.vo $(ARCH)/$(VARIANT)/Conventions.vo backend/Linearize.vo: backend/Linearize.v lib/Coqlib.vo lib/Maps.vo lib/Ordered.vo common/AST.vo common/Values.vo common/Globalenvs.vo common/Errors.vo $(ARCH)/Op.vo backend/Locations.vo backend/LTL.vo backend/LTLin.vo backend/Kildall.vo lib/Lattice.vo -backend/Lineartyping.vo: backend/Lineartyping.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo $(ARCH)/Op.vo backend/RTL.vo backend/Locations.vo backend/Linear.vo $(ARCH)/$(VARIANT)/Conventions.vo -backend/Linear.vo: backend/Linear.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Mem.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Locations.vo backend/LTL.vo $(ARCH)/$(VARIANT)/Conventions.vo +backend/Lineartyping.vo: backend/Lineartyping.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Memdata.vo $(ARCH)/Op.vo backend/RTL.vo backend/Locations.vo backend/Linear.vo $(ARCH)/$(VARIANT)/Conventions.vo +backend/Linear.vo: backend/Linear.v lib/Coqlib.vo lib/Maps.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 $(ARCH)/$(VARIANT)/Conventions.vo backend/Locations.vo: backend/Locations.v lib/Coqlib.vo lib/Maps.vo common/AST.vo common/Values.vo $(ARCH)/Machregs.vo -backend/LTLintyping.vo: backend/LTLintyping.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo $(ARCH)/Op.vo backend/RTL.vo backend/Locations.vo backend/LTLin.vo backend/LTLtyping.vo $(ARCH)/$(VARIANT)/Conventions.vo -backend/LTLin.vo: backend/LTLin.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Mem.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Locations.vo backend/LTL.vo $(ARCH)/$(VARIANT)/Conventions.vo -backend/LTLtyping.vo: backend/LTLtyping.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo $(ARCH)/Op.vo backend/RTL.vo backend/Locations.vo backend/LTL.vo $(ARCH)/$(VARIANT)/Conventions.vo -backend/LTL.vo: backend/LTL.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Events.vo common/Mem.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Locations.vo $(ARCH)/$(VARIANT)/Conventions.vo -backend/Machabstr2concr.vo: backend/Machabstr2concr.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Mem.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Locations.vo backend/Mach.vo backend/Machtyping.vo backend/Machabstr.vo backend/Machconcr.vo $(ARCH)/Asmgenretaddr.vo -backend/Machabstrblock.vo: backend/Machabstrblock.v lib/Coqlib.vo lib/Maps.vo common/AST.vo common/Mem.vo lib/Integers.vo common/Values.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Locations.vo $(ARCH)/$(VARIANT)/Conventions.vo backend/Mach.vo backend/Machabstr.vo $(ARCH)/$(VARIANT)/Stacklayout.vo -backend/Machabstr.vo: backend/Machabstr.v lib/Coqlib.vo lib/Maps.vo common/AST.vo common/Mem.vo lib/Integers.vo common/Values.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Locations.vo $(ARCH)/$(VARIANT)/Conventions.vo backend/Mach.vo $(ARCH)/$(VARIANT)/Stacklayout.vo -backend/Machconcr.vo: backend/Machconcr.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Mem.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Locations.vo $(ARCH)/$(VARIANT)/Conventions.vo backend/Mach.vo $(ARCH)/$(VARIANT)/Stacklayout.vo $(ARCH)/Asmgenretaddr.vo -backend/Machtyping.vo: backend/Machtyping.v lib/Coqlib.vo lib/Maps.vo common/AST.vo common/Mem.vo lib/Integers.vo common/Values.vo common/Events.vo common/Globalenvs.vo $(ARCH)/Op.vo backend/Locations.vo $(ARCH)/$(VARIANT)/Conventions.vo backend/Mach.vo backend/Machabstr.vo -backend/Mach.vo: backend/Mach.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Mem.vo common/Events.vo common/Globalenvs.vo $(ARCH)/Op.vo backend/Locations.vo +backend/LTLintyping.vo: backend/LTLintyping.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Memdata.vo $(ARCH)/Op.vo backend/RTL.vo backend/Locations.vo backend/LTLin.vo backend/LTLtyping.vo $(ARCH)/$(VARIANT)/Conventions.vo +backend/LTLin.vo: backend/LTLin.v lib/Coqlib.vo lib/Maps.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 $(ARCH)/$(VARIANT)/Conventions.vo +backend/LTLtyping.vo: backend/LTLtyping.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Memdata.vo $(ARCH)/Op.vo backend/RTL.vo backend/Locations.vo backend/LTL.vo $(ARCH)/$(VARIANT)/Conventions.vo +backend/LTL.vo: 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 $(ARCH)/$(VARIANT)/Conventions.vo +backend/Machabstr2concr.vo: backend/Machabstr2concr.v lib/Coqlib.vo lib/Maps.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/Mach.vo backend/Machtyping.vo backend/Machabstr.vo backend/Machconcr.vo $(ARCH)/Asmgenretaddr.vo +backend/Machabstr.vo: backend/Machabstr.v lib/Coqlib.vo lib/Maps.vo common/AST.vo common/Memory.vo lib/Integers.vo common/Values.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Locations.vo $(ARCH)/$(VARIANT)/Conventions.vo backend/Mach.vo $(ARCH)/$(VARIANT)/Stacklayout.vo +backend/Machconcr.vo: backend/Machconcr.v lib/Coqlib.vo lib/Maps.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 $(ARCH)/$(VARIANT)/Conventions.vo backend/Mach.vo $(ARCH)/$(VARIANT)/Stacklayout.vo $(ARCH)/Asmgenretaddr.vo +backend/Machtyping.vo: backend/Machtyping.v lib/Coqlib.vo lib/Maps.vo common/AST.vo common/Memory.vo lib/Integers.vo common/Values.vo common/Events.vo common/Globalenvs.vo $(ARCH)/Op.vo backend/Locations.vo $(ARCH)/$(VARIANT)/Conventions.vo backend/Mach.vo backend/Machabstr.vo +backend/Mach.vo: backend/Mach.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo $(ARCH)/Op.vo backend/Locations.vo backend/Parallelmove.vo: backend/Parallelmove.v lib/Coqlib.vo lib/Parmov.vo common/Values.vo common/Events.vo common/AST.vo backend/Locations.vo $(ARCH)/$(VARIANT)/Conventions.vo backend/Registers.vo: backend/Registers.v lib/Coqlib.vo common/AST.vo lib/Maps.vo lib/Ordered.vo -backend/Reloadproof.vo: backend/Reloadproof.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Mem.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Locations.vo $(ARCH)/$(VARIANT)/Conventions.vo backend/Allocproof.vo backend/LTLin.vo backend/LTLintyping.vo backend/Linear.vo backend/Parallelmove.vo backend/Reload.vo +backend/Reloadproof.vo: backend/Reloadproof.v lib/Coqlib.vo lib/Maps.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 $(ARCH)/$(VARIANT)/Conventions.vo backend/Allocproof.vo backend/LTLin.vo backend/LTLintyping.vo backend/Linear.vo backend/Parallelmove.vo backend/Reload.vo backend/Reloadtyping.vo: backend/Reloadtyping.v lib/Coqlib.vo lib/Maps.vo common/AST.vo $(ARCH)/Op.vo backend/Locations.vo backend/LTLin.vo backend/LTLintyping.vo backend/Linear.vo backend/Lineartyping.vo $(ARCH)/$(VARIANT)/Conventions.vo backend/Parallelmove.vo backend/Reload.vo backend/Reloadproof.vo backend/Reload.vo: backend/Reload.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Globalenvs.vo $(ARCH)/Op.vo backend/Locations.vo backend/LTLin.vo $(ARCH)/$(VARIANT)/Conventions.vo backend/Parallelmove.vo backend/Linear.vo -backend/RTLgenproof.vo: backend/RTLgenproof.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Mem.vo common/Events.vo common/Smallstep.vo common/Globalenvs.vo common/Switch.vo backend/Registers.vo backend/Cminor.vo $(ARCH)/Op.vo backend/CminorSel.vo backend/RTL.vo backend/RTLgen.vo backend/RTLgenspec.vo common/Errors.vo -backend/RTLgenspec.vo: backend/RTLgenspec.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Events.vo common/Mem.vo common/Globalenvs.vo common/Switch.vo $(ARCH)/Op.vo backend/Registers.vo backend/CminorSel.vo backend/RTL.vo backend/RTLgen.vo +backend/RTLgenproof.vo: backend/RTLgenproof.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Memory.vo common/Events.vo common/Smallstep.vo common/Globalenvs.vo common/Switch.vo backend/Registers.vo backend/Cminor.vo $(ARCH)/Op.vo backend/CminorSel.vo backend/RTL.vo backend/RTLgen.vo backend/RTLgenspec.vo common/Errors.vo +backend/RTLgenspec.vo: backend/RTLgenspec.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Events.vo common/Memory.vo common/Globalenvs.vo common/Switch.vo $(ARCH)/Op.vo backend/Registers.vo backend/CminorSel.vo backend/RTL.vo backend/RTLgen.vo backend/RTLgen.vo: backend/RTLgen.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Switch.vo $(ARCH)/Op.vo backend/Registers.vo backend/CminorSel.vo backend/RTL.vo -backend/RTLtyping.vo: backend/RTLtyping.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo common/AST.vo $(ARCH)/Op.vo backend/Registers.vo common/Globalenvs.vo common/Values.vo common/Mem.vo lib/Integers.vo common/Events.vo common/Smallstep.vo backend/RTL.vo $(ARCH)/$(VARIANT)/Conventions.vo -backend/RTL.vo: backend/RTL.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Events.vo common/Mem.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Registers.vo -backend/Selectionproof.vo: backend/Selectionproof.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Mem.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo backend/Cminor.vo $(ARCH)/Op.vo backend/CminorSel.vo $(ARCH)/SelectOp.vo backend/Selection.vo $(ARCH)/SelectOpproof.vo -backend/Selection.vo: backend/Selection.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Mem.vo common/Globalenvs.vo backend/Cminor.vo $(ARCH)/Op.vo backend/CminorSel.vo $(ARCH)/SelectOp.vo -backend/Stackingproof.vo: backend/Stackingproof.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo common/AST.vo lib/Integers.vo common/Values.vo $(ARCH)/Op.vo common/Mem.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo backend/Locations.vo backend/Linear.vo backend/Lineartyping.vo backend/Mach.vo backend/Machabstr.vo backend/Bounds.vo $(ARCH)/$(VARIANT)/Conventions.vo $(ARCH)/$(VARIANT)/Stacklayout.vo backend/Stacking.vo +backend/RTLtyping.vo: backend/RTLtyping.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo common/AST.vo $(ARCH)/Op.vo backend/Registers.vo common/Globalenvs.vo common/Values.vo common/Memory.vo lib/Integers.vo common/Events.vo common/Smallstep.vo backend/RTL.vo $(ARCH)/$(VARIANT)/Conventions.vo +backend/RTL.vo: backend/RTL.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/Registers.vo +backend/Selectionproof.vo: backend/Selectionproof.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/Cminor.vo $(ARCH)/Op.vo backend/CminorSel.vo $(ARCH)/SelectOp.vo backend/Selection.vo $(ARCH)/SelectOpproof.vo +backend/Selection.vo: backend/Selection.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Globalenvs.vo backend/Cminor.vo $(ARCH)/Op.vo backend/CminorSel.vo $(ARCH)/SelectOp.vo +backend/Stackingproof.vo: backend/Stackingproof.v lib/Coqlib.vo lib/Maps.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/Linear.vo backend/Lineartyping.vo backend/Mach.vo backend/Machabstr.vo backend/Bounds.vo $(ARCH)/$(VARIANT)/Conventions.vo $(ARCH)/$(VARIANT)/Stacklayout.vo backend/Stacking.vo backend/Stackingtyping.vo: backend/Stackingtyping.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo lib/Integers.vo common/AST.vo $(ARCH)/Op.vo backend/Locations.vo $(ARCH)/$(VARIANT)/Conventions.vo backend/Linear.vo backend/Lineartyping.vo backend/Mach.vo backend/Machtyping.vo backend/Bounds.vo $(ARCH)/$(VARIANT)/Stacklayout.vo backend/Stacking.vo backend/Stackingproof.vo backend/Stacking.vo: backend/Stacking.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo common/AST.vo lib/Integers.vo $(ARCH)/Op.vo backend/RTL.vo backend/Locations.vo backend/Linear.vo backend/Bounds.vo backend/Mach.vo $(ARCH)/$(VARIANT)/Conventions.vo $(ARCH)/$(VARIANT)/Stacklayout.vo -backend/Tailcallproof.vo: backend/Tailcallproof.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Mem.vo $(ARCH)/Op.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo backend/Registers.vo backend/RTL.vo $(ARCH)/$(VARIANT)/Conventions.vo backend/Tailcall.vo +backend/Tailcallproof.vo: backend/Tailcallproof.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Memory.vo $(ARCH)/Op.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo backend/Registers.vo backend/RTL.vo $(ARCH)/$(VARIANT)/Conventions.vo backend/Tailcall.vo backend/Tailcall.vo: backend/Tailcall.v lib/Coqlib.vo lib/Maps.vo common/AST.vo common/Globalenvs.vo backend/Registers.vo $(ARCH)/Op.vo backend/RTL.vo $(ARCH)/$(VARIANT)/Conventions.vo -backend/Tunnelingproof.vo: backend/Tunnelingproof.v lib/Coqlib.vo lib/Maps.vo lib/UnionFind.vo common/AST.vo common/Values.vo common/Mem.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Locations.vo backend/LTL.vo backend/Tunneling.vo -backend/Tunnelingtyping.vo: backend/Tunnelingtyping.v lib/Coqlib.vo lib/Maps.vo lib/UnionFind.vo common/AST.vo common/Values.vo common/Mem.vo common/Globalenvs.vo $(ARCH)/Op.vo backend/Locations.vo backend/LTL.vo backend/LTLtyping.vo backend/Tunneling.vo backend/Tunnelingproof.vo +backend/Tunnelingproof.vo: 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/Tunnelingtyping.vo: backend/Tunnelingtyping.v lib/Coqlib.vo lib/Maps.vo lib/UnionFind.vo common/AST.vo common/Values.vo common/Memory.vo common/Globalenvs.vo $(ARCH)/Op.vo backend/Locations.vo backend/LTL.vo backend/LTLtyping.vo backend/Tunneling.vo backend/Tunnelingproof.vo backend/Tunneling.vo: backend/Tunneling.v lib/Coqlib.vo lib/Maps.vo lib/UnionFind.vo common/AST.vo common/Values.vo common/Globalenvs.vo $(ARCH)/Op.vo backend/Locations.vo backend/LTL.vo -cfrontend/Cmedium.saved.vo: cfrontend/Cmedium.saved.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/AST.vo common/Mem.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo cfrontend/Csyntax.vo cfrontend/Csem.vo -cfrontend/Cmedium.vo: cfrontend/Cmedium.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/AST.vo common/Mem.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo cfrontend/Csyntax.vo cfrontend/Csem.vo -cfrontend/Cminorgenproof.vo: cfrontend/Cminorgenproof.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Mem.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo cfrontend/Csharpminor.vo $(ARCH)/Op.vo backend/Cminor.vo cfrontend/Cminorgen.vo common/Switch.vo -cfrontend/Cminorgen.vo: cfrontend/Cminorgen.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo lib/Ordered.vo common/AST.vo lib/Integers.vo common/Mem.vo cfrontend/Csharpminor.vo $(ARCH)/Op.vo backend/Cminor.vo -cfrontend/Csem.vo: 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/Mem.vo common/Events.vo common/Globalenvs.vo cfrontend/Csyntax.vo common/Smallstep.vo -cfrontend/Csharpminor.vo: cfrontend/Csharpminor.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Mem.vo common/Events.vo common/Globalenvs.vo backend/Cminor.vo common/Smallstep.vo -cfrontend/Cshmgenproof1.vo: cfrontend/Cshmgenproof1.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/AST.vo common/Values.vo common/Events.vo common/Mem.vo common/Globalenvs.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Ctyping.vo backend/Cminor.vo cfrontend/Csharpminor.vo cfrontend/Cshmgen.vo -cfrontend/Cshmgenproof2.vo: cfrontend/Cshmgenproof2.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/AST.vo common/Values.vo common/Events.vo common/Mem.vo common/Globalenvs.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Ctyping.vo backend/Cminor.vo cfrontend/Csharpminor.vo cfrontend/Cshmgen.vo cfrontend/Cshmgenproof1.vo -cfrontend/Cshmgenproof3.vo: cfrontend/Cshmgenproof3.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/AST.vo common/Values.vo common/Events.vo common/Mem.vo common/Globalenvs.vo common/Smallstep.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Ctyping.vo backend/Cminor.vo cfrontend/Csharpminor.vo cfrontend/Cshmgen.vo cfrontend/Cshmgenproof1.vo cfrontend/Cshmgenproof2.vo +cfrontend/Cminorgenproof.vo: cfrontend/Cminorgenproof.v lib/Coqlib.vo lib/Intv.vo common/Errors.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memdata.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo common/Switch.vo cfrontend/Csharpminor.vo backend/Cminor.vo cfrontend/Cminorgen.vo +cfrontend/Cminorgen.vo: cfrontend/Cminorgen.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo lib/Ordered.vo common/AST.vo lib/Integers.vo common/Memdata.vo cfrontend/Csharpminor.vo backend/Cminor.vo +cfrontend/Csem.vo: 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/Csyntax.vo common/Smallstep.vo +cfrontend/Csharpminor.vo: cfrontend/Csharpminor.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 backend/Cminor.vo common/Smallstep.vo +cfrontend/Cshmgenproof1.vo: cfrontend/Cshmgenproof1.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/AST.vo common/Values.vo common/Events.vo common/Memory.vo common/Globalenvs.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Ctyping.vo backend/Cminor.vo cfrontend/Csharpminor.vo cfrontend/Cshmgen.vo +cfrontend/Cshmgenproof2.vo: cfrontend/Cshmgenproof2.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/AST.vo common/Values.vo common/Events.vo common/Memory.vo common/Globalenvs.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Ctyping.vo backend/Cminor.vo cfrontend/Csharpminor.vo cfrontend/Cshmgen.vo cfrontend/Cshmgenproof1.vo +cfrontend/Cshmgenproof3.vo: cfrontend/Cshmgenproof3.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/AST.vo common/Values.vo common/Events.vo common/Memory.vo common/Globalenvs.vo common/Smallstep.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Ctyping.vo backend/Cminor.vo cfrontend/Csharpminor.vo cfrontend/Cshmgen.vo cfrontend/Cshmgenproof1.vo cfrontend/Cshmgenproof2.vo cfrontend/Cshmgen.vo: cfrontend/Cshmgen.v lib/Coqlib.vo common/Errors.vo lib/Integers.vo lib/Floats.vo common/AST.vo cfrontend/Csyntax.vo backend/Cminor.vo cfrontend/Csharpminor.vo +cfrontend/Cshmtyping.vo: cfrontend/Cshmtyping.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Events.vo common/Values.vo common/Memdata.vo common/Memory.vo cfrontend/Csharpminor.vo cfrontend/Csyntax.vo: cfrontend/Csyntax.v lib/Coqlib.vo common/Errors.vo lib/Integers.vo lib/Floats.vo common/AST.vo cfrontend/Ctyping.vo: cfrontend/Ctyping.v lib/Coqlib.vo lib/Maps.vo common/AST.vo cfrontend/Csyntax.vo driver/Compiler.vo: driver/Compiler.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo common/AST.vo common/Values.vo common/Smallstep.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Csharpminor.vo backend/Cminor.vo backend/CminorSel.vo backend/RTL.vo backend/LTL.vo backend/LTLin.vo backend/Linear.vo backend/Mach.vo $(ARCH)/Asm.vo cfrontend/Cshmgen.vo cfrontend/Cminorgen.vo backend/Selection.vo backend/RTLgen.vo backend/Tailcall.vo backend/Constprop.vo backend/CSE.vo backend/Allocation.vo backend/Tunneling.vo backend/Linearize.vo backend/Reload.vo backend/Stacking.vo $(ARCH)/Asmgen.vo cfrontend/Ctyping.vo backend/RTLtyping.vo backend/LTLtyping.vo backend/LTLintyping.vo backend/Lineartyping.vo backend/Machtyping.vo cfrontend/Cshmgenproof3.vo cfrontend/Cminorgenproof.vo backend/Selectionproof.vo backend/RTLgenproof.vo backend/Tailcallproof.vo backend/Constpropproof.vo backend/CSEproof.vo backend/Allocproof.vo backend/Alloctyping.vo backend/Tunnelingproof.vo backend/Tunnelingtyping.vo backend/Linearizeproof.vo backend/Linearizetyping.vo backend/Reloadproof.vo backend/Reloadtyping.vo backend/Stackingproof.vo backend/Stackingtyping.vo backend/Machabstr2concr.vo $(ARCH)/Asmgenproof.vo @@ -33,12 +33,12 @@ GPATH=$(DIRS) # General-purpose libraries (in lib/) -LIB=Coqlib.v Maps.v Lattice.v Ordered.v \ +LIB=Coqlib.v Intv.v Maps.v Lattice.v Ordered.v \ Iteration.v Integers.v Floats.v Parmov.v UnionFind.v # Parts common to the front-ends and the back-end (in common/) -COMMON=Errors.v AST.v Events.v Globalenvs.v Mem.v Values.v \ +COMMON=Errors.v AST.v Events.v Globalenvs.v Memdata.v Memtype.v Memory.v Values.v \ Smallstep.v Determinism.v Switch.v # Back-end modules (in backend/, $(ARCH)/, $(ARCH)/$(VARIANT)) @@ -18,7 +18,7 @@ Require Import AST. Require Import Integers. Require Import Floats. Require Import Values. -Require Import Mem. +Require Import Memory. Require Import Events. Require Import Globalenvs. Require Import Smallstep. @@ -233,7 +233,7 @@ Module Pregmap := EMap(PregEq). and condition bits to either [Vzero] or [Vone]. *) Definition regset := Pregmap.t val. -Definition genv := Genv.t fundef. +Definition genv := Genv.t fundef unit. Notation "a # b" := (a b) (at level 1, only parsing). Notation "a # b <- c" := (Pregmap.set b c a) (at level 1, b at next level). @@ -609,28 +609,28 @@ Inductive step: state -> trace -> state -> Prop := exec_instr c i rs m = OK rs' m' -> step (State rs m) E0 (State rs' m') | exec_step_external: - forall b ef args res rs m t rs', + forall b ef args res rs m t rs' m', rs PC = Vptr b Int.zero -> Genv.find_funct_ptr ge b = Some (External ef) -> - event_match ef args t res -> + external_call ef args m t res m' -> extcall_arguments rs m ef.(ef_sig) args -> rs' = (rs#(loc_external_result ef.(ef_sig)) <- res #PC <- (rs IR14)) -> - step (State rs m) t (State rs' m). + step (State rs m) t (State rs' m'). End RELSEM. (** Execution of whole programs. *) Inductive initial_state (p: program): state -> Prop := - | initial_state_intro: + | initial_state_intro: forall m0, let ge := Genv.globalenv p in - let m0 := Genv.init_mem p in let rs0 := (Pregmap.init Vundef) # PC <- (symbol_offset ge p.(prog_main) Int.zero) # IR14 <- Vzero # IR13 <- (Vptr Mem.nullptr Int.zero) in + Genv.init_mem p = Some m0 -> initial_state p (State rs0 m0). Inductive final_state: state -> int -> Prop := diff --git a/arm/Asmgen.v b/arm/Asmgen.v index 8e0805f..069a08a 100644 --- a/arm/Asmgen.v +++ b/arm/Asmgen.v @@ -19,7 +19,7 @@ Require Import AST. Require Import Integers. Require Import Floats. Require Import Values. -Require Import Mem. +Require Import Memory. Require Import Globalenvs. Require Import Op. Require Import Locations. diff --git a/arm/Asmgenproof.v b/arm/Asmgenproof.v index db84d64..0260feb 100644 --- a/arm/Asmgenproof.v +++ b/arm/Asmgenproof.v @@ -19,7 +19,7 @@ Require Import AST. Require Import Integers. Require Import Floats. Require Import Values. -Require Import Mem. +Require Import Memory. Require Import Events. Require Import Globalenvs. Require Import Smallstep. diff --git a/arm/Asmgenproof1.v b/arm/Asmgenproof1.v index 0776413..fc2ce7f 100644 --- a/arm/Asmgenproof1.v +++ b/arm/Asmgenproof1.v @@ -18,7 +18,7 @@ Require Import AST. Require Import Integers. Require Import Floats. Require Import Values. -Require Import Mem. +Require Import Memory. Require Import Globalenvs. Require Import Op. Require Import Locations. diff --git a/arm/Asmgenretaddr.v b/arm/Asmgenretaddr.v index 72d855a..359aaf2 100644 --- a/arm/Asmgenretaddr.v +++ b/arm/Asmgenretaddr.v @@ -22,7 +22,7 @@ Require Import AST. Require Import Integers. Require Import Floats. Require Import Values. -Require Import Mem. +Require Import Memory. Require Import Globalenvs. Require Import Op. Require Import Locations. diff --git a/arm/ConstpropOpproof.v b/arm/ConstpropOpproof.v index b718fc2..9778ace 100644 --- a/arm/ConstpropOpproof.v +++ b/arm/ConstpropOpproof.v @@ -17,7 +17,7 @@ Require Import AST. Require Import Integers. Require Import Floats. Require Import Values. -Require Import Mem. +Require Import Memory. Require Import Globalenvs. Require Import Op. Require Import Registers. @@ -29,7 +29,7 @@ Require Import AST. Require Import Integers. Require Import Floats. Require Import Values. -Require Import Mem. +Require Import Memory. Require Import Globalenvs. Set Implicit Arguments. @@ -217,7 +217,7 @@ Definition offset_sp (sp: val) (delta: int) : option val := end. Definition eval_operation - (F: Type) (genv: Genv.t F) (sp: val) + (F V: Type) (genv: Genv.t F V) (sp: val) (op: operation) (vl: list val): option val := match op, vl with | Omove, v1::nil => Some v1 @@ -301,7 +301,7 @@ Definition eval_operation end. Definition eval_addressing - (F: Type) (genv: Genv.t F) (sp: val) + (F V: Type) (genv: Genv.t F V) (sp: val) (addr: addressing) (vl: list val) : option val := match addr, vl with | Aindexed n, Vptr b1 n1 :: nil => @@ -382,9 +382,9 @@ Qed. Section GENV_TRANSF. -Variable F1 F2: Type. -Variable ge1: Genv.t F1. -Variable ge2: Genv.t F2. +Variable F1 F2 V1 V2: Type. +Variable ge1: Genv.t F1 V1. +Variable ge2: Genv.t F2 V2. Hypothesis agree_on_symbols: forall (s: ident), Genv.find_symbol ge2 s = Genv.find_symbol ge1 s. @@ -523,8 +523,8 @@ Definition type_of_chunk (c: memory_chunk) : typ := Section SOUNDNESS. -Variable A: Type. -Variable genv: Genv.t A. +Variable A V: Type. +Variable genv: Genv.t A V. Lemma type_of_operation_sound: forall op vl sp v, @@ -584,8 +584,8 @@ End SOUNDNESS. Section EVAL_OP_TOTAL. -Variable F: Type. -Variable genv: Genv.t F. +Variable F V: Type. +Variable genv: Genv.t F V. Definition find_symbol_offset (id: ident) (ofs: int) : val := match Genv.find_symbol genv id with @@ -774,8 +774,8 @@ End EVAL_OP_TOTAL. Section EVAL_LESSDEF. -Variable F: Type. -Variable genv: Genv.t F. +Variable F V: Type. +Variable genv: Genv.t F V. Ltac InvLessdef := match goal with @@ -900,7 +900,7 @@ Definition op_for_binary_addressing (addr: addressing) : operation := end. Lemma eval_op_for_binary_addressing: - forall (F: Type) (ge: Genv.t F) sp addr args v, + forall (F V: Type) (ge: Genv.t F V) sp addr args v, (length args >= 2)%nat -> eval_addressing ge sp addr args = Some v -> eval_operation ge sp (op_for_binary_addressing addr) args = Some v. diff --git a/arm/SelectOp.v b/arm/SelectOp.v index abf39af..66c1299 100644 --- a/arm/SelectOp.v +++ b/arm/SelectOp.v @@ -42,7 +42,7 @@ Require Import AST. Require Import Integers. Require Import Floats. Require Import Values. -Require Import Mem. +Require Import Memory. Require Import Globalenvs. Require Cminor. Require Import Op. diff --git a/arm/SelectOpproof.v b/arm/SelectOpproof.v index 32aba30..b260346 100644 --- a/arm/SelectOpproof.v +++ b/arm/SelectOpproof.v @@ -18,7 +18,7 @@ Require Import AST. Require Import Integers. Require Import Floats. Require Import Values. -Require Import Mem. +Require Import Memory. Require Import Events. Require Import Globalenvs. Require Import Smallstep. diff --git a/backend/Allocproof.v b/backend/Allocproof.v index 10eaa5b..3f526aa 100644 --- a/backend/Allocproof.v +++ b/backend/Allocproof.v @@ -21,7 +21,7 @@ Require Import Maps. Require Import AST. Require Import Integers. Require Import Values. -Require Import Mem. +Require Import Memory. Require Import Events. Require Import Smallstep. Require Import Globalenvs. @@ -423,14 +423,14 @@ Lemma functions_translated: Genv.find_funct ge v = Some f -> exists tf, Genv.find_funct tge v = Some tf /\ transf_fundef f = OK tf. -Proof (Genv.find_funct_transf_partial transf_fundef TRANSF). +Proof (Genv.find_funct_transf_partial transf_fundef _ TRANSF). Lemma function_ptr_translated: forall (b: block) (f: RTL.fundef), Genv.find_funct_ptr ge b = Some f -> exists tf, Genv.find_funct_ptr tge b = Some tf /\ transf_fundef f = OK tf. -Proof (Genv.find_funct_ptr_transf_partial transf_fundef TRANSF). +Proof (Genv.find_funct_ptr_transf_partial transf_fundef _ TRANSF). Lemma sig_function_translated: forall f tf, @@ -482,7 +482,7 @@ Inductive match_stackframes: list RTL.stackframe -> list LTL.stackframe -> Prop (rs#res <- rv) (Locmap.set (assign res) rv ls)) -> match_stackframes - (RTL.Stackframe res (RTL.fn_code f) sp pc rs :: s) + (RTL.Stackframe res f sp pc rs :: s) (LTL.Stackframe (assign res) (transf_fun f live assign) sp ls pc :: ts). Inductive match_states: RTL.state -> LTL.state -> Prop := @@ -493,7 +493,7 @@ Inductive match_states: RTL.state -> LTL.state -> Prop := (ANL: analyze f = Some live) (ASG: regalloc f live (live0 f live) env = Some assign) (AG: agree assign (transfer f pc live!!pc) rs ls), - match_states (RTL.State s (RTL.fn_code f) sp pc rs m) + match_states (RTL.State s f sp pc rs m) (LTL.State ts (transf_fun f live assign) sp pc ls m) | match_states_call: forall s f args m ts tf, @@ -532,7 +532,7 @@ Ltac WellTypedHyp := Ltac TranslInstr := match goal with | H: (PTree.get _ _ = Some _) |- _ => - simpl; rewrite PTree.gmap; rewrite H; simpl; auto + simpl in H; simpl; rewrite PTree.gmap; rewrite H; simpl; auto end. Ltac MatchStates := @@ -646,7 +646,7 @@ Proof. (* Icall *) exploit transl_find_function; eauto. intros [tf [TFIND TF]]. - generalize (regalloc_correct_1 f0 env live _ _ _ _ ASG H).
unfold correct_alloc_instr. intros [CORR1 [CORR2 CORR3]]. + generalize (regalloc_correct_1 f env live _ _ _ _ ASG H).
unfold correct_alloc_instr. intros [CORR1 [CORR2 CORR3]]. assert (rs##args = map ls (map assign args)). eapply agree_eval_regs; eauto. econstructor; split. @@ -735,14 +735,13 @@ Lemma transf_initial_states: Proof. intros. inversion H. exploit function_ptr_translated; eauto. intros [tf [FIND TR]]. - assert (MEM: (Genv.init_mem tprog) = (Genv.init_mem prog)). - exact (Genv.init_mem_transf_partial _ _ TRANSF). - exists (LTL.Callstate nil tf nil (Genv.init_mem tprog)); split. + exists (LTL.Callstate nil tf nil m0); split. econstructor; eauto. + eapply Genv.init_mem_transf_partial; eauto. rewrite symbols_preserved. rewrite (transform_partial_program_main _ _ TRANSF). auto. - rewrite <- H2. apply sig_function_translated; auto. - rewrite MEM. constructor; auto. constructor. + rewrite <- H3. apply sig_function_translated; auto. + constructor; auto. constructor. Qed. Lemma transf_final_states: diff --git a/backend/CSE.v b/backend/CSE.v index 98b7bbf..ff79be5 100644 --- a/backend/CSE.v +++ b/backend/CSE.v @@ -19,7 +19,7 @@ Require Import AST. Require Import Integers. Require Import Floats. Require Import Values. -Require Import Mem. +Require Import Memory. Require Import Globalenvs. Require Import Op. Require Import Registers. @@ -265,7 +265,7 @@ Definition equation_holds | Load chunk addr vl => exists a, eval_addressing ge sp addr (List.map valuation vl) = Some a /\ - loadv chunk m a = Some (valuation vres) + Mem.loadv chunk m a = Some (valuation vres) end. Definition numbering_holds diff --git a/backend/CSEproof.v b/backend/CSEproof.v index 7f94246..fcc867a 100644 --- a/backend/CSEproof.v +++ b/backend/CSEproof.v @@ -18,7 +18,7 @@ Require Import AST. Require Import Integers. Require Import Floats. Require Import Values. -Require Import Mem. +Require Import Memory. Require Import Events. Require Import Globalenvs. Require Import Smallstep. @@ -404,7 +404,7 @@ Definition rhs_evals_to | Load chunk addr vl => exists a, eval_addressing ge sp addr (List.map valu vl) = Some a /\ - loadv chunk m a = Some v + Mem.loadv chunk m a = Some v end. Lemma equation_evals_to_holds_1: @@ -510,7 +510,7 @@ Lemma add_load_satisfiable: wf_numbering n -> numbering_satisfiable ge sp rs m n -> eval_addressing ge sp addr rs##args = Some a -> - loadv chunk m a = Some v -> + Mem.loadv chunk m a = Some v -> numbering_satisfiable ge sp (rs#dst <- v) m (add_load n dst chunk addr args). @@ -668,7 +668,7 @@ Lemma find_load_correct: find_load n chunk addr args = Some r -> exists a, eval_addressing ge sp addr rs##args = Some a /\ - loadv chunk m a = Some rs#r. + Mem.loadv chunk m a = Some rs#r. Proof. intros until r. intros WF [valu NH]. unfold find_load. caseEq (valnum_regs n args). intros n' vl VR FIND. @@ -783,21 +783,19 @@ Qed. Inductive match_stackframes: stackframe -> stackframe -> Prop := match_stackframes_intro: - forall res c sp pc rs f, - c = f.(RTL.fn_code) -> + forall res sp pc rs f, (forall v m, numbering_satisfiable ge sp (rs#res <- v) m (analyze f)!!pc) -> match_stackframes - (Stackframe res c sp pc rs) - (Stackframe res (transf_code (analyze f) c) sp pc rs). + (Stackframe res f sp pc rs) + (Stackframe res (transf_function f) sp pc rs). Inductive match_states: state -> state -> Prop := | match_states_intro: - forall s c sp pc rs m s' f - (CF: c = f.(RTL.fn_code)) + forall s sp pc rs m s' f (SAT: numbering_satisfiable ge sp rs m (analyze f)!!pc) (STACKS: list_forall2 match_stackframes s s'), - match_states (State s c sp pc rs m) - (State s' (transf_code (analyze f) c) sp pc rs m) + match_states (State s f sp pc rs m) + (State s' (transf_function f) sp pc rs m) | match_states_call: forall s f args m s', list_forall2 match_stackframes s s' -> @@ -812,9 +810,9 @@ Inductive match_states: state -> state -> Prop := Ltac TransfInstr := match goal with | H1: (PTree.get ?pc ?c = Some ?instr), f: function |- _ => - cut ((transf_code (analyze f) c)!pc = Some(transf_instr (analyze f)!!pc instr)); - [ simpl - | unfold transf_code; rewrite PTree.gmap; + cut ((transf_function f).(fn_code)!pc = Some(transf_instr (analyze f)!!pc instr)); + [ simpl transf_instr + | unfold transf_function, transf_code; simpl; rewrite PTree.gmap; unfold option_map; rewrite H1; reflexivity ] end. @@ -829,14 +827,14 @@ Proof. induction 1; intros; inv MS; try (TransfInstr; intro C). (* Inop *) - exists (State s' (transf_code (analyze f) (fn_code f)) sp pc' rs m); split. + exists (State s' (transf_function f) sp pc' rs m); split. apply exec_Inop; auto. econstructor; eauto. eapply analysis_correct_1; eauto. simpl; auto. unfold transfer; rewrite H; auto. (* Iop *) - exists (State s' (transf_code (analyze f) (fn_code f)) sp pc' (rs#res <- v) m); split. + exists (State s' (transf_function f) sp pc' (rs#res <- v) m); split. assert (eval_operation tge sp op rs##args = Some v). rewrite <- H0. apply eval_operation_preserved. exact symbols_preserved. generalize C; clear C. @@ -855,14 +853,14 @@ Proof. eapply add_op_satisfiable; eauto. apply wf_analyze. (* Iload *) - exists (State s' (transf_code (analyze f) (fn_code f)) sp pc' (rs#dst <- v) m); split. + exists (State s' (transf_function f) sp pc' (rs#dst <- v) m); split. assert (eval_addressing tge sp addr rs##args = Some a). rewrite <- H0. apply eval_addressing_preserved. exact symbols_preserved. generalize C; clear C. caseEq (find_load (analyze f)!!pc chunk addr args). intros r FIND CODE. eapply exec_Iop'; eauto. simpl. assert (exists a, eval_addressing ge sp addr rs##args = Some a - /\ loadv chunk m a = Some rs#r). + /\ Mem.loadv chunk m a = Some rs#r). eapply find_load_correct; eauto. eapply wf_analyze; eauto. elim H3; intros a' [A B]. @@ -874,7 +872,7 @@ Proof. eapply add_load_satisfiable; eauto. apply wf_analyze. (* Istore *) - exists (State s' (transf_code (analyze f) (fn_code f)) sp pc' rs m'); split. + exists (State s' (transf_function f) sp pc' rs m'); split. assert (eval_addressing tge sp addr rs##args = Some a). rewrite <- H0. apply eval_addressing_preserved. exact symbols_preserved. eapply exec_Istore; eauto. @@ -886,7 +884,7 @@ Proof. (* Icall *) exploit find_function_translated; eauto. intro FIND'. econstructor; split. - eapply exec_Icall with (f := transf_fundef f); eauto. + eapply exec_Icall; eauto. apply sig_preserved. econstructor; eauto. constructor; auto. @@ -898,7 +896,7 @@ Proof. (* Itailcall *) exploit find_function_translated; eauto. intro FIND'. econstructor; split. - eapply exec_Itailcall with (f := transf_fundef f); eauto. + eapply exec_Itailcall; eauto. apply sig_preserved. econstructor; eauto. @@ -951,15 +949,14 @@ Lemma transf_initial_states: exists st2, initial_state tprog st2 /\ match_states st1 st2. Proof. intros. inversion H. - exists (Callstate nil (transf_fundef f) nil (Genv.init_mem tprog)); split. + exists (Callstate nil (transf_fundef f) nil m0); split. econstructor; eauto. + apply Genv.init_mem_transf; auto. change (prog_main tprog) with (prog_main prog). rewrite symbols_preserved. eauto. apply funct_ptr_translated; auto. - rewrite <- H2. apply sig_preserved. - replace (Genv.init_mem tprog) with (Genv.init_mem prog). - constructor. constructor. auto. - symmetry. unfold tprog, transf_program. apply Genv.init_mem_transf. + rewrite <- H3. apply sig_preserved. + constructor. constructor. Qed. Lemma transf_final_states: diff --git a/backend/Cminor.v b/backend/Cminor.v index aa9c511..094bef7 100644 --- a/backend/Cminor.v +++ b/backend/Cminor.v @@ -22,7 +22,7 @@ Require Import Integers. Require Import Floats. Require Import Events. Require Import Values. -Require Import Mem. +Require Import Memory. Require Import Globalenvs. Require Import Smallstep. Require Import Switch. @@ -144,7 +144,7 @@ Definition funsig (fd: fundef) := - [env]: local environments, map local variables to values. *) -Definition genv := Genv.t fundef. +Definition genv := Genv.t fundef unit. Definition env := PTree.t val. (** The following functions build the initial local environment at @@ -402,11 +402,12 @@ Inductive step: state -> trace -> state -> Prop := | step_skip_block: forall f k sp e m, step (State f Sskip (Kblock k) sp e m) E0 (State f Sskip k sp e m) - | step_skip_call: forall f k sp e m, + | step_skip_call: forall f k sp e m m', is_call_cont k -> f.(fn_sig).(sig_res) = None -> + Mem.free m sp 0 f.(fn_stackspace) = Some m' -> step (State f Sskip k (Vptr sp Int.zero) e m) - E0 (Returnstate Vundef k (Mem.free m sp)) + E0 (Returnstate Vundef k m') | step_assign: forall f id a k sp e m v, eval_expr sp e m a v -> @@ -428,13 +429,14 @@ Inductive step: state -> trace -> state -> Prop := step (State f (Scall optid sig a bl) k sp e m) E0 (Callstate fd vargs (Kcall optid f sp e k) m) - | step_tailcall: forall f sig a bl k sp e m vf vargs fd, + | step_tailcall: forall f sig a bl k sp e m vf vargs fd m', eval_expr (Vptr sp Int.zero) e m a vf -> eval_exprlist (Vptr sp Int.zero) e m bl vargs -> Genv.find_funct ge vf = Some fd -> funsig fd = sig -> + Mem.free m sp 0 f.(fn_stackspace) = Some m' -> step (State f (Stailcall sig a bl) k (Vptr sp Int.zero) e m) - E0 (Callstate fd vargs (call_cont k) (Mem.free m sp)) + E0 (Callstate fd vargs (call_cont k) m') | step_seq: forall f s1 s2 k sp e m, step (State f (Sseq s1 s2) k sp e m) @@ -469,13 +471,15 @@ Inductive step: state -> trace -> state -> Prop := step (State f (Sswitch a cases default) k sp e m) E0 (State f (Sexit (switch_target n default cases)) k sp e m) - | step_return_0: forall f k sp e m, + | step_return_0: forall f k sp e m m', + Mem.free m sp 0 f.(fn_stackspace) = Some m' -> step (State f (Sreturn None) k (Vptr sp Int.zero) e m) - E0 (Returnstate Vundef (call_cont k) (Mem.free m sp)) - | step_return_1: forall f a k sp e m v, + E0 (Returnstate Vundef (call_cont k) m') + | step_return_1: forall f a k sp e m v m', eval_expr (Vptr sp Int.zero) e m a v -> + Mem.free m sp 0 f.(fn_stackspace) = Some m' -> step (State f (Sreturn (Some a)) k (Vptr sp Int.zero) e m) - E0 (Returnstate v (call_cont k) (Mem.free m sp)) + E0 (Returnstate v (call_cont k) m') | step_label: forall f lbl s k sp e m, step (State f (Slabel lbl s) k sp e m) @@ -491,10 +495,10 @@ Inductive step: state -> trace -> state -> Prop := set_locals f.(fn_vars) (set_params vargs f.(fn_params)) = e -> step (Callstate (Internal f) vargs k m) E0 (State f f.(fn_body) k (Vptr sp Int.zero) e m') - | step_external_function: forall ef vargs k m t vres, - event_match ef vargs t vres -> + | step_external_function: forall ef vargs k m t vres m', + external_call ef vargs m t vres m' -> step (Callstate (External ef) vargs k m) - t (Returnstate vres k m) + t (Returnstate vres k m') | step_return: forall v optid f sp e k m, step (Returnstate v (Kcall optid f sp e k) m) @@ -508,9 +512,9 @@ End RELSEM. without arguments and with an empty continuation. *) Inductive initial_state (p: program): state -> Prop := - | initial_state_intro: forall b f, + | initial_state_intro: forall b f m0, let ge := Genv.globalenv p in - let m0 := Genv.init_mem p in + Genv.init_mem p = Some m0 -> Genv.find_symbol ge p.(prog_main) = Some b -> Genv.find_funct_ptr ge b = Some f -> funsig f = mksignature nil (Some Tint) -> @@ -560,12 +564,16 @@ Definition outcome_result_value end. Definition outcome_free_mem - (out: outcome) (m: mem) (sp: block) : mem := + (out: outcome) (m: mem) (sp: block) (sz: Z) (m': mem) := match out with - | Out_tailcall_return _ => m - | _ => Mem.free m sp + | Out_tailcall_return _ => m' = m + | _ => Mem.free m sp 0 sz = Some m' end. +(***** REVISE - PROBLEMS WITH free *) + +(****************************** + Section NATURALSEM. Variable ge: genv. @@ -580,16 +588,17 @@ Inductive eval_funcall: mem -> fundef -> list val -> trace -> mem -> val -> Prop := | eval_funcall_internal: - forall m f vargs m1 sp e t e2 m2 out vres, + forall m f vargs m1 sp e t e2 m2 out vres m3, Mem.alloc m 0 f.(fn_stackspace) = (m1, sp) -> set_locals f.(fn_vars) (set_params vargs f.(fn_params)) = e -> exec_stmt (Vptr sp Int.zero) e m1 f.(fn_body) t e2 m2 out -> outcome_result_value out f.(fn_sig).(sig_res) vres -> - eval_funcall m (Internal f) vargs t (outcome_free_mem out m2 sp) vres + outcome_free_mem out m2 sp f.(fn_stackspace) m3 -> + eval_funcall m (Internal f) vargs t m3 vres | eval_funcall_external: - forall ef m args t res, - event_match ef args t res -> - eval_funcall m (External ef) args t m res + forall ef m args t res m', + external_call ef args m t res m' -> + eval_funcall m (External ef) args t m' res (** Execution of a statement: [exec_stmt ge sp e m s t e' m' out] means that statement [s] executes with outcome [out]. @@ -759,9 +768,9 @@ End NATURALSEM. Inductive bigstep_program_terminates (p: program): trace -> int -> Prop := | bigstep_program_terminates_intro: - forall b f t m r, + forall b f m0 t m r, let ge := Genv.globalenv p in - let m0 := Genv.init_mem p in + Genv.init_mem p = Some m0 -> Genv.find_symbol ge p.(prog_main) = Some b -> Genv.find_funct_ptr ge b = Some f -> funsig f = mksignature nil (Some Tint) -> @@ -770,9 +779,9 @@ Inductive bigstep_program_terminates (p: program): trace -> int -> Prop := Inductive bigstep_program_diverges (p: program): traceinf -> Prop := | bigstep_program_diverges_intro: - forall b f t, + forall b f m0 t, let ge := Genv.globalenv p in - let m0 := Genv.init_mem p in + Genv.init_mem p = Some m0 -> Genv.find_symbol ge p.(prog_main) = Some b -> Genv.find_funct_ptr ge b = Some f -> funsig f = mksignature nil (Some Tint) -> @@ -1116,6 +1125,6 @@ Qed. End BIGSTEP_TO_TRANSITION. - +***************************************************) diff --git a/backend/CminorSel.v b/backend/CminorSel.v index 8533872..231af8f 100644 --- a/backend/CminorSel.v +++ b/backend/CminorSel.v @@ -19,7 +19,7 @@ Require Import Integers. Require Import Floats. Require Import Events. Require Import Values. -Require Import Mem. +Require Import Memory. Require Import Cminor. Require Import Op. Require Import Globalenvs. @@ -105,7 +105,7 @@ Definition funsig (fd: fundef) := - [lenv]: let environments, map de Bruijn indices to values. *) -Definition genv := Genv.t fundef. +Definition genv := Genv.t fundef unit. Definition letenv := list val. (** Continuations *) @@ -260,11 +260,12 @@ Inductive step: state -> trace -> state -> Prop := | step_skip_block: forall f k sp e m, step (State f Sskip (Kblock k) sp e m) E0 (State f Sskip k sp e m) - | step_skip_call: forall f k sp e m, + | step_skip_call: forall f k sp e m m', is_call_cont k -> f.(fn_sig).(sig_res) = None -> + Mem.free m sp 0 f.(fn_stackspace) = Some m' -> step (State f Sskip k (Vptr sp Int.zero) e m) - E0 (Returnstate Vundef k (Mem.free m sp)) + E0 (Returnstate Vundef k m') | step_assign: forall f id a k sp e m v, eval_expr sp e m nil a v -> @@ -287,13 +288,14 @@ Inductive step: state -> trace -> state -> Prop := step (State f (Scall optid sig a bl) k sp e m) E0 (Callstate fd vargs (Kcall optid f sp e k) m) - | step_tailcall: forall f sig a bl k sp e m vf vargs fd, + | step_tailcall: forall f sig a bl k sp e m vf vargs fd m', eval_expr (Vptr sp Int.zero) e m nil a vf -> eval_exprlist (Vptr sp Int.zero) e m nil bl vargs -> Genv.find_funct ge vf = Some fd -> funsig fd = sig -> + Mem.free m sp 0 f.(fn_stackspace) = Some m' -> step (State f (Stailcall sig a bl) k (Vptr sp Int.zero) e m) - E0 (Callstate fd vargs (call_cont k) (Mem.free m sp)) + E0 (Callstate fd vargs (call_cont k) m') | step_seq: forall f s1 s2 k sp e m, step (State f (Sseq s1 s2) k sp e m) @@ -327,13 +329,15 @@ Inductive step: state -> trace -> state -> Prop := step (State f (Sswitch a cases default) k sp e m) E0 (State f (Sexit (switch_target n default cases)) k sp e m) - | step_return_0: forall f k sp e m, + | step_return_0: forall f k sp e m m', + Mem.free m sp 0 f.(fn_stackspace) = Some m' -> step (State f (Sreturn None) k (Vptr sp Int.zero) e m) - E0 (Returnstate Vundef (call_cont k) (Mem.free m sp)) - | step_return_1: forall f a k sp e m v, + E0 (Returnstate Vundef (call_cont k) m') + | step_return_1: forall f a k sp e m v m', eval_expr (Vptr sp Int.zero) e m nil a v -> + Mem.free m sp 0 f.(fn_stackspace) = Some m' -> step (State f (Sreturn (Some a)) k (Vptr sp Int.zero) e m) - E0 (Returnstate v (call_cont k) (Mem.free m sp)) + E0 (Returnstate v (call_cont k) m') | step_label: forall f lbl s k sp e m, step (State f (Slabel lbl s) k sp e m) @@ -349,10 +353,10 @@ Inductive step: state -> trace -> state -> Prop := set_locals f.(fn_vars) (set_params vargs f.(fn_params)) = e -> step (Callstate (Internal f) vargs k m) E0 (State f f.(fn_body) k (Vptr sp Int.zero) e m') - | step_external_function: forall ef vargs k m t vres, - event_match ef vargs t vres -> + | step_external_function: forall ef vargs k m t vres m', + external_call ef vargs m t vres m' -> step (Callstate (External ef) vargs k m) - t (Returnstate vres k m) + t (Returnstate vres k m') | step_return: forall v optid f sp e k m, step (Returnstate v (Kcall optid f sp e k) m) @@ -361,9 +365,9 @@ Inductive step: state -> trace -> state -> Prop := End RELSEM. Inductive initial_state (p: program): state -> Prop := - | initial_state_intro: forall b f, + | initial_state_intro: forall b f m0, let ge := Genv.globalenv p in - let m0 := Genv.init_mem p in + Genv.init_mem p = Some m0 -> Genv.find_symbol ge p.(prog_main) = Some b -> Genv.find_funct_ptr ge b = Some f -> funsig f = mksignature nil (Some Tint) -> diff --git a/backend/Constpropproof.v b/backend/Constpropproof.v index fff9a60..6671960 100644 --- a/backend/Constpropproof.v +++ b/backend/Constpropproof.v @@ -19,7 +19,7 @@ Require Import Integers. Require Import Floats. Require Import Values. Require Import Events. -Require Import Mem. +Require Import Memory. Require Import Globalenvs. Require Import Smallstep. Require Import Op. @@ -152,7 +152,7 @@ Lemma functions_translated: Genv.find_funct tge v = Some (transf_fundef f). Proof. intros. - exact (Genv.find_funct_transf transf_fundef H). + exact (Genv.find_funct_transf transf_fundef _ _ H). Qed. Lemma function_ptr_translated: @@ -161,7 +161,7 @@ Lemma function_ptr_translated: Genv.find_funct_ptr tge b = Some (transf_fundef f). Proof. intros. - exact (Genv.find_funct_ptr_transf transf_fundef H). + exact (Genv.find_funct_ptr_transf transf_fundef _ _ H). Qed. Lemma sig_function_translated: @@ -220,21 +220,19 @@ Qed. Inductive match_stackframes: stackframe -> stackframe -> Prop := match_stackframe_intro: - forall res c sp pc rs f, - c = f.(RTL.fn_code) -> + forall res sp pc rs f, (forall v, regs_match_approx ge (analyze f)!!pc (rs#res <- v)) -> match_stackframes - (Stackframe res c sp pc rs) - (Stackframe res (transf_code (analyze f) c) sp pc rs). + (Stackframe res f sp pc rs) + (Stackframe res (transf_function f) sp pc rs). Inductive match_states: state -> state -> Prop := | match_states_intro: - forall s c sp pc rs m f s' - (CF: c = f.(RTL.fn_code)) + forall s sp pc rs m f s' (MATCH: regs_match_approx ge (analyze f)!!pc rs) (STACKS: list_forall2 match_stackframes s s'), - match_states (State s c sp pc rs m) - (State s' (transf_code (analyze f) c) sp pc rs m) + match_states (State s f sp pc rs m) + (State s' (transf_function f) sp pc rs m) | match_states_call: forall s f args m s', list_forall2 match_stackframes s s' -> @@ -249,9 +247,9 @@ Inductive match_states: state -> state -> Prop := Ltac TransfInstr := match goal with | H1: (PTree.get ?pc ?c = Some ?instr), f: function |- _ => - cut ((transf_code (analyze f) c)!pc = Some(transf_instr (analyze f)!!pc instr)); - [ simpl - | unfold transf_code; rewrite PTree.gmap; + cut ((transf_function f).(fn_code)!pc = Some(transf_instr (analyze f)!!pc instr)); + [ simpl transf_instr + | unfold transf_function, transf_code; simpl; rewrite PTree.gmap; unfold option_map; rewrite H1; reflexivity ] end. @@ -267,7 +265,7 @@ Proof. induction 1; intros; inv MS. (* Inop *) - exists (State s' (transf_code (analyze f) (fn_code f)) sp pc' rs m); split. + exists (State s' (transf_function f) sp pc' rs m); split. TransfInstr; intro. eapply exec_Inop; eauto. econstructor; eauto. eapply analyze_correct_1 with (pc := pc); eauto. @@ -275,11 +273,11 @@ Proof. unfold transfer; rewrite H. auto. (* Iop *) - exists (State s' (transf_code (analyze f) (fn_code f)) sp pc' (rs#res <- v) m); split. + exists (State s' (transf_function f) sp pc' (rs#res <- v) m); split. TransfInstr. caseEq (op_strength_reduction (approx_reg (analyze f)!!pc) op args); intros op' args' OSR. assert (eval_operation tge sp op' rs##args' = Some v). - rewrite (eval_operation_preserved symbols_preserved). + rewrite (eval_operation_preserved _ _ symbols_preserved). generalize (op_strength_reduction_correct ge (approx_reg (analyze f)!!pc) sp rs MATCH op args v). rewrite OSR; simpl. auto. @@ -305,12 +303,12 @@ Proof. caseEq (addr_strength_reduction (approx_reg (analyze f)!!pc) addr args); intros addr' args' ASR. assert (eval_addressing tge sp addr' rs##args' = Some a). - rewrite (eval_addressing_preserved symbols_preserved). + rewrite (eval_addressing_preserved _ _ symbols_preserved). generalize (addr_strength_reduction_correct ge (approx_reg (analyze f)!!pc) sp rs MATCH addr args). rewrite ASR; simpl. congruence. TransfInstr. rewrite ASR. intro. - exists (State s' (transf_code (analyze f) (fn_code f)) sp pc' (rs#dst <- v) m); split. + exists (State s' (transf_function f) sp pc' (rs#dst <- v) m); split. eapply exec_Iload; eauto. econstructor; eauto. eapply analyze_correct_1; eauto. simpl; auto. @@ -321,12 +319,12 @@ Proof. caseEq (addr_strength_reduction (approx_reg (analyze f)!!pc) addr args); intros addr' args' ASR. assert (eval_addressing tge sp addr' rs##args' = Some a). - rewrite (eval_addressing_preserved symbols_preserved). + rewrite (eval_addressing_preserved _ _ symbols_preserved). generalize (addr_strength_reduction_correct ge (approx_reg (analyze f)!!pc) sp rs MATCH addr args). rewrite ASR; simpl. congruence. TransfInstr. rewrite ASR. intro. - exists (State s' (transf_code (analyze f) (fn_code f)) sp pc' rs m'); split. + exists (State s' (transf_function f) sp pc' rs m'); split. eapply exec_Istore; eauto. econstructor; eauto. eapply analyze_correct_1; eauto. simpl; auto. @@ -351,7 +349,7 @@ Proof. constructor; auto. (* Icond, true *) - exists (State s' (transf_code (analyze f) (fn_code f)) sp ifso rs m); split. + exists (State s' (transf_function f) sp ifso rs m); split. caseEq (cond_strength_reduction (approx_reg (analyze f)!!pc) cond args); intros cond' args' CSR. assert (eval_condition cond' rs##args' = Some true). @@ -371,7 +369,7 @@ Proof. unfold transfer; rewrite H; auto. (* Icond, false *) - exists (State s' (transf_code (analyze f) (fn_code f)) sp ifnot rs m); split. + exists (State s' (transf_function f) sp ifnot rs m); split. caseEq (cond_strength_reduction (approx_reg (analyze f)!!pc) cond args); intros cond' args' CSR. assert (eval_condition cond' rs##args' = Some false). @@ -391,7 +389,7 @@ Proof. unfold transfer; rewrite H; auto. (* Ijumptable *) - exists (State s' (transf_code (analyze f) (fn_code f)) sp pc' rs m); split. + exists (State s' (transf_function f) sp pc' rs m); split. caseEq (intval (approx_reg (analyze f)!!pc) arg); intros. exploit intval_correct; eauto. eexact MATCH. intro VRS. eapply exec_Inop; eauto. TransfInstr. rewrite H2. @@ -403,7 +401,7 @@ Proof. unfold transfer; rewrite H; auto. (* Ireturn *) - exists (Returnstate s' (regmap_optget or Vundef rs) (free m stk)); split. + exists (Returnstate s' (regmap_optget or Vundef rs) m'); split. eapply exec_Ireturn; eauto. TransfInstr; auto. constructor; auto. @@ -432,15 +430,14 @@ Lemma transf_initial_states: Proof. intros. inversion H. exploit function_ptr_translated; eauto. intro FIND. - exists (Callstate nil (transf_fundef f) nil (Genv.init_mem tprog)); split. + exists (Callstate nil (transf_fundef f) nil m0); split. econstructor; eauto. + apply Genv.init_mem_transf; auto. replace (prog_main tprog) with (prog_main prog). rewrite symbols_preserved. eauto. reflexivity. - rewrite <- H2. apply sig_function_translated. - replace (Genv.init_mem tprog) with (Genv.init_mem prog). - constructor. constructor. auto. - symmetry. unfold tprog, transf_program. apply Genv.init_mem_transf. + rewrite <- H3. apply sig_function_translated. + constructor. constructor. Qed. Lemma transf_final_states: diff --git a/backend/LTL.v b/backend/LTL.v index 6a69336..2a1172a 100644 --- a/backend/LTL.v +++ b/backend/LTL.v @@ -21,7 +21,7 @@ Require Import AST. Require Import Integers. Require Import Values. Require Import Events. -Require Import Mem. +Require Import Memory. Require Import Globalenvs. Require Import Smallstep. Require Import Op. @@ -67,7 +67,7 @@ Definition funsig (fd: fundef) := (** * Operational semantics *) -Definition genv := Genv.t fundef. +Definition genv := Genv.t fundef unit. Definition locset := Locmap.t. Definition locmap_optget (ol: option loc) (dfl: val) (ls: locset) : val := @@ -189,12 +189,13 @@ Inductive step: state -> trace -> state -> Prop := E0 (Callstate (Stackframe res f sp (postcall_locs rs) pc' :: s) f' (List.map rs args) m) | exec_Ltailcall: - forall s f stk pc rs m sig ros args f', + forall s f stk pc rs m sig ros args f' m', (fn_code f)!pc = Some(Ltailcall sig ros args) -> find_function ros rs = Some f' -> funsig f' = sig -> + Mem.free m stk 0 f.(fn_stacksize) = Some m' -> step (State s f (Vptr stk Int.zero) pc rs m) - E0 (Callstate s f' (List.map rs args) (Mem.free m stk)) + E0 (Callstate s f' (List.map rs args) m') | exec_Lcond_true: forall s f sp pc rs m cond args ifso ifnot, (fn_code f)!pc = Some(Lcond cond args ifso ifnot) -> @@ -215,20 +216,21 @@ Inductive step: state -> trace -> state -> Prop := step (State s f sp pc rs m) E0 (State s f sp pc' rs m) | exec_Lreturn: - forall s f stk pc rs m or, + forall s f stk pc rs m or m', (fn_code f)!pc = Some(Lreturn or) -> + Mem.free m stk 0 f.(fn_stacksize) = Some m' -> step (State s f (Vptr stk Int.zero) pc rs m) - E0 (Returnstate s (locmap_optget or Vundef rs) (Mem.free m stk)) + E0 (Returnstate s (locmap_optget or Vundef rs) m') | exec_function_internal: forall s f args m m' stk, Mem.alloc m 0 f.(fn_stacksize) = (m', stk) -> step (Callstate s (Internal f) args m) E0 (State s f (Vptr stk Int.zero) f.(fn_entrypoint) (init_locs args f.(fn_params)) m') | exec_function_external: - forall s ef t args res m, - event_match ef args t res -> + forall s ef t args res m m', + external_call ef args m t res m' -> step (Callstate s (External ef) args m) - t (Returnstate s res m) + t (Returnstate s res m') | exec_return: forall res f sp rs pc s vres m, step (Returnstate (Stackframe res f sp rs pc :: s) vres m) @@ -242,9 +244,9 @@ End RELSEM. by the calling conventions. *) Inductive initial_state (p: program): state -> Prop := - | initial_state_intro: forall b f, + | initial_state_intro: forall b f m0, let ge := Genv.globalenv p in - let m0 := Genv.init_mem p in + Genv.init_mem p = Some m0 -> Genv.find_symbol ge p.(prog_main) = Some b -> Genv.find_funct_ptr ge b = Some f -> funsig f = mksignature nil (Some Tint) -> diff --git a/backend/LTLin.v b/backend/LTLin.v index e353338..c3b432b 100644 --- a/backend/LTLin.v +++ b/backend/LTLin.v @@ -21,7 +21,7 @@ Require Import Maps. Require Import AST. Require Import Integers. Require Import Values. -Require Import Mem. +Require Import Memory. Require Import Events. Require Import Globalenvs. Require Import Smallstep. @@ -72,7 +72,7 @@ Definition funsig (fd: fundef) := | External ef => ef.(ef_sig) end. -Definition genv := Genv.t fundef. +Definition genv := Genv.t fundef unit. Definition locset := Locmap.t. (** * Operational semantics *) @@ -163,13 +163,13 @@ Inductive step: state -> trace -> state -> Prop := | exec_Lload: forall s f sp chunk addr args dst b rs m a v, eval_addressing ge sp addr (map rs args) = Some a -> - loadv chunk m a = Some v -> + Mem.loadv chunk m a = Some v -> step (State s f sp (Lload chunk addr args dst :: b) rs m) E0 (State s f sp b (Locmap.set dst v rs) m) | exec_Lstore: forall s f sp chunk addr args src b rs m m' a, eval_addressing ge sp addr (map rs args) = Some a -> - storev chunk m a (rs src) = Some m' -> + Mem.storev chunk m a (rs src) = Some m' -> step (State s f sp (Lstore chunk addr args src :: b) rs m) E0 (State s f sp b rs m') | exec_Lcall: @@ -180,11 +180,12 @@ Inductive step: state -> trace -> state -> Prop := E0 (Callstate (Stackframe res f sp (postcall_locs rs) b :: s) f' (List.map rs args) m) | exec_Ltailcall: - forall s f stk sig ros args b rs m f', + forall s f stk sig ros args b rs m f' m', find_function ros rs = Some f' -> sig = funsig f' -> + Mem.free m stk 0 f.(fn_stacksize) = Some m' -> step (State s f (Vptr stk Int.zero) (Ltailcall sig ros args :: b) rs m) - E0 (Callstate s f' (List.map rs args) (Mem.free m stk)) + E0 (Callstate s f' (List.map rs args) m') | exec_Llabel: forall s f sp lbl b rs m, step (State s f sp (Llabel lbl :: b) rs m) @@ -213,19 +214,20 @@ Inductive step: state -> trace -> state -> Prop := step (State s f sp (Ljumptable arg tbl :: b) rs m) E0 (State s f sp b' rs m) | exec_Lreturn: - forall s f stk rs m or b, + forall s f stk rs m or b m', + Mem.free m stk 0 f.(fn_stacksize) = Some m' -> step (State s f (Vptr stk Int.zero) (Lreturn or :: b) rs m) - E0 (Returnstate s (locmap_optget or Vundef rs) (Mem.free m stk)) + E0 (Returnstate s (locmap_optget or Vundef rs) m') | exec_function_internal: forall s f args m m' stk, Mem.alloc m 0 f.(fn_stacksize) = (m', stk) -> step (Callstate s (Internal f) args m) E0 (State s f (Vptr stk Int.zero) f.(fn_code) (init_locs args f.(fn_params)) m') | exec_function_external: - forall s ef args t res m, - event_match ef args t res -> + forall s ef args t res m m', + external_call ef args m t res m' -> step (Callstate s (External ef) args m) - t (Returnstate s res m) + t (Returnstate s res m') | exec_return: forall res f sp rs b s vres m, step (Returnstate (Stackframe res f sp rs b :: s) vres m) @@ -234,9 +236,9 @@ Inductive step: state -> trace -> state -> Prop := End RELSEM. Inductive initial_state (p: program): state -> Prop := - | initial_state_intro: forall b f, + | initial_state_intro: forall b f m0, let ge := Genv.globalenv p in - let m0 := Genv.init_mem p in + Genv.init_mem p = Some m0 -> Genv.find_symbol ge p.(prog_main) = Some b -> Genv.find_funct_ptr ge b = Some f -> funsig f = mksignature nil (Some Tint) -> diff --git a/backend/LTLintyping.v b/backend/LTLintyping.v index 1005890..69422e0 100644 --- a/backend/LTLintyping.v +++ b/backend/LTLintyping.v @@ -16,6 +16,7 @@ Require Import Coqlib. Require Import Maps. Require Import AST. Require Import Integers. +Require Import Memdata. Require Import Op. Require Import RTL. Require Import Locations. diff --git a/backend/LTLtyping.v b/backend/LTLtyping.v index 9a2322c..e1e43f5 100644 --- a/backend/LTLtyping.v +++ b/backend/LTLtyping.v @@ -16,6 +16,7 @@ Require Import Coqlib. Require Import Maps. Require Import AST. Require Import Integers. +Require Import Memdata. Require Import Op. Require Import RTL. Require Import Locations. diff --git a/backend/Linear.v b/backend/Linear.v index bf21cb7..be07b82 100644 --- a/backend/Linear.v +++ b/backend/Linear.v @@ -22,7 +22,7 @@ Require Import Maps. Require Import AST. Require Import Integers. Require Import Values. -Require Import Mem. +Require Import Memory. Require Import Events. Require Import Globalenvs. Require Import Smallstep. @@ -67,7 +67,7 @@ Definition funsig (fd: fundef) := | External ef => ef.(ef_sig) end. -Definition genv := Genv.t fundef. +Definition genv := Genv.t fundef unit. Definition locset := Locmap.t. (** * Operational semantics *) @@ -253,13 +253,13 @@ Inductive step: state -> trace -> state -> Prop := | exec_Lload: forall s f sp chunk addr args dst b rs m a v, eval_addressing ge sp addr (reglist rs args) = Some a -> - loadv chunk m a = Some v -> + Mem.loadv chunk m a = Some v -> step (State s f sp (Lload chunk addr args dst :: b) rs m) E0 (State s f sp b (Locmap.set (R dst) v rs) m) | exec_Lstore: forall s f sp chunk addr args src b rs m m' a, eval_addressing ge sp addr (reglist rs args) = Some a -> - storev chunk m a (rs (R src)) = Some m' -> + Mem.storev chunk m a (rs (R src)) = Some m' -> step (State s f sp (Lstore chunk addr args src :: b) rs m) E0 (State s f sp b rs m') | exec_Lcall: @@ -269,11 +269,12 @@ Inductive step: state -> trace -> state -> Prop := step (State s f sp (Lcall sig ros :: b) rs m) E0 (Callstate (Stackframe f sp rs b:: s) f' rs m) | exec_Ltailcall: - forall s f stk sig ros b rs m f', + forall s f stk sig ros b rs m f' m', find_function ros rs = Some f' -> sig = funsig f' -> + Mem.free m stk 0 f.(fn_stacksize) = Some m' -> step (State s f (Vptr stk Int.zero) (Ltailcall sig ros :: b) rs m) - E0 (Callstate s f' (return_regs (parent_locset s) rs) (Mem.free m stk)) + E0 (Callstate s f' (return_regs (parent_locset s) rs) m') | exec_Llabel: forall s f sp lbl b rs m, step (State s f sp (Llabel lbl :: b) rs m) @@ -302,21 +303,22 @@ Inductive step: state -> trace -> state -> Prop := step (State s f sp (Ljumptable arg tbl :: b) rs m) E0 (State s f sp b' rs m) | exec_Lreturn: - forall s f stk b rs m, + forall s f stk b rs m m', + Mem.free m stk 0 f.(fn_stacksize) = Some m' -> step (State s f (Vptr stk Int.zero) (Lreturn :: b) rs m) - E0 (Returnstate s (return_regs (parent_locset s) rs) (Mem.free m stk)) + E0 (Returnstate s (return_regs (parent_locset s) rs) m') | exec_function_internal: forall s f rs m m' stk, - alloc m 0 f.(fn_stacksize) = (m', stk) -> + Mem.alloc m 0 f.(fn_stacksize) = (m', stk) -> step (Callstate s (Internal f) rs m) E0 (State s f (Vptr stk Int.zero) f.(fn_code) (call_regs rs) m') | exec_function_external: - forall s ef args res rs1 rs2 m t, - event_match ef args t res -> + forall s ef args res rs1 rs2 m t m', + external_call ef args m t res m' -> args = List.map rs1 (Conventions.loc_arguments ef.(ef_sig)) -> rs2 = Locmap.set (R (Conventions.loc_result ef.(ef_sig))) res rs1 -> step (Callstate s (External ef) rs1 m) - t (Returnstate s rs2 m) + t (Returnstate s rs2 m') | exec_return: forall s f sp rs0 c rs m, step (Returnstate (Stackframe f sp rs0 c :: s) rs m) @@ -325,9 +327,9 @@ Inductive step: state -> trace -> state -> Prop := End RELSEM. Inductive initial_state (p: program): state -> Prop := - | initial_state_intro: forall b f, + | initial_state_intro: forall b f m0, let ge := Genv.globalenv p in - let m0 := Genv.init_mem p in + Genv.init_mem p = Some m0 -> Genv.find_symbol ge p.(prog_main) = Some b -> Genv.find_funct_ptr ge b = Some f -> funsig f = mksignature nil (Some Tint) -> diff --git a/backend/Linearizeproof.v b/backend/Linearizeproof.v index c79908d..5d67065 100644 --- a/backend/Linearizeproof.v +++ b/backend/Linearizeproof.v @@ -19,7 +19,7 @@ Require Import FSets. Require Import AST. Require Import Integers. Require Import Values. -Require Import Mem. +Require Import Memory. Require Import Events. Require Import Globalenvs. Require Import Errors. @@ -49,14 +49,14 @@ Lemma functions_translated: Genv.find_funct ge v = Some f -> exists tf, Genv.find_funct tge v = Some tf /\ transf_fundef f = OK tf. -Proof (Genv.find_funct_transf_partial transf_fundef TRANSF). +Proof (Genv.find_funct_transf_partial transf_fundef _ TRANSF). Lemma function_ptr_translated: forall v f, Genv.find_funct_ptr ge v = Some f -> exists tf, Genv.find_funct_ptr tge v = Some tf /\ transf_fundef f = OK tf. -Proof (Genv.find_funct_ptr_transf_partial transf_fundef TRANSF). +Proof (Genv.find_funct_ptr_transf_partial transf_fundef _ TRANSF). Lemma symbols_preserved: forall id, @@ -73,6 +73,14 @@ Proof. inv H. reflexivity. Qed. +Lemma stacksize_preserved: + forall f tf, + transf_function f = OK tf -> + LTLin.fn_stacksize tf = LTL.fn_stacksize f. +Proof. + intros. monadInv H. auto. +Qed. + Lemma find_function_translated: forall ros ls f, LTL.find_function ge ros ls = Some f -> @@ -593,6 +601,7 @@ Proof. econstructor; split. apply plus_one. eapply exec_Ltailcall with (f' := tf'); eauto. symmetry; apply sig_preserved; auto. + rewrite (stacksize_preserved _ _ TRF). eauto. econstructor; eauto. destruct ros; simpl in H0. eapply Genv.find_funct_prop; eauto. @@ -656,6 +665,7 @@ Proof. simpl in EQ. subst c. econstructor; split. apply plus_one. eapply exec_Lreturn; eauto. + rewrite (stacksize_preserved _ _ TRF). eauto. econstructor; eauto. (* internal function *) @@ -692,16 +702,14 @@ Lemma transf_initial_states: Proof. intros. inversion H. exploit function_ptr_translated; eauto. intros [tf [A B]]. - exists (Callstate nil tf nil (Genv.init_mem tprog)); split. - econstructor; eauto. + exists (Callstate nil tf nil m0); split. + econstructor; eauto. eapply Genv.init_mem_transf_partial; eauto. replace (prog_main tprog) with (prog_main prog). rewrite symbols_preserved. eauto. symmetry. apply (transform_partial_program_main transf_fundef _ TRANSF). - rewrite <- H2. apply sig_preserved. auto. - replace (Genv.init_mem tprog) with (Genv.init_mem prog). + rewrite <- H3. apply sig_preserved. auto. constructor. constructor. auto. eapply Genv.find_funct_ptr_prop; eauto. - symmetry. apply Genv.init_mem_transf_partial with transf_fundef. auto. Qed. Lemma transf_final_states: diff --git a/backend/Lineartyping.v b/backend/Lineartyping.v index 1fe7737..028e120 100644 --- a/backend/Lineartyping.v +++ b/backend/Lineartyping.v @@ -16,6 +16,7 @@ Require Import Coqlib. Require Import Maps. Require Import AST. Require Import Integers. +Require Import Memdata. Require Import Op. Require Import RTL. Require Import Locations. diff --git a/backend/Mach.v b/backend/Mach.v index f7e85c3..e89ff3b 100644 --- a/backend/Mach.v +++ b/backend/Mach.v @@ -22,7 +22,7 @@ Require Import Maps. Require Import AST. Require Import Integers. Require Import Values. -Require Import Mem. +Require Import Memory. Require Import Events. Require Import Globalenvs. Require Import Op. @@ -84,7 +84,7 @@ Definition funsig (fd: fundef) := | External ef => ef.(ef_sig) end. -Definition genv := Genv.t fundef. +Definition genv := Genv.t fundef unit. (** * Dynamic semantics *) diff --git a/backend/Machabstr.v b/backend/Machabstr.v index a2630a2..ceaf9a6 100644 --- a/backend/Machabstr.v +++ b/backend/Machabstr.v @@ -15,10 +15,10 @@ Require Import Coqlib. Require Import Maps. Require Import AST. -Require Import Mem. +Require Import Memory. Require Import Integers. Require Import Values. -Require Import Mem. +Require Import Memory. Require Import Events. Require Import Globalenvs. Require Import Smallstep. @@ -262,10 +262,11 @@ Inductive step: state -> trace -> state -> Prop := step (State s f sp (Mcall sig ros :: c) rs fr m) E0 (Callstate (Stackframe f sp c fr :: s) f' rs m) | exec_Mtailcall: - forall s f stk soff sig ros c rs fr m f', + forall s f stk soff sig ros c rs fr m f' m', find_function ros rs = Some f' -> + Mem.free m stk 0 f.(fn_stacksize) = Some m' -> step (State s f (Vptr stk soff) (Mtailcall sig ros :: c) rs fr m) - E0 (Callstate s f' rs (Mem.free m stk)) + E0 (Callstate s f' rs m') | exec_Mgoto: forall s f sp lbl c rs fr m c', find_label lbl f.(fn_code) = Some c' -> @@ -290,9 +291,10 @@ Inductive step: state -> trace -> state -> Prop := step (State s f sp (Mjumptable arg tbl :: c) rs fr m) E0 (State s f sp c' rs fr m) | exec_Mreturn: - forall s f stk soff c rs fr m, + forall s f stk soff c rs fr m m', + Mem.free m stk 0 f.(fn_stacksize) = Some m' -> step (State s f (Vptr stk soff) (Mreturn :: c) rs fr m) - E0 (Returnstate s rs (Mem.free m stk)) + E0 (Returnstate s rs m') | exec_function_internal: forall s f rs m m' stk, Mem.alloc m 0 f.(fn_stacksize) = (m', stk) -> @@ -300,12 +302,12 @@ Inductive step: state -> trace -> state -> Prop := E0 (State s f (Vptr stk (Int.repr (-f.(fn_framesize)))) f.(fn_code) rs empty_frame m') | exec_function_external: - forall s ef args res rs1 rs2 m t, - event_match ef args t res -> + forall s ef args res rs1 rs2 m t m', + external_call ef args m t res m' -> extcall_arguments (parent_function s) rs1 (parent_frame s) ef.(ef_sig) args -> rs2 = (rs1#(Conventions.loc_result ef.(ef_sig)) <- res) -> step (Callstate s (External ef) rs1 m) - t (Returnstate s rs2 m) + t (Returnstate s rs2 m') | exec_return: forall f sp c fr s rs m, step (Returnstate (Stackframe f sp c fr :: s) rs m) @@ -314,9 +316,9 @@ Inductive step: state -> trace -> state -> Prop := End RELSEM. Inductive initial_state (p: program): state -> Prop := - | initial_state_intro: forall b f, + | initial_state_intro: forall b f m0, let ge := Genv.globalenv p in - let m0 := Genv.init_mem p in + Genv.init_mem p = Some m0 -> Genv.find_symbol ge p.(prog_main) = Some b -> Genv.find_funct_ptr ge b = Some f -> initial_state p (Callstate nil f (Regmap.init Vundef) m0). diff --git a/backend/Machabstr2concr.v b/backend/Machabstr2concr.v index 89529fd..7714f3d 100644 --- a/backend/Machabstr2concr.v +++ b/backend/Machabstr2concr.v @@ -17,7 +17,7 @@ Require Import Maps. Require Import AST. Require Import Integers. Require Import Values. -Require Import Mem. +Require Import Memory. Require Import Events. Require Import Globalenvs. Require Import Smallstep. @@ -74,19 +74,27 @@ Hypothesis wt_f: wt_function f. semantics. [ms] is the current memory state in the concrete semantics. The stack pointer is [Vptr sp base] in both semantics. *) -Inductive frame_match (fr: frame) - (sp: block) (base: int) - (mm ms: mem) : Prop := - frame_match_intro: - valid_block ms sp -> - low_bound mm sp = 0 -> - low_bound ms sp = -f.(fn_framesize) -> - high_bound ms sp >= 0 -> - base = Int.repr (-f.(fn_framesize)) -> - (forall ty ofs, - -f.(fn_framesize) <= ofs -> ofs + AST.typesize ty <= 0 -> (4 | ofs) -> - load (chunk_of_type ty) ms sp ofs = Some(fr ty ofs)) -> - frame_match fr sp base mm ms. +Record frame_match (fr: frame) + (sp: block) (base: int) + (mm ms: mem) : Prop := + mk_frame_match { + fm_valid_1: + Mem.valid_block mm sp; + fm_valid_2: + Mem.valid_block ms sp; + fm_base: + base = Int.repr(- f.(fn_framesize)); + fm_stackdata_pos: + Mem.low_bound mm sp = 0; + fm_write_perm: + Mem.range_perm ms sp (-f.(fn_framesize)) 0 Freeable; + fm_contents_match: + forall ty ofs, + -f.(fn_framesize) <= ofs -> ofs + AST.typesize ty <= 0 -> (4 | ofs) -> + exists v, + Mem.load (chunk_of_type ty) ms sp ofs = Some v + /\ Val.lessdef (fr ty ofs) v + }. (** The following two innocuous-looking lemmas are the key results showing that [sp]-relative memory accesses in the concrete @@ -94,8 +102,8 @@ Inductive frame_match (fr: frame) semantics. First, a value [v] that has type [ty] is preserved when stored in memory with chunk [chunk_of_type ty], then read back with the same chunk. The typing hypothesis is crucial here: - for instance, a float value reads back as [Vundef] when stored - and load with chunk [Mint32]. *) + for instance, a float value is not preserved when stored + and loaded with chunk [Mint32]. *) Lemma load_result_ty: forall v ty, @@ -127,14 +135,15 @@ Lemma frame_match_load_stack: frame_match fr sp base mm ms -> 0 <= Int.signed ofs /\ Int.signed ofs + AST.typesize ty <= f.(fn_framesize) -> (4 | Int.signed ofs) -> - load_stack ms (Vptr sp base) ty ofs = - Some (fr ty (Int.signed ofs - f.(fn_framesize))). + exists v, + load_stack ms (Vptr sp base) ty ofs = Some v + /\ Val.lessdef (fr ty (Int.signed ofs - f.(fn_framesize))) v. Proof. intros. inv H. inv wt_f. - unfold load_stack, Val.add, loadv. + unfold load_stack, Val.add, Mem.loadv. replace (Int.signed (Int.add (Int.repr (- fn_framesize f)) ofs)) with (Int.signed ofs - fn_framesize f). - apply H7. omega. omega. + apply fm_contents_match0. omega. omega. apply Zdivide_minus_l; auto. assert (Int.signed (Int.repr (-fn_framesize f)) = -fn_framesize f). apply Int.signed_repr. @@ -149,9 +158,9 @@ Lemma frame_match_get_slot: forall fr sp base mm ms ty ofs v, frame_match fr sp base mm ms -> get_slot f fr ty (Int.signed ofs) v -> - load_stack ms (Vptr sp base) ty ofs = Some v. + exists v', load_stack ms (Vptr sp base) ty ofs = Some v' /\ Val.lessdef v v'. Proof. - intros. inversion H. inv H0. inv H7. eapply frame_match_load_stack; eauto. + intros. inv H0. inv H1. eapply frame_match_load_stack; eauto. Qed. (** Assigning a value to a frame slot (in the abstract semantics) @@ -160,19 +169,20 @@ Qed. and activation records is preserved. *) Lemma frame_match_store_stack: - forall fr sp base mm ms ty ofs v, + forall fr sp base mm ms ty ofs v v', frame_match fr sp base mm ms -> - 0 <= Int.signed ofs /\ Int.signed ofs + AST.typesize ty <= f.(fn_framesize) -> + 0 <= Int.signed ofs -> Int.signed ofs + AST.typesize ty <= f.(fn_framesize) -> (4 | Int.signed ofs) -> Val.has_type v ty -> + Val.lessdef v v' -> Mem.extends mm ms -> exists ms', - store_stack ms (Vptr sp base) ty ofs v = Some ms' /\ + store_stack ms (Vptr sp base) ty ofs v' = Some ms' /\ frame_match (update ty (Int.signed ofs - f.(fn_framesize)) v fr) sp base mm ms' /\ Mem.extends mm ms'. Proof. intros. inv H. inv wt_f. - unfold store_stack, Val.add, storev. + unfold store_stack, Val.add, Mem.storev. assert (Int.signed (Int.add (Int.repr (- fn_framesize f)) ofs) = Int.signed ofs - fn_framesize f). assert (Int.signed (Int.repr (-fn_framesize f)) = -fn_framesize f). @@ -183,58 +193,84 @@ Proof. apply Zle_trans with 0. generalize (AST.typesize_pos ty). omega. compute; congruence. rewrite H. - assert (exists ms', store (chunk_of_type ty) ms sp (Int.signed ofs - fn_framesize f) v = Some ms'). - apply valid_access_store. - constructor. auto. omega. - rewrite size_type_chunk. omega. + assert ({ ms' | Mem.store (chunk_of_type ty) ms sp (Int.signed ofs - fn_framesize f) v' = Some ms'}). + apply Mem.valid_access_store. constructor. + apply Mem.range_perm_implies with Freeable; auto with mem. + red; intros; apply fm_write_perm0. + rewrite <- size_type_chunk in H1. + generalize (size_chunk_pos (chunk_of_type ty)). + omega. replace (align_chunk (chunk_of_type ty)) with 4. apply Zdivide_minus_l; auto. destruct ty; auto. - destruct H8 as [ms' STORE]. - generalize (low_bound_store _ _ _ _ _ _ STORE sp). intro LB. - generalize (high_bound_store _ _ _ _ _ _ STORE sp). intro HB. + destruct X as [ms' STORE]. exists ms'. split. exact STORE. (* frame match *) - split. constructor; try congruence. - eauto with mem. intros. unfold update. - destruct (zeq (Int.signed ofs - fn_framesize f) ofs0). subst ofs0. + split. constructor. + (* valid *) + eauto with mem. + eauto with mem. + (* base *) + auto. + (* stackdata_pos *) + auto. + (* write_perm *) + red; intros; eauto with mem. + (* contents *) + intros. + exploit fm_contents_match0; eauto. intros [v0 [LOAD0 VLD0]]. + assert (exists v1, Mem.load (chunk_of_type ty0) ms' sp ofs0 = Some v1). + apply Mem.valid_access_load; eauto with mem. + destruct H9 as [v1 LOAD1]. + exists v1; split; auto. + unfold update. + destruct (zeq (Int.signed ofs - fn_framesize f) ofs0). subst ofs0. destruct (typ_eq ty ty0). subst ty0. (* same *) - transitivity (Some (Val.load_result (chunk_of_type ty) v)). - eapply load_store_same; eauto. - decEq. apply load_result_ty; auto. + inv H4. + assert (Some v1 = Some (Val.load_result (chunk_of_type ty) v')). + rewrite <- LOAD1. eapply Mem.load_store_same; eauto. + replace (type_of_chunk (chunk_of_type ty)) with ty. auto. + destruct ty; auto. + inv H4. rewrite load_result_ty; auto. + auto. (* mismatch *) - eapply load_store_mismatch'; eauto with mem. - destruct ty; destruct ty0; simpl; congruence. + auto. destruct (zle (ofs0 + AST.typesize ty0) (Int.signed ofs - fn_framesize f)). (* disjoint *) - rewrite <- H9; auto. eapply load_store_other; eauto. - right; left. rewrite size_type_chunk; auto. + assert (Some v1 = Some v0). + rewrite <- LOAD0; rewrite <- LOAD1. + eapply Mem.load_store_other; eauto. + right; left. rewrite size_type_chunk; auto. + inv H9. auto. destruct (zle (Int.signed ofs - fn_framesize f + AST.typesize ty)). - rewrite <- H9; auto. eapply load_store_other; eauto. - right; right. rewrite size_type_chunk; auto. + assert (Some v1 = Some v0). + rewrite <- LOAD0; rewrite <- LOAD1. + eapply Mem.load_store_other; eauto. + right; right. rewrite size_type_chunk; auto. + inv H9. auto. (* overlap *) - eapply load_store_overlap'; eauto with mem. - rewrite size_type_chunk; auto. - rewrite size_type_chunk; auto. + auto. (* extends *) - eapply store_outside_extends; eauto. - left. rewrite size_type_chunk. omega. + eapply Mem.store_outside_extends; eauto. + left. rewrite fm_stackdata_pos0. + rewrite size_type_chunk. omega. Qed. Lemma frame_match_set_slot: - forall fr sp base mm ms ty ofs v fr', + forall fr sp base mm ms ty ofs v fr' v', frame_match fr sp base mm ms -> set_slot f fr ty (Int.signed ofs) v fr' -> Val.has_type v ty -> + Val.lessdef v v' -> Mem.extends mm ms -> exists ms', - store_stack ms (Vptr sp base) ty ofs v = Some ms' /\ + store_stack ms (Vptr sp base) ty ofs v' = Some ms' /\ frame_match fr' sp base mm ms' /\ Mem.extends mm ms'. Proof. - intros. inv H0. inv H3. eapply frame_match_store_stack; eauto. + intros. inv H0. inv H4. eapply frame_match_store_stack; eauto. Qed. (** Agreement is preserved by stores within blocks other than the @@ -243,45 +279,40 @@ Qed. Lemma frame_match_store_other: forall fr sp base mm ms chunk b ofs v ms', frame_match fr sp base mm ms -> - store chunk ms b ofs v = Some ms' -> + Mem.store chunk ms b ofs v = Some ms' -> sp <> b -> frame_match fr sp base mm ms'. Proof. - intros. inv H. - generalize (low_bound_store _ _ _ _ _ _ H0 sp). intro LB. - generalize (high_bound_store _ _ _ _ _ _ H0 sp). intro HB. - apply frame_match_intro; auto. - eauto with mem. - congruence. - congruence. - intros. rewrite <- H7; auto. - eapply load_store_other; eauto. + intros. inv H. constructor; auto. + eauto with mem. + red; intros; eauto with mem. + intros. exploit fm_contents_match0; eauto. intros [v0 [LOAD LD]]. + exists v0; split; auto. rewrite <- LOAD. eapply Mem.load_store_other; eauto. Qed. (** Agreement is preserved by parallel stores in the Machabstr and the Machconcr semantics. *) Lemma frame_match_store: - forall fr sp base mm ms chunk b ofs v mm' ms', + forall fr sp base mm ms chunk b ofs v mm' v' ms', frame_match fr sp base mm ms -> - store chunk mm b ofs v = Some mm' -> - store chunk ms b ofs v = Some ms' -> + Mem.store chunk mm b ofs v = Some mm' -> + Mem.store chunk ms b ofs v' = Some ms' -> frame_match fr sp base mm' ms'. Proof. - intros. inv H. - generalize (low_bound_store _ _ _ _ _ _ H0 sp). intro LBm. - generalize (low_bound_store _ _ _ _ _ _ H1 sp). intro LBs. - generalize (high_bound_store _ _ _ _ _ _ H0 sp). intro HBm. - generalize (high_bound_store _ _ _ _ _ _ H1 sp). intro HBs. - apply frame_match_intro; auto. + intros. inv H. constructor; auto. eauto with mem. - congruence. congruence. congruence. - intros. rewrite <- H7; auto. eapply load_store_other; eauto. - destruct (zeq sp b). subst b. right. + eauto with mem. + rewrite (Mem.bounds_store _ _ _ _ _ _ H0). auto. + red; intros; eauto with mem. + intros. exploit fm_contents_match0; eauto. intros [v0 [LOAD LD]]. + exists v0; split; auto. rewrite <- LOAD. eapply Mem.load_store_other; eauto. + destruct (zeq sp b); auto. subst b. right. rewrite size_type_chunk. - assert (valid_access mm chunk sp ofs) by eauto with mem. - inv H9. left. omega. - auto. + assert (Mem.valid_access mm chunk sp ofs Nonempty) by eauto with mem. + exploit Mem.store_valid_access_3. eexact H0. intro. + exploit Mem.valid_access_in_bounds. eauto. rewrite fm_stackdata_pos0. + omega. Qed. (** Memory allocation of the Cminor stack data block (in the abstract @@ -291,68 +322,111 @@ Qed. remain true. *) Lemma frame_match_new: - forall mm ms mm' ms' sp sp', - mm.(nextblock) = ms.(nextblock) -> - alloc mm 0 f.(fn_stacksize) = (mm', sp) -> - alloc ms (- f.(fn_framesize)) f.(fn_stacksize) = (ms', sp') -> - sp = sp' /\ + forall mm ms mm' ms' sp, + Mem.alloc mm 0 f.(fn_stacksize) = (mm', sp) -> + Mem.alloc ms (- f.(fn_framesize)) f.(fn_stacksize) = (ms', sp) -> frame_match empty_frame sp (Int.repr (-f.(fn_framesize))) mm' ms'. Proof. intros. - assert (sp = sp'). - exploit alloc_result. eexact H0. exploit alloc_result. eexact H1. - congruence. - subst sp'. split. auto. - generalize (low_bound_alloc_same _ _ _ _ _ H0). intro LBm. - generalize (low_bound_alloc_same _ _ _ _ _ H1). intro LBs. - generalize (high_bound_alloc_same _ _ _ _ _ H0). intro HBm. - generalize (high_bound_alloc_same _ _ _ _ _ H1). intro HBs. inv wt_f. constructor; simpl; eauto with mem. - rewrite HBs. auto. - intros. - eapply load_alloc_same'; eauto. + rewrite (Mem.bounds_alloc_same _ _ _ _ _ H). auto. + red; intros. eapply Mem.perm_alloc_2; eauto. omega. + intros. exists Vundef; split. + eapply Mem.load_alloc_same'; eauto. rewrite size_type_chunk. omega. - replace (align_chunk (chunk_of_type ty)) with 4; auto. destruct ty; auto. + replace (align_chunk (chunk_of_type ty)) with 4; auto. + destruct ty; auto. + unfold empty_frame. auto. Qed. Lemma frame_match_alloc: - forall mm ms fr sp base lom him los his mm' ms' bm bs, - mm.(nextblock) = ms.(nextblock) -> + forall mm ms fr sp base lom him los his mm' ms' b, frame_match fr sp base mm ms -> - alloc mm lom him = (mm', bm) -> - alloc ms los his = (ms', bs) -> + Mem.alloc mm lom him = (mm', b) -> + Mem.alloc ms los his = (ms', b) -> frame_match fr sp base mm' ms'. Proof. - intros. inversion H0. - assert (valid_block mm sp). red. rewrite H. auto. - exploit low_bound_alloc_other. eexact H1. eexact H9. intro LBm. - exploit high_bound_alloc_other. eexact H1. eexact H9. intro HBm. - exploit low_bound_alloc_other. eexact H2. eexact H3. intro LBs. - exploit high_bound_alloc_other. eexact H2. eexact H3. intro HBs. - apply frame_match_intro. - eapply valid_block_alloc; eauto. - congruence. congruence. congruence. auto. auto. - intros. eapply load_alloc_other; eauto. + intros. inversion H. + assert (sp <> b). + apply Mem.valid_not_valid_diff with ms; eauto with mem. + constructor; auto. + eauto with mem. + eauto with mem. + rewrite (Mem.bounds_alloc_other _ _ _ _ _ H0); auto. + red; intros; eauto with mem. + intros. exploit fm_contents_match0; eauto. intros [v [LOAD LD]]. + exists v; split; auto. eapply Mem.load_alloc_other; eauto. Qed. (** [frame_match] relations are preserved by freeing a block other than the one pointed to by [sp]. *) Lemma frame_match_free: - forall fr sp base mm ms b, + forall fr sp base mm ms b lom him los his mm' ms', frame_match fr sp base mm ms -> sp <> b -> - frame_match fr sp base (free mm b) (free ms b). + Mem.free mm b lom him = Some mm' -> + Mem.free ms b los his = Some ms' -> + frame_match fr sp base mm' ms'. +Proof. + intros. inversion H. constructor; auto. + eauto with mem. + eauto with mem. + rewrite (Mem.bounds_free _ _ _ _ _ H1). auto. + red; intros; eauto with mem. + intros. rewrite (Mem.load_free _ _ _ _ _ H2); auto. +Qed. + +Lemma frame_match_delete: + forall fr sp base mm ms mm', + frame_match fr sp base mm ms -> + Mem.free mm sp 0 f.(fn_stacksize) = Some mm' -> + Mem.extends mm ms -> + exists ms', + Mem.free ms sp (-f.(fn_framesize)) f.(fn_stacksize) = Some ms' + /\ Mem.extends mm' ms'. Proof. intros. inversion H. - generalize (low_bound_free mm _ _ H0); intro LBm. - generalize (low_bound_free ms _ _ H0); intro LBs. - generalize (high_bound_free mm _ _ H0); intro HBm. - generalize (high_bound_free ms _ _ H0); intro HBs. - apply frame_match_intro; auto. - congruence. congruence. congruence. - intros. rewrite <- H6; auto. apply load_free. auto. + assert (Mem.range_perm mm sp 0 (fn_stacksize f) Freeable). + eapply Mem.free_range_perm; eauto. + assert ({ ms' | Mem.free ms sp (-f.(fn_framesize)) f.(fn_stacksize) = Some ms' }). + apply Mem.range_perm_free. + red; intros. destruct (zlt ofs 0). + apply fm_write_perm0. omega. + eapply Mem.perm_extends; eauto. apply H2. omega. + destruct X as [ms' FREE]. exists ms'; split; auto. + eapply Mem.free_right_extends; eauto. + eapply Mem.free_left_extends; eauto. + intros; red; intros. + exploit Mem.perm_in_bounds; eauto. + rewrite (Mem.bounds_free _ _ _ _ _ H0). rewrite fm_stackdata_pos0; intro. + exploit Mem.perm_free_2. eexact H0. instantiate (1 := ofs); omega. eauto. + auto. +Qed. + +(** [frame_match] is preserved by external calls. *) + +Lemma frame_match_external_call: + forall fr sp base mm ms mm' ms' ef vargs vres t vargs' vres', + frame_match fr sp base mm ms -> + Mem.extends mm ms -> + external_call ef vargs mm t vres mm' -> + Mem.extends mm' ms' -> + external_call ef vargs' ms t vres' ms' -> + mem_unchanged_on (loc_out_of_bounds mm) ms ms' -> + frame_match fr sp base mm' ms'. +Proof. + intros. destruct H4 as [A B]. inversion H. constructor. + eapply external_call_valid_block; eauto. + eapply external_call_valid_block; eauto. + auto. + rewrite (external_call_bounds _ _ _ _ _ _ _ H1); auto. + red; intros. apply A; auto. red. omega. + intros. exploit fm_contents_match0; eauto. intros [v [C D]]. + exists v; split; auto. + apply B; auto. + rewrite size_type_chunk; intros; red. omega. Qed. End FRAME_MATCH. @@ -430,61 +504,130 @@ Proof. simpl. omega. Qed. +Definition is_pointer_or_int (v: val) : Prop := + match v with + | Vint _ => True + | Vptr _ _ => True + | _ => False + end. + +Remark is_pointer_has_type: + forall v, is_pointer_or_int v -> Val.has_type v Tint. +Proof. + intros; destruct v; elim H; exact I. +Qed. + +Lemma frame_match_load_stack_pointer: + forall fr sp base mm ms ty ofs, + frame_match f fr sp base mm ms -> + 0 <= Int.signed ofs /\ Int.signed ofs + AST.typesize ty <= f.(fn_framesize) -> + (4 | Int.signed ofs) -> + is_pointer_or_int (fr ty (Int.signed ofs - f.(fn_framesize))) -> + load_stack ms (Vptr sp base) ty ofs = Some (fr ty (Int.signed ofs - f.(fn_framesize))). +Proof. + intros. exploit frame_match_load_stack; eauto. + intros [v [LOAD LD]]. + inv LD. auto. rewrite <- H4 in H2. elim H2. +Qed. + Lemma frame_match_load_link: forall fr sp base mm ms, frame_match f (extend_frame fr) sp base mm ms -> - load_stack ms (Vptr sp base) Tint f.(fn_link_ofs) = Some (parent_sp cs). + is_pointer_or_int (parent_sp cs) -> + load_stack ms (Vptr sp base) Tint f.(fn_link_ofs) = Some(parent_sp cs). Proof. intros. inversion wt_f. - replace (parent_sp cs) with - (extend_frame fr Tint (Int.signed f.(fn_link_ofs) - f.(fn_framesize))). - eapply frame_match_load_stack; eauto. - - unfold extend_frame. rewrite update_other. apply update_same. simpl. omega. + assert (parent_sp cs = + extend_frame fr Tint (Int.signed f.(fn_link_ofs) - f.(fn_framesize))). + unfold extend_frame. rewrite update_other. rewrite update_same. auto. + simpl. omega. + rewrite H1; eapply frame_match_load_stack_pointer; eauto. + rewrite <- H1; auto. Qed. Lemma frame_match_load_retaddr: forall fr sp base mm ms, frame_match f (extend_frame fr) sp base mm ms -> - load_stack ms (Vptr sp base) Tint f.(fn_retaddr_ofs) = Some (parent_ra cs). + is_pointer_or_int (parent_ra cs) -> + load_stack ms (Vptr sp base) Tint f.(fn_retaddr_ofs) = Some(parent_ra cs). Proof. intros. inversion wt_f. - replace (parent_ra cs) with - (extend_frame fr Tint (Int.signed f.(fn_retaddr_ofs) - f.(fn_framesize))). - eapply frame_match_load_stack; eauto. - unfold extend_frame. apply update_same. + assert (parent_ra cs = + extend_frame fr Tint (Int.signed f.(fn_retaddr_ofs) - f.(fn_framesize))). + unfold extend_frame. rewrite update_same. auto. + rewrite H1; eapply frame_match_load_stack_pointer; eauto. + rewrite <- H1; auto. Qed. Lemma frame_match_function_entry: - forall mm ms mm' ms1 sp sp', - extends mm ms -> - alloc mm 0 f.(fn_stacksize) = (mm', sp) -> - alloc ms (- f.(fn_framesize)) f.(fn_stacksize) = (ms1, sp') -> - Val.has_type (parent_sp cs) Tint -> - Val.has_type (parent_ra cs) Tint -> + forall mm ms mm' sp, + Mem.extends mm ms -> + Mem.alloc mm 0 f.(fn_stacksize) = (mm', sp) -> + is_pointer_or_int (parent_sp cs) -> + is_pointer_or_int (parent_ra cs) -> let base := Int.repr (-f.(fn_framesize)) in - exists ms2, exists ms3, - sp = sp' /\ + exists ms1, exists ms2, exists ms3, + Mem.alloc ms (- f.(fn_framesize)) f.(fn_stacksize) = (ms1, sp) /\ store_stack ms1 (Vptr sp base) Tint f.(fn_link_ofs) (parent_sp cs) = Some ms2 /\ store_stack ms2 (Vptr sp base) Tint f.(fn_retaddr_ofs) (parent_ra cs) = Some ms3 /\ frame_match f (extend_frame empty_frame) sp base mm' ms3 /\ - extends mm' ms3. + Mem.extends mm' ms3. Proof. intros. inversion wt_f. - exploit alloc_extends; eauto. omega. omega. intros [A EXT0]. - exploit frame_match_new. eauto. inv H. eexact H4. eauto. eauto. eauto. - fold base. intros [C FM0]. - destruct (frame_match_store_stack _ wt_f _ _ _ _ _ Tint _ _ - FM0 wt_function_link wt_function_link_aligned H2 EXT0) - as [ms2 [STORE1 [FM1 EXT1]]]. - destruct (frame_match_store_stack _ wt_f _ _ _ _ _ Tint _ _ - FM1 wt_function_retaddr wt_function_retaddr_aligned H3 EXT1) - as [ms3 [STORE2 [FM3 EXT3]]]. - exists ms2; exists ms3; auto. + exploit Mem.alloc_extends; eauto. + instantiate (1 := -f.(fn_framesize)). omega. + instantiate (1 := f.(fn_stacksize)). omega. + intros [ms1 [A EXT0]]. + exploit frame_match_new; eauto. fold base. intros FM0. + exploit frame_match_store_stack. eauto. eexact FM0. + instantiate (1 := fn_link_ofs f); omega. + instantiate (1 := Tint). simpl; omega. + auto. apply is_pointer_has_type. eexact H1. constructor. auto. + intros [ms2 [STORE1 [FM1 EXT1]]]. + exploit frame_match_store_stack. eauto. eexact FM1. + instantiate (1 := fn_retaddr_ofs f); omega. + instantiate (1 := Tint). simpl; omega. + auto. apply is_pointer_has_type. eexact H2. constructor. auto. + intros [ms3 [STORE2 [FM2 EXT2]]]. + exists ms1; exists ms2; exists ms3; auto. Qed. End EXTEND_FRAME. +(** ** The ``less defined than'' relation between register states. *) + +Definition regset_lessdef (rs1 rs2: regset) : Prop := + forall r, Val.lessdef (rs1 r) (rs2 r). + +Lemma regset_lessdef_list: + forall rs1 rs2, regset_lessdef rs1 rs2 -> + forall rl, Val.lessdef_list (rs1##rl) (rs2##rl). +Proof. + induction rl; simpl. + constructor. + constructor; auto. +Qed. + +Lemma regset_lessdef_set: + forall rs1 rs2 r v1 v2, + regset_lessdef rs1 rs2 -> Val.lessdef v1 v2 -> + regset_lessdef (rs1#r <- v1) (rs2#r <- v2). +Proof. + intros; red; intros. unfold Regmap.set. + destruct (RegEq.eq r0 r); auto. +Qed. + +Lemma regset_lessdef_find_function_ptr: + forall ge ros rs1 rs2 fb, + find_function_ptr ge ros rs1 = Some fb -> + regset_lessdef rs1 rs2 -> + find_function_ptr ge ros rs2 = Some fb. +Proof. + unfold find_function_ptr; intros; destruct ros; simpl in *. + generalize (H0 m); intro LD; inv LD. auto. rewrite <- H2 in H. congruence. + auto. +Qed. + (** ** Invariant for stacks *) Section SIMULATION. @@ -518,12 +661,26 @@ Inductive match_stacks: wt_function f -> frame_match f (extend_frame f ts fr) sp base mm ms -> stack_below ts sp -> - Val.has_type ra Tint -> + is_pointer_or_int ra -> match_stacks s ts mm ms -> match_stacks (Machabstr.Stackframe f (Vptr sp base) c fr :: s) (Machconcr.Stackframe fb (Vptr sp base) ra c :: ts) mm ms. +Lemma match_stacks_parent_sp_pointer: + forall s ts mm ms, + match_stacks s ts mm ms -> is_pointer_or_int (Machconcr.parent_sp ts). +Proof. + induction 1; simpl; auto. +Qed. + +Lemma match_stacks_parent_ra_pointer: + forall s ts mm ms, + match_stacks s ts mm ms -> is_pointer_or_int (Machconcr.parent_ra ts). +Proof. + induction 1; simpl; auto. +Qed. + (** If [match_stacks] holds, a lookup in the parent frame in the Machabstr semantics corresponds to two memory loads in the Machconcr semantics, one to load the pointer to the parent's @@ -533,7 +690,9 @@ Lemma match_stacks_get_parent: forall s ts mm ms ty ofs v, match_stacks s ts mm ms -> get_slot (parent_function s) (parent_frame s) ty (Int.signed ofs) v -> - load_stack ms (Machconcr.parent_sp ts) ty ofs = Some v. + exists v', + load_stack ms (Machconcr.parent_sp ts) ty ofs = Some v' + /\ Val.lessdef v v'. Proof. intros. inv H; simpl in H0. inv H0. inv H. simpl in H1. elimtype False. generalize (AST.typesize_pos ty). omega. @@ -542,7 +701,7 @@ Proof. Qed. (** Preservation of the [match_stacks] invariant - by various kinds of memory stores. *) + by various kinds of memory operations. *) Remark stack_below_trans: forall ts b b', @@ -556,7 +715,7 @@ Lemma match_stacks_store_other: forall s ts ms mm, match_stacks s ts mm ms -> forall chunk b ofs v ms', - store chunk ms b ofs v = Some ms' -> + Mem.store chunk ms b ofs v = Some ms' -> stack_below ts b -> match_stacks s ts mm ms'. Proof. @@ -593,9 +752,9 @@ Qed. Lemma match_stacks_store: forall s ts ms mm, match_stacks s ts mm ms -> - forall chunk b ofs v mm' ms', - store chunk mm b ofs v = Some mm' -> - store chunk ms b ofs v = Some ms' -> + forall chunk b ofs v mm' v' ms', + Mem.store chunk mm b ofs v = Some mm' -> + Mem.store chunk ms b ofs v' = Some ms' -> match_stacks s ts mm' ms'. Proof. induction 1; intros. @@ -607,28 +766,28 @@ Qed. Lemma match_stacks_alloc: forall s ts ms mm, match_stacks s ts mm ms -> - forall lom him mm' bm los his ms' bs, - mm.(nextblock) = ms.(nextblock) -> - alloc mm lom him = (mm', bm) -> - alloc ms los his = (ms', bs) -> + forall lom him mm' b los his ms', + Mem.alloc mm lom him = (mm', b) -> + Mem.alloc ms los his = (ms', b) -> match_stacks s ts mm' ms'. Proof. induction 1; intros. constructor. - econstructor; eauto. - eapply frame_match_alloc; eauto. + econstructor; eauto. eapply frame_match_alloc; eauto. Qed. Lemma match_stacks_free: forall s ts ms mm, match_stacks s ts mm ms -> - forall b, + forall b lom him los his mm' ms', + Mem.free mm b lom him = Some mm' -> + Mem.free ms b los his = Some ms' -> stack_below ts b -> - match_stacks s ts (Mem.free mm b) (Mem.free ms b). + match_stacks s ts mm' ms'. Proof. induction 1; intros. constructor. - red in H5; simpl in H5. + red in H7; simpl in H7. econstructor; eauto. eapply frame_match_free; eauto. unfold block; omega. eapply IHmatch_stacks; eauto. @@ -636,21 +795,36 @@ Proof. Qed. Lemma match_stacks_function_entry: - forall s ts mm ms lom him mm' los his ms' stk, + forall s ts ms mm, match_stacks s ts mm ms -> - alloc mm lom him = (mm', stk) -> - alloc ms los his = (ms', stk) -> + forall lom him mm' stk los his ms', + Mem.alloc mm lom him = (mm', stk) -> + Mem.alloc ms los his = (ms', stk) -> match_stacks s ts mm' ms' /\ stack_below ts stk. Proof. intros. - assert (stk = nextblock mm). eapply Mem.alloc_result; eauto. - assert (stk = nextblock ms). eapply Mem.alloc_result; eauto. - split. - eapply match_stacks_alloc; eauto. congruence. - red. - inv H; simpl. - unfold nullptr. apply Zgt_lt. apply nextblock_pos. - inv H6. red in H. rewrite H3. auto. + assert (stk = Mem.nextblock mm) by eauto with mem. + split. eapply match_stacks_alloc; eauto. + red. inv H; simpl. + unfold Mem.nullptr. apply Zgt_lt. apply Mem.nextblock_pos. + inv H5. auto. +Qed. + +Lemma match_stacks_external_call: + forall s ts mm ms, + match_stacks s ts mm ms -> + forall ef vargs t vres mm' ms' vargs' vres', + Mem.extends mm ms -> + external_call ef vargs mm t vres mm' -> + Mem.extends mm' ms' -> + external_call ef vargs' ms t vres' ms' -> + mem_unchanged_on (loc_out_of_bounds mm) ms ms' -> + match_stacks s ts mm' ms'. +Proof. + induction 1; intros. + constructor. + econstructor; eauto. + eapply frame_match_external_call; eauto. Qed. (** ** Invariant between states. *) @@ -666,27 +840,30 @@ Qed. Inductive match_states: Machabstr.state -> Machconcr.state -> Prop := | match_states_intro: - forall s f sp base c rs fr mm ts fb ms + forall s f sp base c rs fr mm ts trs fb ms (STACKS: match_stacks s ts mm ms) (FM: frame_match f (extend_frame f ts fr) sp base mm ms) (BELOW: stack_below ts sp) + (RLD: regset_lessdef rs trs) (MEXT: Mem.extends mm ms) (FIND: Genv.find_funct_ptr ge fb = Some (Internal f)), match_states (Machabstr.State s f (Vptr sp base) c rs fr mm) - (Machconcr.State ts fb (Vptr sp base) c rs ms) + (Machconcr.State ts fb (Vptr sp base) c trs ms) | match_states_call: - forall s f rs mm ts fb ms + forall s f rs mm ts trs fb ms (STACKS: match_stacks s ts mm ms) (MEXT: Mem.extends mm ms) + (RLD: regset_lessdef rs trs) (FIND: Genv.find_funct_ptr ge fb = Some f), match_states (Machabstr.Callstate s f rs mm) - (Machconcr.Callstate ts fb rs ms) + (Machconcr.Callstate ts fb trs ms) | match_states_return: - forall s rs mm ts ms + forall s rs mm ts trs ms (STACKS: match_stacks s ts mm ms) - (MEXT: Mem.extends mm ms), + (MEXT: Mem.extends mm ms) + (RLD: regset_lessdef rs trs), match_states (Machabstr.Returnstate s rs mm) - (Machconcr.Returnstate ts rs ms). + (Machconcr.Returnstate ts trs ms). (** * The proof of simulation *) @@ -725,20 +902,26 @@ Qed. (** Preservation of arguments to external functions. *) Lemma transl_extcall_arguments: - forall rs s sg args ts m ms, + forall rs s sg args ts trs m ms, Machabstr.extcall_arguments (parent_function s) rs (parent_frame s) sg args -> + regset_lessdef rs trs -> match_stacks s ts m ms -> - extcall_arguments rs ms (parent_sp ts) sg args. + exists targs, + extcall_arguments trs ms (parent_sp ts) sg targs + /\ Val.lessdef_list args targs. Proof. unfold Machabstr.extcall_arguments, extcall_arguments; intros. - assert (forall locs vals, - Machabstr.extcall_args (parent_function s) rs (parent_frame s) locs vals -> - extcall_args rs ms (parent_sp ts) locs vals). - induction locs; intros; inv H1. - constructor. + generalize (Conventions.loc_arguments sg) args H. + induction l; intros; inv H2. + exists (@nil val); split; constructor. + exploit IHl; eauto. intros [targs [A B]]. + inv H7. exists (trs r :: targs); split. + constructor; auto. constructor. + constructor; auto. + exploit match_stacks_get_parent; eauto. intros [targ [C D]]. + exists (targ :: targs); split. + constructor; auto. constructor; auto. constructor; auto. - inv H6. constructor. constructor. eapply match_stacks_get_parent; eauto. - auto. Qed. Hypothesis wt_prog: wt_program p. @@ -757,11 +940,11 @@ Proof. (* Mgetstack *) assert (WTF: wt_function f) by (inv WTS; auto). - exists (State ts fb (Vptr sp0 base) c (rs#dst <- v) ms); split. + exploit frame_match_get_slot; eauto. eapply get_slot_extends; eauto. + intros [v' [A B]]. + exists (State ts fb (Vptr sp0 base) c (trs#dst <- v') ms); split. constructor; auto. - eapply frame_match_get_slot; eauto. - eapply get_slot_extends; eauto. - econstructor; eauto with coqlib. + econstructor; eauto with coqlib. eapply regset_lessdef_set; eauto. (* Msetstack *) assert (WTF: wt_function f) by (inv WTS; auto). @@ -769,41 +952,51 @@ Proof. inv WTS. generalize (wt_function_instrs _ WTF _ (is_tail_in TAIL)); intro WTI. inv WTI. apply WTRS. - exploit frame_match_set_slot; eauto. + exploit frame_match_set_slot. eauto. eauto. eapply set_slot_extends; eauto. + auto. apply RLD. auto. intros [ms' [STORE [FM' EXT']]]. - exists (State ts fb (Vptr sp0 base) c rs ms'); split. + exists (State ts fb (Vptr sp0 base) c trs ms'); split. apply exec_Msetstack; auto. econstructor; eauto. eapply match_stacks_store_slot; eauto. (* Mgetparam *) assert (WTF: wt_function f) by (inv WTS; auto). - exists (State ts fb (Vptr sp0 base) c (rs#dst <- v) ms); split. + exploit match_stacks_get_parent; eauto. intros [v' [A B]]. + exists (State ts fb (Vptr sp0 base) c (trs#dst <- v') ms); split. eapply exec_Mgetparam; eauto. eapply frame_match_load_link; eauto. - eapply match_stacks_get_parent; eauto. - econstructor; eauto with coqlib. + eapply match_stacks_parent_sp_pointer; eauto. + econstructor; eauto with coqlib. apply regset_lessdef_set; eauto. (* Mop *) - exists (State ts fb (Vptr sp0 base) c (rs#res <- v) ms); split. + exploit eval_operation_lessdef. 2: eauto. + eapply regset_lessdef_list; eauto. + intros [v' [A B]]. + exists (State ts fb (Vptr sp0 base) c (trs#res <- v') ms); split. apply exec_Mop; auto. - econstructor; eauto with coqlib. + econstructor; eauto with coqlib. apply regset_lessdef_set; eauto. (* Mload *) - exists (State ts fb (Vptr sp0 base) c (rs#dst <- v) ms); split. + exploit eval_addressing_lessdef. 2: eauto. eapply regset_lessdef_list; eauto. + intros [a' [A B]]. + exploit Mem.loadv_extends. eauto. eauto. eexact B. + intros [v' [C D]]. + exists (State ts fb (Vptr sp0 base) c (trs#dst <- v') ms); split. eapply exec_Mload; eauto. - destruct a; simpl in H0; try discriminate. - simpl. eapply Mem.load_extends; eauto. - econstructor; eauto with coqlib. + econstructor; eauto with coqlib. apply regset_lessdef_set; eauto. (* Mstore *) - destruct a; simpl in H0; try discriminate. - exploit Mem.store_within_extends; eauto. intros [ms' [STORE MEXT']]. - exists (State ts fb (Vptr sp0 base) c rs ms'); split. + exploit eval_addressing_lessdef. 2: eauto. eapply regset_lessdef_list; eauto. + intros [a' [A B]]. + exploit Mem.storev_extends. eauto. eauto. eexact B. apply RLD. + intros [ms' [C D]]. + exists (State ts fb (Vptr sp0 base) c trs ms'); split. eapply exec_Mstore; eauto. + destruct a; simpl in H0; try congruence. inv B. simpl in C. econstructor; eauto with coqlib. - eapply match_stacks_store; eauto. + eapply match_stacks_store. eauto. eexact H0. eexact C. eapply frame_match_store; eauto. (* Mcall *) @@ -814,7 +1007,7 @@ Proof. inv WTS. eapply is_tail_cons_left; eauto. destruct H0 as [ra' RETADDR]. econstructor; split. - eapply exec_Mcall; eauto. + eapply exec_Mcall; eauto. eapply regset_lessdef_find_function_ptr; eauto. econstructor; eauto. econstructor; eauto. inv WTS; auto. exact I. @@ -822,12 +1015,13 @@ Proof. assert (WTF: wt_function f) by (inv WTS; auto). exploit find_function_find_function_ptr; eauto. intros [fb' [FIND' FINDFUNCT]]. + exploit frame_match_delete; eauto. intros [ms' [A B]]. econstructor; split. eapply exec_Mtailcall; eauto. - eapply frame_match_load_link; eauto. - eapply frame_match_load_retaddr; eauto. - econstructor; eauto. eapply match_stacks_free; auto. - apply free_extends; auto. + eapply regset_lessdef_find_function_ptr; eauto. + eapply frame_match_load_link; eauto. eapply match_stacks_parent_sp_pointer; eauto. + eapply frame_match_load_retaddr; eauto. eapply match_stacks_parent_ra_pointer; eauto. + econstructor; eauto. eapply match_stacks_free; eauto. (* Mgoto *) econstructor; split. @@ -837,49 +1031,50 @@ Proof. (* Mcond *) econstructor; split. eapply exec_Mcond_true; eauto. + eapply eval_condition_lessdef; eauto. apply regset_lessdef_list; auto. econstructor; eauto. econstructor; split. eapply exec_Mcond_false; eauto. + eapply eval_condition_lessdef; eauto. apply regset_lessdef_list; auto. econstructor; eauto. (* Mjumptable *) econstructor; split. - eapply exec_Mjumptable; eauto. + eapply exec_Mjumptable; eauto. + generalize (RLD arg); intro LD. rewrite H in LD. inv LD. auto. econstructor; eauto. (* Mreturn *) assert (WTF: wt_function f) by (inv WTS; auto). + exploit frame_match_delete; eauto. intros [ms' [A B]]. econstructor; split. eapply exec_Mreturn; eauto. - eapply frame_match_load_link; eauto. - eapply frame_match_load_retaddr; eauto. + eapply frame_match_load_link; eauto. eapply match_stacks_parent_sp_pointer; eauto. + eapply frame_match_load_retaddr; eauto. eapply match_stacks_parent_ra_pointer; eauto. econstructor; eauto. eapply match_stacks_free; eauto. - apply free_extends; auto. (* internal function *) assert (WTF: wt_function f). inv WTS. inv H5. auto. - caseEq (alloc ms (- f.(fn_framesize)) f.(fn_stacksize)). - intros ms' stk' ALLOC. - assert (Val.has_type (parent_sp ts) Tint). - inv STACKS; simpl; auto. - assert (Val.has_type (parent_ra ts) Tint). - inv STACKS; simpl; auto. - destruct (frame_match_function_entry _ WTF _ _ _ _ _ _ _ - MEXT H ALLOC H0 H1) - as [ms2 [ms3 [EQ [STORE1 [STORE2 [FM MEXT']]]]]]. - subst stk'. + exploit frame_match_function_entry. eauto. eauto. eauto. + instantiate (1 := ts). eapply match_stacks_parent_sp_pointer; eauto. + eapply match_stacks_parent_ra_pointer; eauto. + intros [ms1 [ms2 [ms3 [ALLOC [STORE1 [STORE2 [FM MEXT']]]]]]]. econstructor; split. eapply exec_function_internal; eauto. exploit match_stacks_function_entry; eauto. intros [STACKS' BELOW]. econstructor; eauto. eapply match_stacks_store_slot with (ms := ms2); eauto. - eapply match_stacks_store_slot with (ms := ms'); eauto. + eapply match_stacks_store_slot with (ms := ms1); eauto. (* external function *) + exploit transl_extcall_arguments; eauto. intros [targs [A B]]. + exploit external_call_mem_extends; eauto. + intros [tres [ms' [C [D [E F]]]]]. econstructor; split. - eapply exec_function_external; eauto. - eapply transl_extcall_arguments; eauto. + eapply exec_function_external. eauto. eexact C. eexact A. reflexivity. econstructor; eauto. + eapply match_stacks_external_call; eauto. + apply regset_lessdef_set; auto. (* return *) inv STACKS. @@ -894,8 +1089,10 @@ Lemma equiv_initial_states: Proof. intros. inversion H. econstructor; split. - econstructor. eauto. - split. econstructor. constructor. apply Mem.extends_refl. auto. + econstructor. eauto. eauto. + split. econstructor. constructor. apply Mem.extends_refl. + unfold Regmap.init; red; intros. constructor. + auto. econstructor. simpl; intros; contradiction. eapply Genv.find_funct_ptr_prop; eauto. red; intros; exact I. @@ -906,7 +1103,9 @@ Lemma equiv_final_states: match_states st1 st2 /\ wt_state st1 -> Machabstr.final_state st1 r -> Machconcr.final_state st2 r. Proof. intros. inv H0. destruct H. inv H. inv STACKS. - constructor; auto. + constructor. + generalize (RLD (Conventions.loc_result (mksignature nil (Some Tint)))). + rewrite H1. intro LD. inv LD. auto. Qed. Theorem exec_program_equiv: diff --git a/backend/Machconcr.v b/backend/Machconcr.v index 84ae0a4..a6be4bc 100644 --- a/backend/Machconcr.v +++ b/backend/Machconcr.v @@ -17,7 +17,7 @@ Require Import Maps. Require Import AST. Require Import Integers. Require Import Values. -Require Import Mem. +Require Import Memory. Require Import Events. Require Import Globalenvs. Require Import Smallstep. @@ -179,13 +179,14 @@ Inductive step: state -> trace -> state -> Prop := E0 (Callstate (Stackframe fb sp (Vptr fb ra) c :: s) f' rs m) | exec_Mtailcall: - forall s fb stk soff sig ros c rs m f f', + forall s fb stk soff sig ros c rs m f f' m', find_function_ptr ge ros rs = Some f' -> Genv.find_funct_ptr ge fb = Some (Internal f) -> load_stack m (Vptr stk soff) Tint f.(fn_link_ofs) = Some (parent_sp s) -> load_stack m (Vptr stk soff) Tint f.(fn_retaddr_ofs) = Some (parent_ra s) -> + Mem.free m stk (- f.(fn_framesize)) f.(fn_stacksize) = Some m' -> step (State s fb (Vptr stk soff) (Mtailcall sig ros :: c) rs m) - E0 (Callstate s f' rs (Mem.free m stk)) + E0 (Callstate s f' rs m') | exec_Mgoto: forall s fb f sp lbl c rs m c', Genv.find_funct_ptr ge fb = Some (Internal f) -> @@ -213,12 +214,13 @@ Inductive step: state -> trace -> state -> Prop := step (State s fb sp (Mjumptable arg tbl :: c) rs m) E0 (State s fb sp c' rs m) | exec_Mreturn: - forall s fb stk soff c rs m f, + forall s fb stk soff c rs m f m', Genv.find_funct_ptr ge fb = Some (Internal f) -> load_stack m (Vptr stk soff) Tint f.(fn_link_ofs) = Some (parent_sp s) -> load_stack m (Vptr stk soff) Tint f.(fn_retaddr_ofs) = Some (parent_ra s) -> + Mem.free m stk (- f.(fn_framesize)) f.(fn_stacksize) = Some m' -> step (State s fb (Vptr stk soff) (Mreturn :: c) rs m) - E0 (Returnstate s rs (Mem.free m stk)) + E0 (Returnstate s rs m') | exec_function_internal: forall s fb rs m f m1 m2 m3 stk, Genv.find_funct_ptr ge fb = Some (Internal f) -> @@ -229,13 +231,13 @@ Inductive step: state -> trace -> state -> Prop := step (Callstate s fb rs m) E0 (State s fb sp f.(fn_code) rs m3) | exec_function_external: - forall s fb rs m t rs' ef args res, + forall s fb rs m t rs' ef args res m', Genv.find_funct_ptr ge fb = Some (External ef) -> - event_match ef args t res -> + external_call ef args m t res m' -> extcall_arguments rs m (parent_sp s) ef.(ef_sig) args -> rs' = (rs#(Conventions.loc_result ef.(ef_sig)) <- res) -> step (Callstate s fb rs m) - t (Returnstate s rs' m) + t (Returnstate s rs' m') | exec_return: forall s f sp ra c rs m, step (Returnstate (Stackframe f sp ra c :: s) rs m) @@ -244,9 +246,9 @@ Inductive step: state -> trace -> state -> Prop := End RELSEM. Inductive initial_state (p: program): state -> Prop := - | initial_state_intro: forall fb, + | initial_state_intro: forall fb m0, let ge := Genv.globalenv p in - let m0 := Genv.init_mem p in + Genv.init_mem p = Some m0 -> Genv.find_symbol ge p.(prog_main) = Some fb -> initial_state p (Callstate nil fb (Regmap.init Vundef) m0). diff --git a/backend/Machtyping.v b/backend/Machtyping.v index 8b40001..c2e797a 100644 --- a/backend/Machtyping.v +++ b/backend/Machtyping.v @@ -15,10 +15,10 @@ Require Import Coqlib. Require Import Maps. Require Import AST. -Require Import Mem. +Require Import Memory. Require Import Integers. Require Import Values. -Require Import Mem. +Require Import Memory. Require Import Events. Require Import Globalenvs. Require Import Op. @@ -194,14 +194,6 @@ Proof. constructor; auto. Qed. -Lemma wt_event_match: - forall ef args t res, - event_match ef args t res -> - Val.has_type res (proj_sig_res ef.(ef_sig)). -Proof. - induction 1. inversion H0; exact I. -Qed. - Section SUBJECT_REDUCTION. Inductive wt_stackframe: stackframe -> Prop := @@ -259,7 +251,7 @@ Proof. simpl in H. rewrite <- H2. replace v with (rs r1). apply WTRS. congruence. replace (mreg_type res) with (snd (type_of_operation op)). - apply type_of_operation_sound with fundef ge rs##args sp; auto. + apply type_of_operation_sound with fundef unit ge rs##args sp; auto. rewrite <- H5; reflexivity. apply wt_setreg; auto. inversion H1. rewrite H7. @@ -267,18 +259,18 @@ Proof. assert (WTFD: wt_fundef f'). destruct ros; simpl in H. - apply (Genv.find_funct_prop wt_fundef wt_p H). + apply (Genv.find_funct_prop wt_fundef _ _ wt_p H). destruct (Genv.find_symbol ge i); try discriminate. - apply (Genv.find_funct_ptr_prop wt_fundef wt_p H). + apply (Genv.find_funct_ptr_prop wt_fundef _ _ wt_p H). econstructor; eauto. intros. elim H0; intro. subst s0. econstructor; eauto with coqlib. auto. assert (WTFD: wt_fundef f'). destruct ros; simpl in H. - apply (Genv.find_funct_prop wt_fundef wt_p H). + apply (Genv.find_funct_prop wt_fundef _ _ wt_p H). destruct (Genv.find_symbol ge i); try discriminate. - apply (Genv.find_funct_ptr_prop wt_fundef wt_p H). + apply (Genv.find_funct_ptr_prop wt_fundef _ _ wt_p H). econstructor; eauto. (* apply wt_setreg; auto. exact I. *) @@ -293,7 +285,7 @@ Proof. apply wt_empty_frame. econstructor; eauto. apply wt_setreg; auto. - generalize (wt_event_match _ _ _ _ H). + generalize (external_call_well_typed _ _ _ _ _ _ H). unfold proj_sig_res, Conventions.loc_result. destruct (sig_res (ef_sig ef)). destruct t0; simpl; auto. diff --git a/backend/RTL.v b/backend/RTL.v index b2ee80f..c5d4d7d 100644 --- a/backend/RTL.v +++ b/backend/RTL.v @@ -22,7 +22,7 @@ Require Import AST. Require Import Integers. Require Import Values. Require Import Events. -Require Import Mem. +Require Import Memory. Require Import Globalenvs. Require Import Smallstep. Require Import Op. @@ -115,7 +115,7 @@ Definition funsig (fd: fundef) := (** * Operational semantics *) -Definition genv := Genv.t fundef. +Definition genv := Genv.t fundef unit. Definition regset := Regmap.t val. Fixpoint init_regs (vl: list val) (rl: list reg) {struct rl} : regset := @@ -128,8 +128,8 @@ Fixpoint init_regs (vl: list val) (rl: list reg) {struct rl} : regset := set of transitions between states. A state captures the current point in the execution. Three kinds of states appear in the transitions: -- [State cs c sp pc rs m] describes an execution point within a function. - [c] is the code for the current function (a CFG). +- [State cs f sp pc rs m] describes an execution point within a function. + [f] is the current function. [sp] is the pointer to the stack block for its current activation (as in Cminor). [pc] is the current program point (CFG node) within the code [c]. @@ -145,10 +145,10 @@ Fixpoint init_regs (vl: list val) (rl: list reg) {struct rl} : regset := [v] is the return value and [m] the current memory state. In all three kinds of states, the [cs] parameter represents the call stack. -It is a list of frames [Stackframe res c sp pc rs]. Each frame represents +It is a list of frames [Stackframe res f sp pc rs]. Each frame represents a function call in progress. [res] is the pseudo-register that will receive the result of the call. -[c] is the code of the calling function. +[f] is the calling function. [sp] is its stack pointer. [pc] is the program point for the instruction that follows the call. [rs] is the state of registers in the calling function. @@ -157,7 +157,7 @@ a function call in progress. Inductive stackframe : Type := | Stackframe: forall (res: reg) (**r where to store the result *) - (c: code) (**r code of calling function *) + (f: function) (**r calling function *) (sp: val) (**r stack pointer in calling function *) (pc: node) (**r program point in calling function *) (rs: regset), (**r register state in calling function *) @@ -166,7 +166,7 @@ Inductive stackframe : Type := Inductive state : Type := | State: forall (stack: list stackframe) (**r call stack *) - (c: code) (**r current code *) + (f: function) (**r current function *) (sp: val) (**r stack pointer *) (pc: node) (**r current program point in [c] *) (rs: regset) (**r register state *) @@ -206,107 +206,109 @@ Definition find_function Inductive step: state -> trace -> state -> Prop := | exec_Inop: - forall s c sp pc rs m pc', - c!pc = Some(Inop pc') -> - step (State s c sp pc rs m) - E0 (State s c sp pc' rs m) + forall s f sp pc rs m pc', + (fn_code f)!pc = Some(Inop pc') -> + step (State s f sp pc rs m) + E0 (State s f sp pc' rs m) | exec_Iop: - forall s c sp pc rs m op args res pc' v, - c!pc = Some(Iop op args res pc') -> + forall s f sp pc rs m op args res pc' v, + (fn_code f)!pc = Some(Iop op args res pc') -> eval_operation ge sp op rs##args = Some v -> - step (State s c sp pc rs m) - E0 (State s c sp pc' (rs#res <- v) m) + step (State s f sp pc rs m) + E0 (State s f sp pc' (rs#res <- v) m) | exec_Iload: - forall s c sp pc rs m chunk addr args dst pc' a v, - c!pc = Some(Iload chunk addr args dst pc') -> + forall s f sp pc rs m chunk addr args dst pc' a v, + (fn_code f)!pc = Some(Iload chunk addr args dst pc') -> eval_addressing ge sp addr rs##args = Some a -> Mem.loadv chunk m a = Some v -> - step (State s c sp pc rs m) - E0 (State s c sp pc' (rs#dst <- v) m) + step (State s f sp pc rs m) + E0 (State s f sp pc' (rs#dst <- v) m) | exec_Istore: - forall s c sp pc rs m chunk addr args src pc' a m', - c!pc = Some(Istore chunk addr args src pc') -> + forall s f sp pc rs m chunk addr args src pc' a m', + (fn_code f)!pc = Some(Istore chunk addr args src pc') -> eval_addressing ge sp addr rs##args = Some a -> Mem.storev chunk m a rs#src = Some m' -> - step (State s c sp pc rs m) - E0 (State s c sp pc' rs m') + step (State s f sp pc rs m) + E0 (State s f sp pc' rs m') | exec_Icall: - forall s c sp pc rs m sig ros args res pc' f, - c!pc = Some(Icall sig ros args res pc') -> - find_function ros rs = Some f -> - funsig f = sig -> - step (State s c sp pc rs m) - E0 (Callstate (Stackframe res c sp pc' rs :: s) f rs##args m) + forall s f sp pc rs m sig ros args res pc' fd, + (fn_code f)!pc = Some(Icall sig ros args res pc') -> + find_function ros rs = Some fd -> + funsig fd = sig -> + step (State s f sp pc rs m) + E0 (Callstate (Stackframe res f sp pc' rs :: s) fd rs##args m) | exec_Itailcall: - forall s c stk pc rs m sig ros args f, - c!pc = Some(Itailcall sig ros args) -> - find_function ros rs = Some f -> - funsig f = sig -> - step (State s c (Vptr stk Int.zero) pc rs m) - E0 (Callstate s f rs##args (Mem.free m stk)) + forall s f stk pc rs m sig ros args fd m', + (fn_code f)!pc = Some(Itailcall sig ros args) -> + find_function ros rs = Some fd -> + funsig fd = sig -> + Mem.free m stk 0 f.(fn_stacksize) = Some m' -> + step (State s f (Vptr stk Int.zero) pc rs m) + E0 (Callstate s fd rs##args m') | exec_Icond_true: - forall s c sp pc rs m cond args ifso ifnot, - c!pc = Some(Icond cond args ifso ifnot) -> + forall s f sp pc rs m cond args ifso ifnot, + (fn_code f)!pc = Some(Icond cond args ifso ifnot) -> eval_condition cond rs##args = Some true -> - step (State s c sp pc rs m) - E0 (State s c sp ifso rs m) + step (State s f sp pc rs m) + E0 (State s f sp ifso rs m) | exec_Icond_false: - forall s c sp pc rs m cond args ifso ifnot, - c!pc = Some(Icond cond args ifso ifnot) -> + forall s f sp pc rs m cond args ifso ifnot, + (fn_code f)!pc = Some(Icond cond args ifso ifnot) -> eval_condition cond rs##args = Some false -> - step (State s c sp pc rs m) - E0 (State s c sp ifnot rs m) + step (State s f sp pc rs m) + E0 (State s f sp ifnot rs m) | exec_Ijumptable: - forall s c sp pc rs m arg tbl n pc', - c!pc = Some(Ijumptable arg tbl) -> + forall s f sp pc rs m arg tbl n pc', + (fn_code f)!pc = Some(Ijumptable arg tbl) -> rs#arg = Vint n -> list_nth_z tbl (Int.signed n) = Some pc' -> - step (State s c sp pc rs m) - E0 (State s c sp pc' rs m) + step (State s f sp pc rs m) + E0 (State s f sp pc' rs m) | exec_Ireturn: - forall s c stk pc rs m or, - c!pc = Some(Ireturn or) -> - step (State s c (Vptr stk Int.zero) pc rs m) - E0 (Returnstate s (regmap_optget or Vundef rs) (Mem.free m stk)) + forall s f stk pc rs m or m', + (fn_code f)!pc = Some(Ireturn or) -> + Mem.free m stk 0 f.(fn_stacksize) = Some m' -> + step (State s f (Vptr stk Int.zero) pc rs m) + E0 (Returnstate s (regmap_optget or Vundef rs) m') | exec_function_internal: forall s f args m m' stk, Mem.alloc m 0 f.(fn_stacksize) = (m', stk) -> step (Callstate s (Internal f) args m) E0 (State s - f.(fn_code) + f (Vptr stk Int.zero) f.(fn_entrypoint) (init_regs args f.(fn_params)) m') | exec_function_external: - forall s ef args res t m, - event_match ef args t res -> + forall s ef args res t m m', + external_call ef args m t res m' -> step (Callstate s (External ef) args m) - t (Returnstate s res m) + t (Returnstate s res m') | exec_return: - forall res c sp pc rs s vres m, - step (Returnstate (Stackframe res c sp pc rs :: s) vres m) - E0 (State s c sp pc (rs#res <- vres) m). + forall res f sp pc rs s vres m, + step (Returnstate (Stackframe res f sp pc rs :: s) vres m) + E0 (State s f sp pc (rs#res <- vres) m). Lemma exec_Iop': - forall s c sp pc rs m op args res pc' rs' v, - c!pc = Some(Iop op args res pc') -> + forall s f sp pc rs m op args res pc' rs' v, + (fn_code f)!pc = Some(Iop op args res pc') -> eval_operation ge sp op rs##args = Some v -> rs' = (rs#res <- v) -> - step (State s c sp pc rs m) - E0 (State s c sp pc' rs' m). + step (State s f sp pc rs m) + E0 (State s f sp pc' rs' m). Proof. intros. subst rs'. eapply exec_Iop; eauto. Qed. Lemma exec_Iload': - forall s c sp pc rs m chunk addr args dst pc' rs' a v, - c!pc = Some(Iload chunk addr args dst pc') -> + forall s f sp pc rs m chunk addr args dst pc' rs' a v, + (fn_code f)!pc = Some(Iload chunk addr args dst pc') -> eval_addressing ge sp addr rs##args = Some a -> Mem.loadv chunk m a = Some v -> rs' = (rs#dst <- v) -> - step (State s c sp pc rs m) - E0 (State s c sp pc' rs' m). + step (State s f sp pc rs m) + E0 (State s f sp pc' rs' m). Proof. intros. subst rs'. eapply exec_Iload; eauto. Qed. @@ -319,9 +321,9 @@ End RELSEM. without arguments and with an empty call stack. *) Inductive initial_state (p: program): state -> Prop := - | initial_state_intro: forall b f, + | initial_state_intro: forall b f m0, let ge := Genv.globalenv p in - let m0 := Genv.init_mem p in + Genv.init_mem p = Some m0 -> Genv.find_symbol ge p.(prog_main) = Some b -> Genv.find_funct_ptr ge b = Some f -> funsig f = mksignature nil (Some Tint) -> diff --git a/backend/RTLgenproof.v b/backend/RTLgenproof.v index d07bd08..f4d1342 100644 --- a/backend/RTLgenproof.v +++ b/backend/RTLgenproof.v @@ -17,7 +17,7 @@ Require Import Maps. Require Import AST. Require Import Integers. Require Import Values. -Require Import Mem. +Require Import Memory. Require Import Events. Require Import Smallstep. Require Import Globalenvs. @@ -337,7 +337,7 @@ Lemma function_ptr_translated: exists tf, Genv.find_funct_ptr tge b = Some tf /\ transl_fundef f = OK tf. Proof - (Genv.find_funct_ptr_transf_partial transl_fundef TRANSL). + (Genv.find_funct_ptr_transf_partial transl_fundef _ TRANSL). Lemma functions_translated: forall (v: val) (f: CminorSel.fundef), @@ -345,7 +345,7 @@ Lemma functions_translated: exists tf, Genv.find_funct tge v = Some tf /\ transl_fundef f = OK tf. Proof - (Genv.find_funct_transf_partial transl_fundef TRANSL). + (Genv.find_funct_transf_partial transl_fundef _ TRANSL). Lemma sig_transl_function: forall (f: CminorSel.fundef) (tf: RTL.fundef), @@ -365,10 +365,10 @@ Qed. (** Correctness of the code generated by [add_move]. *) Lemma tr_move_correct: - forall r1 ns r2 nd cs code sp rs m, - tr_move code ns r1 nd r2 -> + forall r1 ns r2 nd cs f sp rs m, + tr_move f.(fn_code) ns r1 nd r2 -> exists rs', - star step tge (State cs code sp ns rs m) E0 (State cs code sp nd rs' m) /\ + star step tge (State cs f sp ns rs m) E0 (State cs f sp nd rs' m) /\ rs'#r2 = rs#r1 /\ (forall r, r <> r2 -> rs'#r = rs#r). Proof. @@ -382,13 +382,13 @@ Qed. (** Correctness of the code generated by [store_var] and [store_optvar]. *) Lemma tr_store_var_correct: - forall rs cs code map r id ns nd e sp m, - tr_store_var code map r id ns nd -> + forall rs cs f map r id ns nd e sp m, + tr_store_var f.(fn_code) map r id ns nd -> map_wf map -> match_env map e nil rs -> exists rs', - star step tge (State cs code sp ns rs m) - E0 (State cs code sp nd rs' m) + star step tge (State cs f sp ns rs m) + E0 (State cs f sp nd rs' m) /\ match_env map (PTree.set id rs#r e) nil rs'. Proof. intros. destruct H as [rv [A B]]. @@ -402,13 +402,13 @@ Proof. Qed. Lemma tr_store_optvar_correct: - forall rs cs code map r optid ns nd e sp m, - tr_store_optvar code map r optid ns nd -> + forall rs cs f map r optid ns nd e sp m, + tr_store_optvar f.(fn_code) map r optid ns nd -> map_wf map -> match_env map e nil rs -> exists rs', - star step tge (State cs code sp ns rs m) - E0 (State cs code sp nd rs' m) + star step tge (State cs f sp ns rs m) + E0 (State cs f sp nd rs' m) /\ match_env map (set_optvar optid rs#r e) nil rs'. Proof. intros. destruct optid; simpl in *. @@ -419,15 +419,15 @@ Qed. (** Correctness of the translation of [switch] statements *) Lemma transl_switch_correct: - forall cs sp e m code map r nexits t ns, - tr_switch code map r nexits t ns -> + forall cs sp e m f map r nexits t ns, + tr_switch f.(fn_code) map r nexits t ns -> forall rs i act, rs#r = Vint i -> map_wf map -> match_env map e nil rs -> comptree_match i t = Some act -> exists nd, exists rs', - star step tge (State cs code sp ns rs m) E0 (State cs code sp nd rs' m) /\ + star step tge (State cs f sp ns rs m) E0 (State cs f sp nd rs' m) /\ nth_error nexits act = Some nd /\ match_env map e nil rs'. Proof. @@ -458,7 +458,7 @@ Proof. set (rs1 := rs#rt <- (Vint(Int.sub i ofs))). assert (ME1: match_env map e nil rs1). unfold rs1. eauto with rtlg. - assert (EX1: step tge (State cs code sp n rs m) E0 (State cs code sp n1 rs1 m)). + assert (EX1: step tge (State cs f sp n rs m) E0 (State cs f sp n1 rs1 m)). eapply exec_Iop; eauto. predSpec Int.eq Int.eq_spec ofs Int.zero; simpl. rewrite H10. rewrite Int.sub_zero_l. congruence. @@ -521,12 +521,12 @@ Variable m: mem. Definition transl_expr_prop (le: letenv) (a: expr) (v: val) : Prop := - forall cs code map pr ns nd rd rs + forall cs f map pr ns nd rd rs (MWF: map_wf map) - (TE: tr_expr code map pr a ns nd rd) + (TE: tr_expr f.(fn_code) map pr a ns nd rd) (ME: match_env map e le rs), exists rs', - star step tge (State cs code sp ns rs m) E0 (State cs code sp nd rs' m) + star step tge (State cs f sp ns rs m) E0 (State cs f sp nd rs' m) /\ match_env map e le rs' /\ rs'#rd = v /\ (forall r, reg_in_map map r \/ In r pr -> rs'#r = rs#r). @@ -536,25 +536,25 @@ Definition transl_expr_prop Definition transl_exprlist_prop (le: letenv) (al: exprlist) (vl: list val) : Prop := - forall cs code map pr ns nd rl rs + forall cs f map pr ns nd rl rs (MWF: map_wf map) - (TE: tr_exprlist code map pr al ns nd rl) + (TE: tr_exprlist f.(fn_code) map pr al ns nd rl) (ME: match_env map e le rs), exists rs', - star step tge (State cs code sp ns rs m) E0 (State cs code sp nd rs' m) + star step tge (State cs f sp ns rs m) E0 (State cs f sp nd rs' m) /\ match_env map e le rs' /\ rs'##rl = vl /\ (forall r, reg_in_map map r \/ In r pr -> rs'#r = rs#r). Definition transl_condition_prop (le: letenv) (a: condexpr) (vb: bool) : Prop := - forall cs code map pr ns ntrue nfalse rs + forall cs f map pr ns ntrue nfalse rs (MWF: map_wf map) - (TE: tr_condition code map pr a ns ntrue nfalse) + (TE: tr_condition f.(fn_code) map pr a ns ntrue nfalse) (ME: match_env map e le rs), exists rs', - star step tge (State cs code sp ns rs m) E0 - (State cs code sp (if vb then ntrue else nfalse) rs' m) + star step tge (State cs f sp ns rs m) E0 + (State cs f sp (if vb then ntrue else nfalse) rs' m) /\ match_env map e le rs' /\ (forall r, reg_in_map map r \/ In r pr -> rs'#r = rs#r). @@ -604,7 +604,7 @@ Proof. split. eapply star_right. eexact EX1. eapply exec_Iop; eauto. subst vargs. - rewrite (@eval_operation_preserved CminorSel.fundef RTL.fundef ge tge). + rewrite (@eval_operation_preserved CminorSel.fundef _ _ _ ge tge). auto. exact symbols_preserved. traceEq. (* Match-env *) @@ -621,7 +621,7 @@ Lemma transl_expr_Eload_correct: eval_exprlist ge sp e m le args vargs -> transl_exprlist_prop le args vargs -> Op.eval_addressing ge sp addr vargs = Some vaddr -> - loadv chunk m vaddr = Some v -> + Mem.loadv chunk m vaddr = Some v -> transl_expr_prop le (Eload chunk addr args) v. Proof. intros; red; intros. inv TE. @@ -629,7 +629,7 @@ Proof. exists (rs1#rd <- v). (* Exec *) split. eapply star_right. eexact EX1. eapply exec_Iload; eauto. - rewrite RES1. rewrite (@eval_addressing_preserved _ _ ge tge). + rewrite RES1. rewrite (@eval_addressing_preserved _ _ _ _ ge tge). exact H1. exact symbols_preserved. traceEq. (* Match-env *) split. eauto with rtlg. @@ -650,7 +650,7 @@ Lemma transl_expr_Econdition_correct: Proof. intros; red; intros; inv TE. exploit H0; eauto. intros [rs1 [EX1 [ME1 OTHER1]]]. - assert (tr_expr code map pr (if vcond then ifso else ifnot) (if vcond then ntrue else nfalse) nd rd). + assert (tr_expr f.(fn_code) map pr (if vcond then ifso else ifnot) (if vcond then ntrue else nfalse) nd rd). destruct vcond; auto. exploit H2; eauto. intros [rs2 [EX2 [ME2 [RES2 OTHER2]]]]. exists rs2. @@ -767,7 +767,7 @@ Lemma transl_condition_CEcondition_correct: Proof. intros; red; intros; inv TE. exploit H0; eauto. intros [rs1 [EX1 [ME1 OTHER1]]]. - assert (tr_condition code map pr (if vcond then ifso else ifnot) + assert (tr_condition f.(fn_code) map pr (if vcond then ifso else ifnot) (if vcond then ntrue' else nfalse') ntrue nfalse). destruct vcond; auto. exploit H2; eauto. intros [rs2 [EX2 [ME2 OTHER2]]]. @@ -977,12 +977,13 @@ Qed. *) -Inductive tr_funbody (c: code) (map: mapping) (f: CminorSel.function) +Inductive tr_fun (tf: function) (map: mapping) (f: CminorSel.function) (ngoto: labelmap) (nret: node) (rret: option reg) : Prop := - | tr_funbody_intro: forall nentry r, + | tr_fun_intro: forall nentry r, rret = ret_reg f.(CminorSel.fn_sig) r -> - tr_stmt c map f.(fn_body) nentry nret nil ngoto nret rret -> - tr_funbody c map f ngoto nret rret. + tr_stmt tf.(fn_code) map f.(fn_body) nentry nret nil ngoto nret rret -> + tf.(fn_stacksize) = f.(fn_stackspace) -> + tr_fun tf map f ngoto nret rret. Inductive tr_cont: RTL.code -> mapping -> CminorSel.cont -> node -> list node -> labelmap -> node -> option reg -> @@ -1006,25 +1007,25 @@ Inductive tr_cont: RTL.code -> mapping -> with match_stacks: CminorSel.cont -> list RTL.stackframe -> Prop := | match_stacks_stop: match_stacks Kstop nil - | match_stacks_call: forall optid f sp e k r c n rs cs map nexits ngoto nret rret n', + | match_stacks_call: forall optid f sp e k r tf n rs cs map nexits ngoto nret rret n', map_wf map -> - tr_funbody c map f ngoto nret rret -> + tr_fun tf map f ngoto nret rret -> match_env map e nil rs -> - tr_store_optvar c map r optid n n' -> + tr_store_optvar tf.(fn_code) map r optid n n' -> ~reg_in_map map r -> - tr_cont c map k n' nexits ngoto nret rret cs -> - match_stacks (Kcall optid f sp e k) (Stackframe r c sp n rs :: cs). + tr_cont tf.(fn_code) map k n' nexits ngoto nret rret cs -> + match_stacks (Kcall optid f sp e k) (Stackframe r tf sp n rs :: cs). Inductive match_states: CminorSel.state -> RTL.state -> Prop := | match_state: - forall f s k sp e m cs c ns rs map ncont nexits ngoto nret rret + forall f s k sp e m cs tf ns rs map ncont nexits ngoto nret rret (MWF: map_wf map) - (TS: tr_stmt c map s ns ncont nexits ngoto nret rret) - (TF: tr_funbody c map f ngoto nret rret) - (TK: tr_cont c map k ncont nexits ngoto nret rret cs) + (TS: tr_stmt tf.(fn_code) map s ns ncont nexits ngoto nret rret) + (TF: tr_fun tf map f ngoto nret rret) + (TK: tr_cont tf.(fn_code) map k ncont nexits ngoto nret rret cs) (ME: match_env map e nil rs), match_states (CminorSel.State f s k sp e m) - (RTL.State cs c sp ns rs m) + (RTL.State cs tf sp ns rs m) | match_callstate: forall f args k m cs tf (TF: transl_fundef f = OK tf) @@ -1109,15 +1110,19 @@ Proof. (* skip return *) inv TS. - assert (c!ncont = Some(Ireturn rret) /\ match_stacks k cs). - inv TK; simpl in H; try contradiction; auto. - destruct H1. + assert ((fn_code tf)!ncont = Some(Ireturn rret) + /\ match_stacks k cs). + inv TK; simpl in H; try contradiction; auto. + destruct H2. assert (rret = None). inv TF. unfold ret_reg. rewrite H0. auto. + assert (fn_stacksize tf = fn_stackspace f). + inv TF. auto. subst rret. econstructor; split. left; apply plus_one. eapply exec_Ireturn. eauto. - simpl. constructor; auto. + rewrite H5. eauto. + constructor; auto. (* assign *) inv TS. @@ -1152,7 +1157,7 @@ Proof. intros [rs' [A [B [C D]]]]. exploit transl_exprlist_correct; eauto. intros [rs'' [E [F [G J]]]]. - exploit functions_translated; eauto. intros [tf [P Q]]. + exploit functions_translated; eauto. intros [tf' [P Q]]. econstructor; split. left; eapply plus_right. eapply star_trans. eexact A. eexact E. reflexivity. eapply exec_Icall; eauto. simpl. rewrite J. rewrite C. eauto. simpl; auto. @@ -1166,12 +1171,14 @@ Proof. intros [rs' [A [B [C D]]]]. exploit transl_exprlist_correct; eauto. intros [rs'' [E [F [G J]]]]. - exploit functions_translated; eauto. intros [tf [P Q]]. + exploit functions_translated; eauto. intros [tf' [P Q]]. exploit match_stacks_call_cont; eauto. intros [U V]. + assert (fn_stacksize tf = fn_stackspace f). inv TF; auto. econstructor; split. left; eapply plus_right. eapply star_trans. eexact A. eexact E. reflexivity. eapply exec_Itailcall; eauto. simpl. rewrite J. rewrite C. eauto. simpl; auto. apply sig_transl_function; auto. + rewrite H2; eauto. traceEq. rewrite G. constructor; auto. (* seq *) @@ -1234,17 +1241,21 @@ Proof. (* return none *) inv TS. exploit match_stacks_call_cont; eauto. intros [U V]. + inversion TF. econstructor; split. left; apply plus_one. eapply exec_Ireturn; eauto. - simpl. constructor; auto. + rewrite H2; eauto. + constructor; auto. (* return some *) inv TS. exploit transl_expr_correct; eauto. intros [rs' [A [B [C D]]]]. - exploit match_stacks_call_cont; eauto. intros [U V]. + exploit match_stacks_call_cont; eauto. intros [U V]. + inversion TF. econstructor; split. - left; eapply plus_right. eexact A. eapply exec_Ireturn; eauto. traceEq. + left; eapply plus_right. eexact A. eapply exec_Ireturn; eauto. + rewrite H4; eauto. traceEq. simpl. rewrite C. constructor; auto. (* label *) @@ -1301,11 +1312,12 @@ Proof. induction 1. exploit function_ptr_translated; eauto. intros [tf [A B]]. econstructor; split. - econstructor. rewrite (transform_partial_program_main _ _ TRANSL). fold tge. - rewrite symbols_preserved. eexact H. + econstructor. apply (Genv.init_mem_transf_partial _ _ TRANSL); eauto. + rewrite (transform_partial_program_main _ _ TRANSL). fold tge. + rewrite symbols_preserved. eauto. eexact A. - rewrite <- H1. apply sig_transl_function; auto. - rewrite (Genv.init_mem_transf_partial _ _ TRANSL). constructor. auto. constructor. + rewrite <- H2. apply sig_transl_function; auto. + constructor. auto. constructor. Qed. Lemma transl_final_states: diff --git a/backend/RTLgenspec.v b/backend/RTLgenspec.v index 037eb3f..51fb945 100644 --- a/backend/RTLgenspec.v +++ b/backend/RTLgenspec.v @@ -27,7 +27,7 @@ Require Import AST. Require Import Integers. Require Import Values. Require Import Events. -Require Import Mem. +Require Import Memory. Require Import Globalenvs. Require Import Switch. Require Import Op. diff --git a/backend/RTLtyping.v b/backend/RTLtyping.v index d8e2f21..68f38c0 100644 --- a/backend/RTLtyping.v +++ b/backend/RTLtyping.v @@ -20,7 +20,7 @@ Require Import Op. Require Import Registers. Require Import Globalenvs. Require Import Values. -Require Import Mem. +Require Import Memory. Require Import Integers. Require Import Events. Require Import Smallstep. @@ -454,14 +454,6 @@ Proof. apply wt_regset_assign; auto. Qed. -Lemma wt_event_match: - forall ef args t res, - event_match ef args t res -> - Val.has_type res (proj_sig_res ef.(ef_sig)). -Proof. - induction 1. inversion H0; exact I. -Qed. - Inductive wt_stackframes: list stackframe -> option typ -> Prop := | wt_stackframes_nil: wt_stackframes nil (Some Tint) @@ -471,7 +463,7 @@ Inductive wt_stackframes: list stackframe -> option typ -> Prop := wt_regset env rs -> env res = match tyres with None => Tint | Some t => t end -> wt_stackframes s (sig_res (fn_sig f)) -> - wt_stackframes (Stackframe res (fn_code f) sp pc rs :: s) tyres. + wt_stackframes (Stackframe res f sp pc rs :: s) tyres. Inductive wt_state: state -> Prop := | wt_state_intro: @@ -479,7 +471,7 @@ Inductive wt_state: state -> Prop := (WT_STK: wt_stackframes s (sig_res (fn_sig f))) (WT_FN: wt_function f env) (WT_RS: wt_regset env rs), - wt_state (State s (fn_code f) sp pc rs m) + wt_state (State s f sp pc rs m) | wt_state_call: forall s f args m, wt_stackframes s (sig_res (funsig f)) -> @@ -517,7 +509,7 @@ Proof. econstructor; eauto. apply wt_regset_assign. auto. replace (env res) with (snd (type_of_operation op)). - apply type_of_operation_sound with fundef ge rs##args sp; auto. + apply type_of_operation_sound with fundef unit ge rs##args sp; auto. rewrite <- H6. reflexivity. (* Iload *) econstructor; eauto. @@ -526,29 +518,29 @@ Proof. (* Istore *) econstructor; eauto. (* Icall *) - assert (wt_fundef f). + assert (wt_fundef fd). destruct ros; simpl in H0. - pattern f. apply Genv.find_funct_prop with fundef unit p (rs#r). + pattern fd. apply Genv.find_funct_prop with fundef unit p (rs#r). exact wt_p. exact H0. caseEq (Genv.find_symbol ge i); intros; rewrite H1 in H0. - pattern f. apply Genv.find_funct_ptr_prop with fundef unit p b. + pattern fd. apply Genv.find_funct_ptr_prop with fundef unit p b. exact wt_p. exact H0. discriminate. econstructor; eauto. econstructor; eauto. rewrite <- H7. apply wt_regset_list. auto. (* Itailcall *) - assert (wt_fundef f). + assert (wt_fundef fd). destruct ros; simpl in H0. - pattern f. apply Genv.find_funct_prop with fundef unit p (rs#r). + pattern fd. apply Genv.find_funct_prop with fundef unit p (rs#r). exact wt_p. exact H0. caseEq (Genv.find_symbol ge i); intros; rewrite H1 in H0. - pattern f. apply Genv.find_funct_ptr_prop with fundef unit p b. + pattern fd. apply Genv.find_funct_ptr_prop with fundef unit p b. exact wt_p. exact H0. discriminate. econstructor; eauto. - rewrite H5; auto. - rewrite <- H6. apply wt_regset_list. auto. + rewrite H6; auto. + rewrite <- H7. apply wt_regset_list. auto. (* Icond *) econstructor; eauto. econstructor; eauto. @@ -557,7 +549,7 @@ Proof. (* Ireturn *) econstructor; eauto. destruct or; simpl in *. - rewrite <- H1. apply WT_RS. exact I. + rewrite <- H2. apply WT_RS. exact I. (* internal function *) simpl in *. inv H5. inversion H1; subst. econstructor; eauto. @@ -566,7 +558,7 @@ Proof. simpl in *. inv H5. econstructor; eauto. change (Val.has_type res (proj_sig_res (ef_sig ef))). - eapply wt_event_match; eauto. + eapply external_call_well_typed; eauto. (* return *) inv H1. econstructor; eauto. apply wt_regset_assign; auto. congruence. diff --git a/backend/RTLtypingaux.ml b/backend/RTLtypingaux.ml index 406ca07..868fb8d 100644 --- a/backend/RTLtypingaux.ml +++ b/backend/RTLtypingaux.ml @@ -16,6 +16,7 @@ open Datatypes open Camlcoq open Maps open AST +open Memdata open Op open Registers open RTL diff --git a/backend/Reloadproof.v b/backend/Reloadproof.v index 21d5f38..7d73011 100644 --- a/backend/Reloadproof.v +++ b/backend/Reloadproof.v @@ -17,7 +17,7 @@ Require Import Maps. Require Import AST. Require Import Integers. Require Import Values. -Require Import Mem. +Require Import Memory. Require Import Events. Require Import Globalenvs. Require Import Smallstep. @@ -875,7 +875,7 @@ Inductive match_states: LTLin.state -> Linear.state -> Prop := (AG: agree rs ls) (WT: wt_function f) (TL: is_tail c (LTLin.fn_code f)) - (MMD: Mem.lessdef m tm), + (MMD: Mem.extends m tm), match_states (LTLin.State s f sp c rs m) (Linear.State s' (transf_function f) sp (transf_code f c) ls tm) | match_states_call: @@ -885,7 +885,7 @@ Inductive match_states: LTLin.state -> Linear.state -> Prop := (PRES: forall l, ~In l temporaries -> ~In l destroyed_at_call -> ls l = parent_locset s' l) (WT: wt_fundef f) - (MMD: Mem.lessdef m tm), + (MMD: Mem.extends m tm), match_states (LTLin.Callstate s f args m) (Linear.Callstate s' (transf_fundef f) ls tm) | match_states_return: @@ -894,7 +894,7 @@ Inductive match_states: LTLin.state -> Linear.state -> Prop := (AG: Val.lessdef res (ls (R (Conventions.loc_result sig)))) (PRES: forall l, ~In l temporaries -> ~In l destroyed_at_call -> ls l = parent_locset s' l) - (MMD: Mem.lessdef m tm), + (MMD: Mem.extends m tm), match_states (LTLin.Returnstate s res m) (Linear.Returnstate s' ls tm). @@ -1006,8 +1006,7 @@ Proof. rewrite B. eapply agree_locs; eauto. rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. destruct H1 as [ta [P Q]]. - exploit Mem.loadv_lessdef; eauto. - intros [tv [R S]]. + exploit Mem.loadv_extends; eauto. intros [tv [R S]]. exploit add_spill_correct. intros [ls3 [D [E F]]]. left; econstructor; split. @@ -1038,7 +1037,7 @@ Proof. destruct H1 as [ta [P Q]]. assert (X: Val.lessdef (rs src) (ls2 (R rsrc))). rewrite E. eapply agree_loc; eauto. - exploit Mem.storev_lessdef. eexact MMD. eexact Q. eexact X. eauto. + exploit Mem.storev_extends. eexact MMD. eauto. eexact Q. eexact X. intros [tm2 [Y Z]]. left; econstructor; split. eapply plus_right. eauto. @@ -1072,7 +1071,7 @@ Proof. eapply agree_exten; eauto. apply Loc.diff_sym. apply loc_acceptable_noteq_diff. auto. red; intros; subst src. simpl in H8. intuition congruence. - exploit Mem.storev_lessdef. eexact MMD. eexact Q. eexact X. eauto. + exploit Mem.storev_extends. eexact MMD. eauto. eexact Q. eexact X. intros [tm2 [Y Z]]. left; econstructor; split. eapply star_plus_trans. eauto. @@ -1157,15 +1156,16 @@ Proof. ExploitWT. inversion WTI. subst ros0 args0. assert (WTF': wt_fundef f'). eapply find_function_wt; eauto. rewrite <- H0. + exploit Mem.free_parallel_extends; eauto. intros [tm' [FREE MMD']]. destruct ros as [fn | id]. (* indirect call *) - red in H4. destruct H4 as [OK1 [OK2 OK3]]. - rewrite <- H0 in H3. rewrite <- H0 in OK3. + red in H5. destruct H5 as [OK1 [OK2 OK3]]. + rewrite <- H0 in H4. rewrite <- H0 in OK3. destruct (parallel_move_arguments_correct tge s' (transf_function f) (Vptr stk Int.zero) args sig (add_reload fn IT1 (Ltailcall sig (inl ident IT1) :: transf_code f b)) - ls tm H3 H5) + ls tm H4 H6) as [ls2 [A [B C]]]. destruct (add_reload_correct tge s' (transf_function f) (Vptr stk Int.zero) fn IT1 (Ltailcall sig (inl ident IT1) :: transf_code f b) @@ -1191,13 +1191,12 @@ Proof. eapply match_stackframes_change_sig; eauto. rewrite return_regs_arguments; auto. congruence. exact (return_regs_preserve (parent_locset s') ls3). - apply Mem.free_lessdef; auto. (* direct call *) - rewrite <- H0 in H3. + rewrite <- H0 in H4. destruct (parallel_move_arguments_correct tge s' (transf_function f) (Vptr stk Int.zero) args sig (Ltailcall sig (inr mreg id) :: transf_code f b) - ls tm H3 H5) + ls tm H4 H6) as [ls3 [D [E F]]]. assert (ARGS: Val.lessdef_list (map rs args) (map ls3 (loc_arguments sig))). @@ -1214,7 +1213,6 @@ Proof. eapply match_stackframes_change_sig; eauto. rewrite return_regs_arguments; auto. congruence. exact (return_regs_preserve (parent_locset s') ls3). - apply Mem.free_lessdef; auto. (* Llabel *) left; econstructor; split. @@ -1272,29 +1270,29 @@ Proof. eapply LTLin.find_label_is_tail; eauto. (* Lreturn *) - ExploitWT; inv WTI. + ExploitWT; inv WTI. + exploit Mem.free_parallel_extends; eauto. intros [tm' [FREE MMD']]. destruct or; simpl. (* with an argument *) exploit add_reload_correct. intros [ls2 [A [B C]]]. left; econstructor; split. - eapply plus_right. eauto. eapply exec_Lreturn; eauto. + eapply plus_right. eauto. eapply exec_Lreturn; eauto. traceEq. econstructor; eauto. rewrite return_regs_result. rewrite B. apply agree_loc; auto. apply return_regs_preserve. - apply Mem.free_lessdef; auto. (* without an argument *) left; econstructor; split. apply plus_one. eapply exec_Lreturn; eauto. econstructor; eauto. apply return_regs_preserve. - apply Mem.free_lessdef; auto. (* internal function *) simpl in WT. inversion_clear WT. inversion H0. simpl in AG. - caseEq (alloc tm 0 (LTLin.fn_stacksize f)). intros tm' tstk TALLOC. - exploit Mem.alloc_lessdef; eauto. intros [P Q]. subst tstk. + exploit Mem.alloc_extends. eauto. eauto. + instantiate (1 := 0); omega. instantiate (1 := LTLin.fn_stacksize f); omega. + intros [tm' [ALLOC MMD']]. destruct (parallel_move_parameters_correct tge s' (transf_function f) (Vptr stk Int.zero) (LTLin.fn_params f) (LTLin.fn_sig f) (transf_code f (LTLin.fn_code f)) (call_regs ls) tm' @@ -1310,8 +1308,8 @@ Proof. econstructor; eauto with coqlib. (* external function *) - exploit event_match_lessdef; eauto. - intros [res' [A B]]. + exploit external_call_mem_extends; eauto. + intros [res' [tm' [A [B [C D]]]]]. left; econstructor; split. apply plus_one. eapply exec_function_external; eauto. econstructor; eauto. @@ -1338,16 +1336,15 @@ Lemma transf_initial_states: Proof. intros. inversion H. econstructor; split. - econstructor. - change (prog_main tprog) with (prog_main prog). + econstructor. + apply Genv.init_mem_transf; eauto. rewrite symbols_preserved. eauto. apply function_ptr_translated; eauto. rewrite sig_preserved. auto. - replace (Genv.init_mem tprog) with (Genv.init_mem prog). - econstructor; eauto. constructor. rewrite H2; auto. - rewrite H2. simpl. constructor. + econstructor; eauto. constructor. rewrite H3; auto. + rewrite H3. simpl. constructor. eapply Genv.find_funct_ptr_prop; eauto. - apply Mem.lessdef_refl. symmetry. unfold tprog, transf_program. apply Genv.init_mem_transf; auto. + apply Mem.extends_refl. Qed. Lemma transf_final_states: diff --git a/backend/Selection.v b/backend/Selection.v index 4355faf..e822fdf 100644 --- a/backend/Selection.v +++ b/backend/Selection.v @@ -28,7 +28,7 @@ Require Import AST. Require Import Integers. Require Import Floats. Require Import Values. -Require Import Mem. +Require Import Memory. Require Import Globalenvs. Require Cminor. Require Import Op. diff --git a/backend/Selectionproof.v b/backend/Selectionproof.v index 70cbeb4..1da7884 100644 --- a/backend/Selectionproof.v +++ b/backend/Selectionproof.v @@ -18,7 +18,7 @@ Require Import AST. Require Import Integers. Require Import Floats. Require Import Values. -Require Import Mem. +Require Import Memory. Require Import Events. Require Import Globalenvs. Require Import Smallstep. @@ -300,7 +300,7 @@ Lemma functions_translated: Genv.find_funct tge v = Some (sel_fundef f). Proof. intros. - exact (Genv.find_funct_transf sel_fundef H). + exact (Genv.find_funct_transf sel_fundef _ _ H). Qed. Lemma function_ptr_translated: @@ -309,7 +309,7 @@ Lemma function_ptr_translated: Genv.find_funct_ptr tge b = Some (sel_fundef f). Proof. intros. - exact (Genv.find_funct_ptr_transf sel_fundef H). + exact (Genv.find_funct_ptr_transf sel_fundef _ _ H). Qed. Lemma sig_function_translated: @@ -428,6 +428,7 @@ Proof. econstructor; split. econstructor. destruct k; simpl in H; simpl; auto. rewrite <- H0; reflexivity. + simpl. eauto. constructor; auto. (* (* assign *) @@ -457,11 +458,11 @@ Proof. constructor; auto. destruct b; auto. (* Sreturn None *) econstructor; split. - econstructor. + econstructor. simpl; eauto. constructor; auto. apply call_cont_commut. (* Sreturn Some *) econstructor; split. - econstructor. simpl. eauto with evalexpr. + econstructor. simpl. eauto with evalexpr. simpl; eauto. constructor; auto. apply call_cont_commut. (* Sgoto *) econstructor; split. @@ -477,10 +478,10 @@ Proof. induction 1. econstructor; split. econstructor. - simpl. fold tge. rewrite symbols_preserved. eexact H. + apply Genv.init_mem_transf; eauto. + simpl. fold tge. rewrite symbols_preserved. eexact H0. apply function_ptr_translated. eauto. - rewrite <- H1. apply sig_function_translated; auto. - unfold tprog, sel_program. rewrite Genv.init_mem_transf. + rewrite <- H2. apply sig_function_translated; auto. constructor; auto. Qed. diff --git a/backend/Stackingproof.v b/backend/Stackingproof.v index ba42958..f44eac2 100644 --- a/backend/Stackingproof.v +++ b/backend/Stackingproof.v @@ -27,7 +27,7 @@ Require Import AST. Require Import Integers. Require Import Values. Require Import Op. -Require Import Mem. +Require Import Memory. Require Import Events. Require Import Globalenvs. Require Import Smallstep. @@ -1145,7 +1145,7 @@ Lemma functions_translated: exists tf, Genv.find_funct tge v = Some tf /\ transf_fundef f = OK tf. Proof - (Genv.find_funct_transf_partial transf_fundef TRANSF). + (Genv.find_funct_transf_partial transf_fundef _ TRANSF). Lemma function_ptr_translated: forall v f, @@ -1153,7 +1153,7 @@ Lemma function_ptr_translated: exists tf, Genv.find_funct_ptr tge v = Some tf /\ transf_fundef f = OK tf. Proof - (Genv.find_funct_ptr_transf_partial transf_fundef TRANSF). + (Genv.find_funct_ptr_transf_partial transf_fundef _ TRANSF). Lemma sig_preserved: forall f tf, transf_fundef f = OK tf -> Mach.funsig tf = Linear.funsig f. @@ -1166,6 +1166,15 @@ Proof. intro. inversion H. reflexivity. Qed. +Lemma stacksize_preserved: + forall f tf, transf_function f = OK tf -> Mach.fn_stacksize tf = Linear.fn_stacksize f. +Proof. + intros until tf; unfold transf_function. + destruct (zlt (Linear.fn_stacksize f) 0). simpl; congruence. + destruct (zlt (- Int.min_signed) (fe_size (make_env (function_bounds f)))). simpl; congruence. + intros. inversion H; reflexivity. +Qed. + Lemma find_function_translated: forall f0 tf0 ls ls0 rs fr cs ros f, agree f0 tf0 ls ls0 rs fr cs -> @@ -1478,10 +1487,12 @@ Proof. simpl. intuition congruence. simpl. intuition congruence. econstructor; split. eapply plus_right. eexact A. - simpl shift_sp. eapply exec_Mtailcall; eauto. traceEq. + simpl shift_sp. eapply exec_Mtailcall; eauto. + rewrite (stacksize_preserved _ _ TRANSL); eauto. + traceEq. econstructor; eauto. intros; symmetry; eapply agree_return_regs; eauto. - intros. inv WTI. generalize (H3 _ H0). tauto. + intros. inv WTI. generalize (H4 _ H0). tauto. apply agree_callee_save_return_regs. (* Llabel *) @@ -1524,7 +1535,9 @@ Proof. intros [ls' [A [B C]]]. econstructor; split. eapply plus_right. eauto. - simpl shift_sp. econstructor; eauto. traceEq. + simpl shift_sp. econstructor; eauto. + rewrite (stacksize_preserved _ _ TRANSL); eauto. + traceEq. econstructor; eauto. intros. symmetry. eapply agree_return_regs; eauto. apply agree_callee_save_return_regs. @@ -1583,13 +1596,13 @@ Proof. exploit function_ptr_translated; eauto. intros [tf [FIND TR]]. econstructor; split. econstructor. + eapply Genv.init_mem_transf_partial; eauto. rewrite (transform_partial_program_main _ _ TRANSF). rewrite symbols_preserved. eauto. eauto. - rewrite (Genv.init_mem_transf_partial _ _ TRANSF). econstructor; eauto. constructor. eapply Genv.find_funct_ptr_prop; eauto. - intros. rewrite H2 in H4. simpl in H4. contradiction. + intros. rewrite H3 in H5. simpl in H5. contradiction. simpl; red; auto. Qed. diff --git a/backend/Tailcallproof.v b/backend/Tailcallproof.v index 8681d84..0ca4c02 100644 --- a/backend/Tailcallproof.v +++ b/backend/Tailcallproof.v @@ -17,7 +17,7 @@ Require Import Maps. Require Import AST. Require Import Integers. Require Import Values. -Require Import Mem. +Require Import Memory. Require Import Op. Require Import Events. Require Import Globalenvs. @@ -227,66 +227,6 @@ Proof. apply regset_set. auto. auto. Qed. -(** ** Agreement between the size of a stack block and a function *) - -(** To reason over deallocation of empty stack blocks, we need to - maintain the invariant that the bounds of a stack block - for function [f] are always [0, f.(fn_stacksize)]. *) - -Inductive match_stacksize: function -> block -> mem -> Z -> Prop := - | match_stacksize_intro: forall f sp m bound, - sp < bound -> - low_bound m sp = 0 -> - high_bound m sp = f.(fn_stacksize) -> - match_stacksize f sp m bound. - -Lemma match_stacksize_store: - forall m m' chunk b ofs v f sp bound, - store chunk m b ofs v = Some m' -> - match_stacksize f sp m bound -> - match_stacksize f sp m' bound. -Proof. - intros. inv H0. constructor. auto. - rewrite <- H2. eapply Mem.low_bound_store; eauto. - rewrite <- H3. eapply Mem.high_bound_store; eauto. -Qed. - -Lemma match_stacksize_alloc_other: - forall m m' lo hi b f sp bound, - alloc m lo hi = (m', b) -> - match_stacksize f sp m bound -> - bound <= m.(nextblock) -> - match_stacksize f sp m' bound. -Proof. - intros. inv H0. - assert (valid_block m sp). red. omega. - constructor. auto. - rewrite <- H3. eapply low_bound_alloc_other; eauto. - rewrite <- H4. eapply high_bound_alloc_other; eauto. -Qed. - -Lemma match_stacksize_alloc_same: - forall m f m' sp, - alloc m 0 f.(fn_stacksize) = (m', sp) -> - match_stacksize f sp m' m'.(nextblock). -Proof. - intros. constructor. - unfold alloc in H. inv H. simpl. omega. - eapply low_bound_alloc_same; eauto. - eapply high_bound_alloc_same; eauto. -Qed. - -Lemma match_stacksize_free: - forall f sp m b bound, - match_stacksize f sp m bound -> - bound <= b -> - match_stacksize f sp (free m b) bound. -Proof. - intros. inv H. constructor. auto. - rewrite <- H2. apply low_bound_free. unfold block; omega. - rewrite <- H3. apply high_bound_free. unfold block; omega. -Qed. - (** * Proof of semantic preservation *) Section PRESERVATION. @@ -319,6 +259,13 @@ Proof. destruct (zeq (fn_stacksize f) 0); auto. Qed. +Lemma stacksize_preserved: + forall f, fn_stacksize (transf_function f) = fn_stacksize f. +Proof. + unfold transf_function. intros. + destruct (zeq (fn_stacksize f) 0); auto. +Qed. + Lemma find_function_translated: forall ros rs rs' f, find_function ge ros rs = Some f -> @@ -370,131 +317,58 @@ We first define the simulation invariant between call stacks. The first two cases are standard, but the third case corresponds to a frame that was eliminated by the transformation. *) -Inductive match_stackframes: mem -> Z -> list stackframe -> list stackframe -> Prop := - | match_stackframes_nil: forall m bound, - match_stackframes m bound nil nil - | match_stackframes_normal: forall m bound stk stk' res sp pc rs rs' f, - match_stackframes m sp stk stk' -> - match_stacksize f sp m bound -> +Inductive match_stackframes: list stackframe -> list stackframe -> Prop := + | match_stackframes_nil: + match_stackframes nil nil + | match_stackframes_normal: forall stk stk' res sp pc rs rs' f, + match_stackframes stk stk' -> regset_lessdef rs rs' -> - match_stackframes m bound - (Stackframe res f.(fn_code) (Vptr sp Int.zero) pc rs :: stk) - (Stackframe res (transf_function f).(fn_code) (Vptr sp Int.zero) pc rs' :: stk') - | match_stackframes_tail: forall m bound stk stk' res sp pc rs f, - match_stackframes m sp stk stk' -> - match_stacksize f sp m bound -> + match_stackframes + (Stackframe res f (Vptr sp Int.zero) pc rs :: stk) + (Stackframe res (transf_function f) (Vptr sp Int.zero) pc rs' :: stk') + | match_stackframes_tail: forall stk stk' res sp pc rs f, + match_stackframes stk stk' -> is_return_spec f pc res -> f.(fn_stacksize) = 0 -> - match_stackframes m bound - (Stackframe res f.(fn_code) (Vptr sp Int.zero) pc rs :: stk) + match_stackframes + (Stackframe res f (Vptr sp Int.zero) pc rs :: stk) stk'. -(** In [match_stackframes m bound s s'], the memory state [m] is used - to check that the sizes of the stack blocks agree with what was - declared by the corresponding functions. The [bound] parameter - is used to enforce separation between the stack blocks. *) - -Lemma match_stackframes_incr: - forall m bound s s' bound', - match_stackframes m bound s s' -> - bound <= bound' -> - match_stackframes m bound' s s'. -Proof. - intros. inv H; econstructor; eauto. - inv H2. constructor; auto. omega. - inv H2. constructor; auto. omega. -Qed. - -Lemma match_stackframes_store: - forall m bound s s', - match_stackframes m bound s s' -> - forall chunk b ofs v m', - store chunk m b ofs v = Some m' -> - match_stackframes m' bound s s'. -Proof. - induction 1; intros. - constructor. - econstructor; eauto. eapply match_stacksize_store; eauto. - econstructor; eauto. eapply match_stacksize_store; eauto. -Qed. - -Lemma match_stackframes_alloc: - forall m lo hi m' sp s s', - match_stackframes m (nextblock m) s s' -> - alloc m lo hi = (m', sp) -> - match_stackframes m' sp s s'. -Proof. - intros. - assert (forall bound s s', - match_stackframes m bound s s' -> - bound <= m.(nextblock) -> - match_stackframes m' bound s s'). - induction 1; intros. constructor. - constructor; auto. apply IHmatch_stackframes; auto. inv H2. omega. - eapply match_stacksize_alloc_other; eauto. - econstructor; eauto. apply IHmatch_stackframes; auto. inv H2. omega. - eapply match_stacksize_alloc_other; eauto. - exploit alloc_result; eauto. intro. rewrite H2. - eapply H1; eauto. omega. -Qed. - -Lemma match_stackframes_free: - forall f sp m s s', - match_stacksize f sp m (nextblock m) -> - match_stackframes m sp s s' -> - match_stackframes (free m sp) (nextblock (free m sp)) s s'. -Proof. - intros. simpl. - assert (forall bound s s', - match_stackframes m bound s s' -> - bound <= sp -> - match_stackframes (free m sp) bound s s'). - induction 1; intros. constructor. - constructor; auto. apply IHmatch_stackframes; auto. inv H2; omega. - apply match_stacksize_free; auto. - econstructor; eauto. apply IHmatch_stackframes; auto. inv H2; omega. - apply match_stacksize_free; auto. - - apply match_stackframes_incr with sp. apply H1; auto. omega. - inv H. omega. -Qed. - (** Here is the invariant relating two states. The first three cases are standard. Note the ``less defined than'' conditions - over values, register states, and memory states. *) + over values and register states, and the corresponding ``extends'' + relation over memory states. *) Inductive match_states: state -> state -> Prop := | match_states_normal: forall s sp pc rs m s' rs' m' f - (STKSZ: match_stacksize f sp m m.(nextblock)) - (STACKS: match_stackframes m sp s s') + (STACKS: match_stackframes s s') (RLD: regset_lessdef rs rs') - (MLD: Mem.lessdef m m'), - match_states (State s f.(fn_code) (Vptr sp Int.zero) pc rs m) - (State s' (transf_function f).(fn_code) (Vptr sp Int.zero) pc rs' m') + (MLD: Mem.extends m m'), + match_states (State s f (Vptr sp Int.zero) pc rs m) + (State s' (transf_function f) (Vptr sp Int.zero) pc rs' m') | match_states_call: forall s f args m s' args' m', - match_stackframes m m.(nextblock) s s' -> + match_stackframes s s' -> Val.lessdef_list args args' -> - Mem.lessdef m m' -> + Mem.extends m m' -> match_states (Callstate s f args m) (Callstate s' (transf_fundef f) args' m') | match_states_return: forall s v m s' v' m', - match_stackframes m m.(nextblock) s s' -> + match_stackframes s s' -> Val.lessdef v v' -> - Mem.lessdef m m' -> + Mem.extends m m' -> match_states (Returnstate s v m) (Returnstate s' v' m') | match_states_interm: forall s sp pc rs m s' m' f r v' - (STKSZ: match_stacksize f sp m m.(nextblock)) - (STACKS: match_stackframes m sp s s') - (MLD: Mem.lessdef m m'), + (STACKS: match_stackframes s s') + (MLD: Mem.extends m m'), is_return_spec f pc r -> f.(fn_stacksize) = 0 -> Val.lessdef (rs#r) v' -> - match_states (State s f.(fn_code) (Vptr sp Int.zero) pc rs m) + match_states (State s f (Vptr sp Int.zero) pc rs m) (Returnstate s' v' m'). (** The last case of [match_states] corresponds to the execution @@ -516,7 +390,7 @@ Inductive match_states: state -> state -> Prop := Definition measure (st: state) : nat := match st with - | State s c sp pc rs m => (List.length s * (niter + 2) + return_measure c pc + 1)%nat + | State s f sp pc rs m => (List.length s * (niter + 2) + return_measure f.(fn_code) pc + 1)%nat | Callstate s f args m => 0%nat | Returnstate s v m => (List.length s * (niter + 2))%nat end. @@ -557,7 +431,7 @@ Proof. assert (Val.lessdef_list (rs##args) (rs'##args)). apply regset_get_list; auto. exploit eval_operation_lessdef; eauto. intros [v' [EVAL' VLD]]. - left. exists (State s' (fn_code (transf_function f)) (Vptr sp0 Int.zero) pc' (rs'#res <- v') m'); split. + left. exists (State s' (transf_function f) (Vptr sp0 Int.zero) pc' (rs'#res <- v') m'); split. eapply exec_Iop; eauto. rewrite <- EVAL'. apply eval_operation_preserved. exact symbols_preserved. econstructor; eauto. apply regset_set; auto. @@ -571,9 +445,9 @@ Proof. assert (Val.lessdef_list (rs##args) (rs'##args)). apply regset_get_list; auto. exploit eval_addressing_lessdef; eauto. intros [a' [ADDR' ALD]]. - exploit loadv_lessdef; eauto. + exploit Mem.loadv_extends; eauto. intros [v' [LOAD' VLD]]. - left. exists (State s' (fn_code (transf_function f)) (Vptr sp0 Int.zero) pc' (rs'#dst <- v') m'); split. + left. exists (State s' (transf_function f) (Vptr sp0 Int.zero) pc' (rs'#dst <- v') m'); split. eapply exec_Iload with (a := a'). eauto. rewrite <- ADDR'. apply eval_addressing_preserved. exact symbols_preserved. eauto. econstructor; eauto. apply regset_set; auto. @@ -583,88 +457,91 @@ Proof. assert (Val.lessdef_list (rs##args) (rs'##args)). apply regset_get_list; auto. exploit eval_addressing_lessdef; eauto. intros [a' [ADDR' ALD]]. - exploit storev_lessdef. 4: eexact H1. eauto. eauto. apply RLD. + exploit Mem.storev_extends. 2: eexact H1. eauto. eauto. apply RLD. intros [m'1 [STORE' MLD']]. - left. exists (State s' (fn_code (transf_function f)) (Vptr sp0 Int.zero) pc' rs' m'1); split. + left. exists (State s' (transf_function f) (Vptr sp0 Int.zero) pc' rs' m'1); split. eapply exec_Istore with (a := a'). eauto. rewrite <- ADDR'. apply eval_addressing_preserved. exact symbols_preserved. eauto. destruct a; simpl in H1; try discriminate. econstructor; eauto. - eapply match_stacksize_store; eauto. - rewrite (nextblock_store _ _ _ _ _ _ H1). auto. - eapply match_stackframes_store; eauto. (* call *) exploit find_function_translated; eauto. intro FIND'. TransfInstr. (* call turned tailcall *) - left. exists (Callstate s' (transf_fundef f) (rs'##args) (Mem.free m' sp0)); split. + assert ({ m'' | Mem.free m' sp0 0 (fn_stacksize (transf_function f)) = Some m''}). + apply Mem.range_perm_free. rewrite stacksize_preserved. rewrite H7. + red; intros; omegaContradiction. + destruct X as [m'' FREE]. + left. exists (Callstate s' (transf_fundef fd) (rs'##args) m''); split. eapply exec_Itailcall; eauto. apply sig_preserved. constructor. eapply match_stackframes_tail; eauto. apply regset_get_list; auto. - apply Mem.free_right_lessdef; auto. inv STKSZ. omega. + eapply Mem.free_right_extends; eauto. + rewrite stacksize_preserved. rewrite H7. intros. omegaContradiction. (* call that remains a call *) - left. exists (Callstate (Stackframe res (fn_code (transf_function f0)) (Vptr sp0 Int.zero) pc' rs' :: s') - (transf_fundef f) (rs'##args) m'); split. + left. exists (Callstate (Stackframe res (transf_function f) (Vptr sp0 Int.zero) pc' rs' :: s') + (transf_fundef fd) (rs'##args) m'); split. eapply exec_Icall; eauto. apply sig_preserved. constructor. constructor; auto. apply regset_get_list; auto. auto. (* tailcall *) - exploit find_function_translated; eauto. intro FIND'. + exploit find_function_translated; eauto. intro FIND'. + exploit Mem.free_parallel_extends; eauto. intros [m'1 [FREE EXT]]. TransfInstr. - left. exists (Callstate s' (transf_fundef f) (rs'##args) (Mem.free m' stk)); split. - eapply exec_Itailcall; eauto. apply sig_preserved. - constructor. eapply match_stackframes_free; eauto. - apply regset_get_list; auto. apply Mem.free_lessdef; auto. + left. exists (Callstate s' (transf_fundef fd) (rs'##args) m'1); split. + eapply exec_Itailcall; eauto. apply sig_preserved. + rewrite stacksize_preserved; auto. + constructor. auto. apply regset_get_list; auto. auto. (* cond true *) TransfInstr. - left. exists (State s' (fn_code (transf_function f)) (Vptr sp0 Int.zero) ifso rs' m'); split. + left. exists (State s' (transf_function f) (Vptr sp0 Int.zero) ifso rs' m'); split. eapply exec_Icond_true; eauto. apply eval_condition_lessdef with (rs##args); auto. apply regset_get_list; auto. constructor; auto. (* cond false *) TransfInstr. - left. exists (State s' (fn_code (transf_function f)) (Vptr sp0 Int.zero) ifnot rs' m'); split. + left. exists (State s' (transf_function f) (Vptr sp0 Int.zero) ifnot rs' m'); split. eapply exec_Icond_false; eauto. apply eval_condition_lessdef with (rs##args); auto. apply regset_get_list; auto. constructor; auto. (* jumptable *) TransfInstr. - left. exists (State s' (fn_code (transf_function f)) (Vptr sp0 Int.zero) pc' rs' m'); split. + left. exists (State s' (transf_function f) (Vptr sp0 Int.zero) pc' rs' m'); split. eapply exec_Ijumptable; eauto. generalize (RLD arg). rewrite H0. intro. inv H2. auto. constructor; auto. (* return *) + exploit Mem.free_parallel_extends; eauto. intros [m'1 [FREE EXT]]. TransfInstr. - left. exists (Returnstate s' (regmap_optget or Vundef rs') (free m' stk)); split. - apply exec_Ireturn; auto. - constructor. - eapply match_stackframes_free; eauto. + left. exists (Returnstate s' (regmap_optget or Vundef rs') m'1); split. + apply exec_Ireturn; auto. rewrite stacksize_preserved; auto. + constructor. auto. destruct or; simpl. apply RLD. constructor. - apply Mem.free_lessdef; auto. + auto. (* eliminated return None *) assert (or = None) by congruence. subst or. right. split. simpl. omega. split. auto. - constructor. - eapply match_stackframes_free; eauto. + constructor. auto. simpl. constructor. - apply Mem.free_left_lessdef; auto. + eapply Mem.free_left_extends; eauto. (* eliminated return Some *) assert (or = Some r) by congruence. subst or. right. split. simpl. omega. split. auto. - constructor. - eapply match_stackframes_free; eauto. + constructor. auto. simpl. auto. - apply Mem.free_left_lessdef; auto. + eapply Mem.free_left_extends; eauto. (* internal call *) - caseEq (alloc m'0 0 (fn_stacksize f)). intros m'1 stk' ALLOC'. - exploit alloc_lessdef; eauto. intros [EQ1 LD']. subst stk'. + exploit Mem.alloc_extends; eauto. + instantiate (1 := 0). omega. + instantiate (1 := fn_stacksize f). omega. + intros [m'1 [ALLOC EXT]]. assert (fn_stacksize (transf_function f) = fn_stacksize f /\ fn_entrypoint (transf_function f) = fn_entrypoint f /\ fn_params (transf_function f) = fn_params f). @@ -673,13 +550,12 @@ Proof. left. econstructor; split. simpl. eapply exec_function_internal; eauto. rewrite EQ1; eauto. rewrite EQ2. rewrite EQ3. constructor; auto. - eapply match_stacksize_alloc_same; eauto. - eapply match_stackframes_alloc; eauto. apply regset_init_regs. auto. (* external call *) - exploit event_match_lessdef; eauto. intros [res' [EVM' VLD']]. - left. exists (Returnstate s' res' m'); split. + exploit external_call_mem_extends; eauto. + intros [res' [m2' [A [B [C D]]]]]. + left. exists (Returnstate s' res' m2'); split. simpl. econstructor; eauto. constructor; auto. @@ -705,15 +581,13 @@ Lemma transf_initial_states: Proof. intros. inv H. exploit funct_ptr_translated; eauto. intro FIND. - exists (Callstate nil (transf_fundef f) nil (Genv.init_mem tprog)); split. - econstructor; eauto. + exists (Callstate nil (transf_fundef f) nil m0); split. + econstructor; eauto. apply Genv.init_mem_transf. auto. replace (prog_main tprog) with (prog_main prog). rewrite symbols_preserved. eauto. reflexivity. - rewrite <- H2. apply sig_preserved. - replace (Genv.init_mem tprog) with (Genv.init_mem prog). - constructor. constructor. constructor. apply lessdef_refl. - symmetry. unfold tprog, transf_program. apply Genv.init_mem_transf. + rewrite <- H3. apply sig_preserved. + constructor. constructor. constructor. apply Mem.extends_refl. Qed. Lemma transf_final_states: diff --git a/backend/Tunnelingproof.v b/backend/Tunnelingproof.v index 92ec68c..4cbcbd4 100644 --- a/backend/Tunnelingproof.v +++ b/backend/Tunnelingproof.v @@ -17,7 +17,7 @@ Require Import Maps. Require Import UnionFind. Require Import AST. Require Import Values. -Require Import Mem. +Require Import Memory. Require Import Events. Require Import Globalenvs. Require Import Smallstep. @@ -348,15 +348,14 @@ Lemma transf_initial_states: exists st2, initial_state tp st2 /\ match_states st1 st2. Proof. intros. inversion H. - exists (Callstate nil (tunnel_fundef f) nil (Genv.init_mem tp)); split. + exists (Callstate nil (tunnel_fundef f) nil m0); split. econstructor; eauto. + apply Genv.init_mem_transf; auto. change (prog_main tp) with (prog_main p). rewrite symbols_preserved. eauto. apply function_ptr_translated; auto. - rewrite <- H2. apply sig_preserved. - replace (Genv.init_mem tp) with (Genv.init_mem p). - constructor. constructor. auto. - symmetry. unfold tp, tunnel_program. apply Genv.init_mem_transf. + rewrite <- H3. apply sig_preserved. + constructor. constructor. Qed. Lemma transf_final_states: diff --git a/backend/Tunnelingtyping.v b/backend/Tunnelingtyping.v index 834e8e1..743b468 100644 --- a/backend/Tunnelingtyping.v +++ b/backend/Tunnelingtyping.v @@ -17,7 +17,7 @@ Require Import Maps. Require Import UnionFind. Require Import AST. Require Import Values. -Require Import Mem. +Require Import Memory. Require Import Globalenvs. Require Import Op. Require Import Locations. diff --git a/cfrontend/Cminorgen.v b/cfrontend/Cminorgen.v index f48b0ab..ba3a2bf 100644 --- a/cfrontend/Cminorgen.v +++ b/cfrontend/Cminorgen.v @@ -20,9 +20,8 @@ Require Import Maps. Require Import Ordered. Require Import AST. Require Import Integers. -Require Mem. +Require Import Memdata. Require Import Csharpminor. -Require Import Op. Require Import Cminor. Open Local Scope string_scope. @@ -49,14 +48,132 @@ Open Local Scope error_monad_scope. of Cminor. *) -(** Translation of constants. *) +(** Compile-time information attached to each Csharpminor + variable: global variables, local variables, function parameters. + [Var_local] denotes a scalar local variable whose address is not + taken; it will be translated to a Cminor local variable of the + same name. [Var_stack_scalar] and [Var_stack_array] denote + local variables that are stored as sub-blocks of the Cminor stack + data block. [Var_global_scalar] and [Var_global_array] denote + global variables, stored in the global symbols with the same names. *) -Definition transl_constant (cst: Csharpminor.constant): constant := - match cst with - | Csharpminor.Ointconst n => Ointconst n - | Csharpminor.Ofloatconst n => Ofloatconst n +Inductive var_info: Type := + | Var_local: memory_chunk -> var_info + | Var_stack_scalar: memory_chunk -> Z -> var_info + | Var_stack_array: Z -> var_info + | Var_global_scalar: memory_chunk -> var_info + | Var_global_array: var_info. + +Definition compilenv := PMap.t var_info. + +(** Infer the type or memory chunk of the result of an expression. *) + +Definition chunktype_const (c: Csharpminor.constant) := + match c with + | Csharpminor.Ointconst n => Mint32 + | Csharpminor.Ofloatconst n => Mfloat64 end. +Definition chunktype_unop (op: unary_operation) := + match op with + | Ocast8unsigned => Mint8unsigned + | Ocast8signed => Mint8signed + | Ocast16unsigned => Mint16unsigned + | Ocast16signed => Mint16signed + | Onegint => Mint32 + | Onotbool => Mint32 + | Onotint => Mint32 + | Onegf => Mfloat64 + | Oabsf => Mfloat64 + | Osingleoffloat => Mfloat32 + | Ointoffloat => Mint32 + | Ointuoffloat => Mint32 + | Ofloatofint => Mfloat64 + | Ofloatofintu => Mfloat64 + end. + +Definition chunktype_binop (op: binary_operation) := + match op with + | Oadd => Mint32 + | Osub => Mint32 + | Omul => Mint32 + | Odiv => Mint32 + | Odivu => Mint32 + | Omod => Mint32 + | Omodu => Mint32 + | Oand => Mint32 + | Oor => Mint32 + | Oxor => Mint32 + | Oshl => Mint32 + | Oshr => Mint32 + | Oshru => Mint32 + | Oaddf => Mfloat64 + | Osubf => Mfloat64 + | Omulf => Mfloat64 + | Odivf => Mfloat64 + | Ocmp c => Mint8unsigned + | Ocmpu c => Mint8unsigned + | Ocmpf c => Mint8unsigned + end. + +Definition chunktype_compat (src dst: memory_chunk) : bool := + match src, dst with + | Mint8unsigned, (Mint8unsigned|Mint16unsigned|Mint16signed|Mint32) => true + | Mint8signed, (Mint8signed|Mint16unsigned|Mint16signed|Mint32) => true + | Mint16unsigned, (Mint16unsigned|Mint32) => true + | Mint16signed, (Mint16signed|Mint32) => true + | Mint32, Mint32 => true + | Mfloat32, (Mfloat32|Mfloat64) => true + | Mfloat64, Mfloat64 => true + | _, _ => false + end. + +Definition chunk_for_type (ty: typ) : memory_chunk := + match ty with Tint => Mint32 | Tfloat => Mfloat64 end. + +Definition chunktype_merge (c1 c2: memory_chunk) : res memory_chunk := + if chunktype_compat c1 c2 then + OK c2 + else if chunktype_compat c2 c1 then + OK c1 + else if typ_eq (type_of_chunk c1) (type_of_chunk c2) then + OK (chunk_for_type (type_of_chunk c1)) + else + Error(msg "Cminorgen: chunktype_merge"). + +Fixpoint chunktype_expr (cenv: compilenv) (e: Csharpminor.expr) + {struct e}: res memory_chunk := + match e with + | Csharpminor.Evar id => + match cenv!!id with + | Var_local chunk => OK chunk + | Var_stack_scalar chunk ofs => OK chunk + | Var_global_scalar chunk => OK chunk + | _ => Error(msg "Cminorgen.chunktype_expr") + end + | Csharpminor.Eaddrof id => + OK Mint32 + | Csharpminor.Econst cst => + OK (chunktype_const cst) + | Csharpminor.Eunop op e1 => + OK (chunktype_unop op) + | Csharpminor.Ebinop op e1 e2 => + OK (chunktype_binop op) + | Csharpminor.Eload chunk e => + OK chunk + | Csharpminor.Econdition e1 e2 e3 => + do chunk2 <- chunktype_expr cenv e2; + do chunk3 <- chunktype_expr cenv e3; + chunktype_merge chunk2 chunk3 + end. + +Definition type_expr (cenv: compilenv) (e: Csharpminor.expr): res typ := + do c <- chunktype_expr cenv e; OK(type_of_chunk c). + +Definition type_exprlist (cenv: compilenv) (el: list Csharpminor.expr): + res (list typ) := + mmap (type_expr cenv) el. + (** [make_cast chunk e] returns a Cminor expression that normalizes the value of Cminor expression [e] as prescribed by the memory chunk [chunk]. For instance, 8-bit sign extension is performed if @@ -74,10 +191,9 @@ Definition make_cast (chunk: memory_chunk) (e: expr): expr := end. (** When the translation of an expression is stored in memory, - the normalization performed by [make_cast] can be redundant + a cast at the toplevel of the expression can be redundant with that implicitly performed by the memory store. - [store_arg] detects this case and strips away the redundant - normalization. *) + [store_arg] detects this case and strips away the redundant cast. *) Definition store_arg (chunk: memory_chunk) (e: expr) : expr := match e with @@ -103,26 +219,7 @@ Definition make_stackaddr (ofs: Z): expr := Definition make_globaladdr (id: ident): expr := Econst (Oaddrsymbol id Int.zero). -(** Compile-time information attached to each Csharpminor - variable: global variables, local variables, function parameters. - [Var_local] denotes a scalar local variable whose address is not - taken; it will be translated to a Cminor local variable of the - same name. [Var_stack_scalar] and [Var_stack_array] denote - local variables that are stored as sub-blocks of the Cminor stack - data block. [Var_global_scalar] and [Var_global_array] denote - global variables, stored in the global symbols with the same names. *) - -Inductive var_info: Type := - | Var_local: memory_chunk -> var_info - | Var_stack_scalar: memory_chunk -> Z -> var_info - | Var_stack_array: Z -> var_info - | Var_global_scalar: memory_chunk -> var_info - | Var_global_array: var_info. - -Definition compilenv := PMap.t var_info. - -(** Generation of Cminor code corresponding to accesses to Csharpminor - local variables: reads, assignments, and taking the address of. *) +(** Generation of a Cminor expression for reading a Csharpminor variable. *) Definition var_get (cenv: compilenv) (id: ident): res expr := match PMap.get id cenv with @@ -136,24 +233,67 @@ Definition var_get (cenv: compilenv) (id: ident): res expr := Error(msg "Cminorgen.var_get") end. -Definition var_set (cenv: compilenv) (id: ident) (rhs: expr): res stmt := +(** Generation of a Cminor expression for taking the address of + a Csharpminor variable. *) + +Definition var_addr (cenv: compilenv) (id: ident): res expr := + match PMap.get id cenv with + | Var_local chunk => Error(msg "Cminorgen.var_addr") + | Var_stack_scalar chunk ofs => OK (make_stackaddr ofs) + | Var_stack_array ofs => OK (make_stackaddr ofs) + | _ => OK (make_globaladdr id) + end. + +(** Generation of a Cminor statement performing an assignment to + a variable. [rhs_chunk] is the inferred chunk type for the + right-hand side. If the variable was allocated to a Cminor variable, + a cast may need to be inserted to normalize the value of the r.h.s., + as per Csharpminor's semantics. *) + +Definition var_set (cenv: compilenv) + (id: ident) (rhs: expr) (rhs_chunk: memory_chunk): res stmt := match PMap.get id cenv with | Var_local chunk => - OK(Sassign id (make_cast chunk rhs)) + if chunktype_compat rhs_chunk chunk then + OK(Sassign id rhs) + else if typ_eq (type_of_chunk chunk) (type_of_chunk rhs_chunk) then + OK(Sassign id (make_cast chunk rhs)) + else + Error(msg "Cminorgen.var_set.1") | Var_stack_scalar chunk ofs => OK(make_store chunk (make_stackaddr ofs) rhs) | Var_global_scalar chunk => OK(make_store chunk (make_globaladdr id) rhs) | _ => - Error(msg "Cminorgen.var_set") + Error(msg "Cminorgen.var_set.2") end. -Definition var_addr (cenv: compilenv) (id: ident): res expr := +(** A variant of [var_set] used for initializing function parameters + and storing the return values of function calls. The value to + be stored already resides in the Cminor variable called [id]. + Moreover, its chunk type is not known, only its int-or-float type. *) + +Definition var_set_self (cenv: compilenv) (id: ident) (ty: typ): res stmt := match PMap.get id cenv with - | Var_local chunk => Error(msg "Cminorgen.var_addr") - | Var_stack_scalar chunk ofs => OK (make_stackaddr ofs) - | Var_stack_array ofs => OK (make_stackaddr ofs) - | _ => OK (make_globaladdr id) + | Var_local chunk => + if typ_eq (type_of_chunk chunk) ty then + OK(Sassign id (make_cast chunk (Evar id))) + else + Error(msg "Cminorgen.var_set_self.1") + | Var_stack_scalar chunk ofs => + OK(make_store chunk (make_stackaddr ofs) (Evar id)) + | Var_global_scalar chunk => + OK(make_store chunk (make_globaladdr id) (Evar id)) + | _ => + Error(msg "Cminorgen.var_set_self.2") + end. + +(** Translation of constants. *) + +Definition transl_constant (cst: Csharpminor.constant): constant := + match cst with + | Csharpminor.Ointconst n => Ointconst n + | Csharpminor.Ofloatconst n => Ofloatconst n end. (** Translation of expressions. All the hard work is done by the @@ -234,16 +374,27 @@ Fixpoint switch_env (ls: lbl_stmt) (e: exit_env) {struct ls}: exit_env := | LScase _ _ ls' => false :: switch_env ls' e end. -(** Translation of statements. The only nonobvious part is - the translation of [switch] statements, outlined above. *) +(** Translation of statements. The nonobvious part is + the translation of [switch] statements, outlined above. + Also note the additional type checks on arguments to calls and returns. + These checks should always succeed for C#minor code generated from + well-typed Clight code, but are necessary for the correctness proof + to go through. +*) + +Definition typ_of_opttyp (ot: option typ) := + match ot with None => Tint | Some t => t end. -Fixpoint transl_stmt (cenv: compilenv) (xenv: exit_env) (s: Csharpminor.stmt) +Fixpoint transl_stmt (ret: option typ) (cenv: compilenv) + (xenv: exit_env) (s: Csharpminor.stmt) {struct s}: res stmt := match s with | Csharpminor.Sskip => OK Sskip | Csharpminor.Sassign id e => - do te <- transl_expr cenv e; var_set cenv id te + do chunk <- chunktype_expr cenv e; + do te <- transl_expr cenv e; + var_set cenv id te chunk | Csharpminor.Sstore chunk e1 e2 => do te1 <- transl_expr cenv e1; do te2 <- transl_expr cenv e2; @@ -251,26 +402,32 @@ Fixpoint transl_stmt (cenv: compilenv) (xenv: exit_env) (s: Csharpminor.stmt) | Csharpminor.Scall None sig e el => do te <- transl_expr cenv e; do tel <- transl_exprlist cenv el; - OK (Scall None sig te tel) + do tyl <- type_exprlist cenv el; + if list_eq_dec typ_eq tyl sig.(sig_args) + then OK (Scall None sig te tel) + else Error(msg "Cminorgen.transl_stmt(call0)") | Csharpminor.Scall (Some id) sig e el => do te <- transl_expr cenv e; do tel <- transl_exprlist cenv el; - do s <- var_set cenv id (Evar id); - OK (Sseq (Scall (Some id) sig te tel) s) + do tyl <- type_exprlist cenv el; + do s <- var_set_self cenv id (proj_sig_res sig); + if list_eq_dec typ_eq tyl sig.(sig_args) + then OK (Sseq (Scall (Some id) sig te tel) s) + else Error(msg "Cminorgen.transl_stmt(call1)") | Csharpminor.Sseq s1 s2 => - do ts1 <- transl_stmt cenv xenv s1; - do ts2 <- transl_stmt cenv xenv s2; + do ts1 <- transl_stmt ret cenv xenv s1; + do ts2 <- transl_stmt ret cenv xenv s2; OK (Sseq ts1 ts2) | Csharpminor.Sifthenelse e s1 s2 => do te <- transl_expr cenv e; - do ts1 <- transl_stmt cenv xenv s1; - do ts2 <- transl_stmt cenv xenv s2; + do ts1 <- transl_stmt ret cenv xenv s1; + do ts2 <- transl_stmt ret cenv xenv s2; OK (Sifthenelse te ts1 ts2) | Csharpminor.Sloop s => - do ts <- transl_stmt cenv xenv s; + do ts <- transl_stmt ret cenv xenv s; OK (Sloop ts) | Csharpminor.Sblock s => - do ts <- transl_stmt cenv (true :: xenv) s; + do ts <- transl_stmt ret cenv (true :: xenv) s; OK (Sblock ts) | Csharpminor.Sexit n => OK (Sexit (shift_exit xenv n)) @@ -278,27 +435,31 @@ Fixpoint transl_stmt (cenv: compilenv) (xenv: exit_env) (s: Csharpminor.stmt) let cases := switch_table ls O in let default := length cases in do te <- transl_expr cenv e; - transl_lblstmt cenv (switch_env ls xenv) ls (Sswitch te cases default) + transl_lblstmt ret cenv (switch_env ls xenv) ls (Sswitch te cases default) | Csharpminor.Sreturn None => OK (Sreturn None) | Csharpminor.Sreturn (Some e) => - do te <- transl_expr cenv e; OK (Sreturn (Some te)) + do te <- transl_expr cenv e; + do ty <- type_expr cenv e; + if typ_eq ty (typ_of_opttyp ret) + then OK (Sreturn (Some te)) + else Error(msg "Cminorgen.transl_stmt(return)") | Csharpminor.Slabel lbl s => - do ts <- transl_stmt cenv xenv s; OK (Slabel lbl ts) + do ts <- transl_stmt ret cenv xenv s; OK (Slabel lbl ts) | Csharpminor.Sgoto lbl => OK (Sgoto lbl) end -with transl_lblstmt (cenv: compilenv) (xenv: exit_env) - (ls: Csharpminor.lbl_stmt) (body: stmt) +with transl_lblstmt (ret: option typ) (cenv: compilenv) + (xenv: exit_env) (ls: Csharpminor.lbl_stmt) (body: stmt) {struct ls}: res stmt := match ls with | Csharpminor.LSdefault s => - do ts <- transl_stmt cenv xenv s; + do ts <- transl_stmt ret cenv xenv s; OK (Sseq (Sblock body) ts) | Csharpminor.LScase _ s ls' => - do ts <- transl_stmt cenv xenv s; - transl_lblstmt cenv (List.tail xenv) ls' (Sseq (Sblock body) ts) + do ts <- transl_stmt ret cenv xenv s; + transl_lblstmt ret cenv (List.tail xenv) ls' (Sseq (Sblock body) ts) end. (** Computation of the set of variables whose address is taken in @@ -379,7 +540,7 @@ Definition assign_variable (PMap.set id (Var_stack_array ofs) cenv, ofs + Zmax 0 sz) | (id, Vscalar chunk) => if Identset.mem id atk then - let sz := Mem.size_chunk chunk in + let sz := size_chunk chunk in let ofs := align stacksize sz in (PMap.set id (Var_stack_scalar chunk ofs) cenv, ofs + sz) else @@ -425,7 +586,7 @@ Fixpoint store_parameters match params with | nil => OK Sskip | (id, chunk) :: rem => - do s1 <- var_set cenv id (Evar id); + do s1 <- var_set_self cenv id (type_of_chunk chunk); do s2 <- store_parameters cenv rem; OK (Sseq s1 s2) end. @@ -471,7 +632,7 @@ Definition make_vars (params: list ident) (vars: list ident) Definition transl_funbody (cenv: compilenv) (stacksize: Z) (f: Csharpminor.function): res function := - do tbody <- transl_stmt cenv nil f.(Csharpminor.fn_body); + do tbody <- transl_stmt f.(fn_return) cenv nil f.(Csharpminor.fn_body); do sparams <- store_parameters cenv f.(Csharpminor.fn_params); OK (mkfunction (Csharpminor.fn_sig f) diff --git a/cfrontend/Cminorgenproof.v b/cfrontend/Cminorgenproof.v index a472e70..c79555c 100644 --- a/cfrontend/Cminorgenproof.v +++ b/cfrontend/Cminorgenproof.v @@ -12,20 +12,23 @@ (** Correctness proof for Cminor generation. *) +Require Import Coq.Program.Equality. Require Import FSets. Require Import Coqlib. +Require Intv. Require Import Errors. Require Import Maps. Require Import AST. Require Import Integers. Require Import Floats. Require Import Values. -Require Import Mem. +Require Import Memdata. +Require Import Memory. Require Import Events. Require Import Globalenvs. Require Import Smallstep. +Require Import Switch. Require Import Csharpminor. -Require Import Op. Require Import Cminor. Require Import Cminorgen. @@ -51,20 +54,19 @@ Lemma function_ptr_translated: Genv.find_funct_ptr ge b = Some f -> exists tf, Genv.find_funct_ptr tge b = Some tf /\ transl_fundef gce f = OK tf. -Proof (Genv.find_funct_ptr_transf_partial2 (transl_fundef gce) transl_globvar TRANSL). - +Proof (Genv.find_funct_ptr_transf_partial2 (transl_fundef gce) transl_globvar _ TRANSL). Lemma functions_translated: forall (v: val) (f: Csharpminor.fundef), Genv.find_funct ge v = Some f -> exists tf, Genv.find_funct tge v = Some tf /\ transl_fundef gce f = OK tf. -Proof (Genv.find_funct_transf_partial2 (transl_fundef gce) transl_globvar TRANSL). +Proof (Genv.find_funct_transf_partial2 (transl_fundef gce) transl_globvar _ TRANSL). Lemma sig_preserved_body: forall f tf cenv size, transl_funbody cenv size f = OK tf -> - tf.(fn_sig) = f.(Csharpminor.fn_sig). + tf.(fn_sig) = Csharpminor.fn_sig f. Proof. intros. monadInv H. reflexivity. Qed. @@ -112,6 +114,193 @@ Proof. intro. rewrite PMap.gi. auto. Qed. +(** * Derived properties of memory operations *) + +Lemma load_freelist: + forall fbl chunk m b ofs m', + (forall b' lo hi, In (b', lo, hi) fbl -> b' <> b) -> + Mem.free_list m fbl = Some m' -> + Mem.load chunk m' b ofs = Mem.load chunk m b ofs. +Proof. + induction fbl; intros. + simpl in H0. congruence. + destruct a as [[b' lo] hi]. + generalize H0. simpl. case_eq (Mem.free m b' lo hi); try congruence. + intros m1 FR1 FRL. + transitivity (Mem.load chunk m1 b ofs). + eapply IHfbl; eauto. intros. eapply H. eauto with coqlib. + eapply Mem.load_free; eauto. left. apply sym_not_equal. eapply H. auto with coqlib. +Qed. + +Lemma perm_freelist: + forall fbl m m' b ofs p, + Mem.free_list m fbl = Some m' -> + Mem.perm m' b ofs p -> + Mem.perm m b ofs p. +Proof. + induction fbl; simpl; intros until p. + congruence. + destruct a as [[b' lo] hi]. case_eq (Mem.free m b' lo hi); try congruence. + intros. eauto with mem. +Qed. + +Lemma nextblock_freelist: + forall fbl m m', + Mem.free_list m fbl = Some m' -> + Mem.nextblock m' = Mem.nextblock m. +Proof. + induction fbl; intros until m'; simpl. + congruence. + destruct a as [[b lo] hi]. + case_eq (Mem.free m b lo hi); intros; try congruence. + transitivity (Mem.nextblock m0). eauto. eapply Mem.nextblock_free; eauto. +Qed. + +Lemma free_list_freeable: + forall l m m', + Mem.free_list m l = Some m' -> + forall b lo hi, + In (b, lo, hi) l -> Mem.range_perm m b lo hi Freeable. +Proof. + induction l; simpl; intros. + contradiction. + revert H. destruct a as [[b' lo'] hi']. + caseEq (Mem.free m b' lo' hi'); try congruence. + intros m1 FREE1 FREE2. + destruct H0. inv H. + eauto with mem. + red; intros. eapply Mem.perm_free_3; eauto. exploit IHl; eauto. +Qed. + +Lemma bounds_freelist: + forall b l m m', + Mem.free_list m l = Some m' -> Mem.bounds m' b = Mem.bounds m b. +Proof. + induction l; simpl; intros. + inv H; auto. + revert H. destruct a as [[b' lo'] hi']. + caseEq (Mem.free m b' lo' hi'); try congruence. + intros m1 FREE1 FREE2. + transitivity (Mem.bounds m1 b). eauto. eapply Mem.bounds_free; eauto. +Qed. + +Lemma nextblock_storev: + forall chunk m addr v m', + Mem.storev chunk m addr v = Some m' -> Mem.nextblock m' = Mem.nextblock m. +Proof. + unfold Mem.storev; intros. destruct addr; try discriminate. + eapply Mem.nextblock_store; eauto. +Qed. + +(** * Normalized values and operations over memory chunks *) + +(** A value is normalized with respect to a memory chunk if it is + invariant under the cast (truncation, sign extension) corresponding to + the chunk. *) + +Definition val_normalized (v: val) (chunk: memory_chunk) : Prop := + Val.load_result chunk v = v. + +Lemma val_normalized_has_type: + forall chunk v, val_normalized v chunk -> Val.has_type v (type_of_chunk chunk). +Proof. + intros until v; unfold val_normalized, Val.load_result. + destruct chunk; destruct v; intro EQ; try (inv EQ); simpl; exact I. +Qed. + +Lemma val_has_type_normalized: + forall ty v, Val.has_type v ty -> val_normalized v (chunk_for_type ty). +Proof. + unfold Val.has_type, val_normalized; intros; destruct ty; destruct v; + contradiction || reflexivity. +Qed. + +Lemma chunktype_const_correct: + forall c v, + Csharpminor.eval_constant c = Some v -> + val_normalized v (chunktype_const c). +Proof. + unfold Csharpminor.eval_constant; intros. + destruct c; inv H; unfold val_normalized; auto. +Qed. + +Lemma chunktype_unop_correct: + forall op v1 v, + Csharpminor.eval_unop op v1 = Some v -> + val_normalized v (chunktype_unop op). +Proof. + intros; destruct op; simpl in *; unfold val_normalized. + inv H. destruct v1; simpl; auto. rewrite Int.zero_ext_idem; auto. compute; auto. + inv H. destruct v1; simpl; auto. rewrite Int.sign_ext_idem; auto. compute; auto. + inv H. destruct v1; simpl; auto. rewrite Int.zero_ext_idem; auto. compute; auto. + inv H. destruct v1; simpl; auto. rewrite Int.sign_ext_idem; auto. compute; auto. + destruct v1; inv H; auto. + destruct v1; inv H. destruct (Int.eq i Int.zero); auto. reflexivity. + destruct v1; inv H; auto. + destruct v1; inv H; auto. + destruct v1; inv H; auto. + inv H. destruct v1; simpl; auto. rewrite Float.singleoffloat_idem; auto. + destruct v1; inv H; auto. + destruct v1; inv H; auto. + destruct v1; inv H; auto. + destruct v1; inv H; auto. +Qed. + +Lemma chunktype_binop_correct: + forall op v1 v2 m v, + Csharpminor.eval_binop op v1 v2 m = Some v -> + val_normalized v (chunktype_binop op). +Proof. + intros; destruct op; simpl in *; unfold val_normalized; + destruct v1; destruct v2; try (inv H; reflexivity). + destruct (eq_block b b0); inv H; auto. + destruct (Int.eq i0 Int.zero); inv H; auto. + destruct (Int.eq i0 Int.zero); inv H; auto. + destruct (Int.eq i0 Int.zero); inv H; auto. + destruct (Int.eq i0 Int.zero); inv H; auto. + destruct (Int.ltu i0 Int.iwordsize); inv H; auto. + destruct (Int.ltu i0 Int.iwordsize); inv H; auto. + destruct (Int.ltu i0 Int.iwordsize); inv H; auto. + inv H; destruct (Int.cmp c i i0); reflexivity. + unfold eval_compare_null in H. destruct (Int.eq i Int.zero). + destruct c; inv H; auto. inv H. + unfold eval_compare_null in H. destruct (Int.eq i0 Int.zero). + destruct c; inv H; auto. inv H. + destruct (Mem.valid_pointer m b (Int.signed i) && + Mem.valid_pointer m b0 (Int.signed i0)). + destruct (eq_block b b0); inv H. destruct (Int.cmp c i i0); auto. + destruct c; inv H1; auto. inv H. + inv H. destruct (Int.cmpu c i i0); auto. + inv H. destruct (Float.cmp c f f0); auto. +Qed. + +Lemma chunktype_compat_correct: + forall src dst v, + chunktype_compat src dst = true -> + val_normalized v src -> val_normalized v dst. +Proof. + unfold val_normalized; intros. rewrite <- H0. + destruct src; destruct dst; simpl in H; try discriminate; auto; + destruct v; simpl; auto. +Admitted. + +Lemma chunktype_merge_correct: + forall c1 c2 c v, + chunktype_merge c1 c2 = OK c -> + val_normalized v c1 \/ val_normalized v c2 -> + val_normalized v c. +Proof. + intros until v. unfold chunktype_merge. + case_eq (chunktype_compat c1 c2). + intros. inv H0. destruct H1. eapply chunktype_compat_correct; eauto. auto. + case_eq (chunktype_compat c2 c1). + intros. inv H1. destruct H2. auto. eapply chunktype_compat_correct; eauto. + intros. destruct (typ_eq (type_of_chunk c1) (type_of_chunk c2)); inv H1. + apply val_has_type_normalized. destruct H2. + apply val_normalized_has_type. auto. + rewrite e. apply val_normalized_has_type. auto. +Qed. + (** * Correspondence between Csharpminor's and Cminor's environments and memory states *) (** In Csharpminor, every variable is stored in a separate memory block. @@ -125,12 +314,12 @@ Qed. to a sub-block of Cminor block [b] at offset [ofs]. A memory injection [f] defines a relation [val_inject f] between - values and a relation [mem_inject f] between memory states. - These relations, defined in file [Memory], will be used intensively + values and a relation [Mem.inject f] between memory states. + These relations will be used intensively in our proof of simulation between Csharpminor and Cminor executions. - In the remainder of this section, we define relations between - Csharpminor and Cminor environments and call stacks. *) + In this section, we define the relation between + Csharpminor and Cminor environments. *) (** Matching for a Csharpminor variable [id]. - If this variable is mapped to a Cminor local variable, the @@ -187,7 +376,7 @@ Record match_env (f: meminj) (cenv: compilenv) me_vars: forall id, match_var f id e m te sp (PMap.get id cenv); -(** The range [lo, hi] must not be empty. *) +(** [lo, hi] is a proper interval. *) me_low_high: lo <= hi; @@ -215,9 +404,16 @@ Record match_env (f: meminj) (cenv: compilenv) (i.e. allocated before the stack data for the current Cminor function). *) me_incr: forall b tb delta, - f b = Some(tb, delta) -> b < lo -> tb < sp + f b = Some(tb, delta) -> b < lo -> tb < sp; + +(** The sizes of blocks appearing in [e] agree with their types *) + me_bounds: + forall id b lv, + PTree.get id e = Some(b, lv) -> Mem.bounds m b = (0, sizeof lv) }. +Hint Resolve me_low_high. + (** Global environments match if the memory injection [f] leaves unchanged the references to global symbols and functions. *) @@ -231,72 +427,28 @@ Record match_globalenvs (f: meminj) : Prop := forall b, b < 0 -> f b = Some(b, 0) }. -(** Call stacks represent abstractly the execution state of the current - Csharpminor and Cminor functions, as well as the states of the - calling functions. A call stack is a list of frames, each frame - collecting information on the current execution state of a Csharpminor - function and its Cminor translation. *) - -Record frame : Type := - mkframe { - fr_cenv: compilenv; - fr_e: Csharpminor.env; - fr_te: env; - fr_sp: block; - fr_low: Z; - fr_high: Z - }. - -Definition callstack : Type := list frame. - -(** Matching of call stacks imply matching of environments for each of - the frames, plus matching of the global environments, plus disjointness - conditions over the memory blocks allocated for local variables - and Cminor stack data. *) - -Inductive match_callstack: meminj -> callstack -> Z -> Z -> mem -> Prop := - | mcs_nil: - forall f bound tbound m, - match_globalenvs f -> - match_callstack f nil bound tbound m - | mcs_cons: - forall f cenv e te sp lo hi cs bound tbound m, - hi <= bound -> - sp < tbound -> - match_env f cenv e m te sp lo hi -> - match_callstack f cs lo sp m -> - match_callstack f (mkframe cenv e te sp lo hi :: cs) bound tbound m. - (** The remainder of this section is devoted to showing preservation - of the [match_callstack] invariant under various assignments and memory + of the [match_en] invariant under various assignments and memory stores. First: preservation by memory stores to ``mapped'' blocks (block that have a counterpart in the Cminor execution). *) +Ltac geninv x := + let H := fresh in (generalize x; intro H; inv H). + Lemma match_env_store_mapped: forall f cenv e m1 m2 te sp lo hi chunk b ofs v, f b <> None -> - store chunk m1 b ofs v = Some m2 -> + Mem.store chunk m1 b ofs v = Some m2 -> match_env f cenv e m1 te sp lo hi -> match_env f cenv e m2 te sp lo hi. Proof. - intros. inversion H1. constructor; auto. + intros; inv H1; constructor; auto. (* vars *) - intros. generalize (me_vars0 id); intro. - inversion H2; econstructor; eauto. - rewrite <- H5. eapply load_store_other; eauto. + intros. geninv (me_vars0 id); econstructor; eauto. + rewrite <- H4. eapply Mem.load_store_other; eauto. left. congruence. -Qed. - -Lemma match_callstack_mapped: - forall f cs bound tbound m1, - match_callstack f cs bound tbound m1 -> - forall chunk b ofs v m2, - f b <> None -> - store chunk m1 b ofs v = Some m2 -> - match_callstack f cs bound tbound m2. -Proof. - induction 1; intros; econstructor; eauto. - eapply match_env_store_mapped; eauto. + (* bounds *) + intros. rewrite (Mem.bounds_store _ _ _ _ _ _ H0). eauto. Qed. (** Preservation by assignment to a Csharpminor variable that is @@ -307,27 +459,28 @@ Qed. Lemma match_env_store_local: forall f cenv e m1 m2 te sp lo hi id b chunk v tv, e!id = Some(b, Vscalar chunk) -> + Val.has_type v (type_of_chunk chunk) -> val_inject f (Val.load_result chunk v) tv -> - store chunk m1 b 0 v = Some m2 -> + Mem.store chunk m1 b 0 v = Some m2 -> match_env f cenv e m1 te sp lo hi -> match_env f cenv e m2 (PTree.set id tv te) sp lo hi. Proof. - intros. inversion H2. constructor; auto. - intros. generalize (me_vars0 id0); intro. - inversion H3; subst. + intros. inv H3. constructor; auto. + (* vars *) + intros. geninv (me_vars0 id0). (* var_local *) case (peq id id0); intro. (* the stored variable *) - subst id0. - change Csharpminor.var_kind with var_kind in H4. - rewrite H in H5. injection H5; clear H5; intros; subst b0 chunk0. + subst id0. + assert (b0 = b) by congruence. subst. + assert (chunk0 = chunk) by congruence. subst. econstructor. eauto. - eapply load_store_same; eauto. auto. + eapply Mem.load_store_same; eauto. auto. rewrite PTree.gss. reflexivity. auto. (* a different variable *) econstructor; eauto. - rewrite <- H6. eapply load_store_other; eauto. + rewrite <- H6. eapply Mem.load_store_other; eauto. rewrite PTree.gso; auto. (* var_stack_scalar *) econstructor; eauto. @@ -337,49 +490,393 @@ Proof. econstructor; eauto. (* var_global_array *) econstructor; eauto. + (* bounds *) + intros. rewrite (Mem.bounds_store _ _ _ _ _ _ H2). eauto. Qed. -Lemma match_env_store_above: - forall f cenv e m1 m2 te sp lo hi chunk b v, - store chunk m1 b 0 v = Some m2 -> - hi <= b -> +(** The [match_env] relation is preserved by any memory operation + that preserves sizes and loads from blocks in the [lo, hi] range. *) + +Lemma match_env_invariant: + forall f cenv e m1 m2 te sp lo hi, + (forall b ofs chunk v, + lo <= b < hi -> Mem.load chunk m1 b ofs = Some v -> + Mem.load chunk m2 b ofs = Some v) -> + (forall b, + lo <= b < hi -> Mem.bounds m2 b = Mem.bounds m1 b) -> match_env f cenv e m1 te sp lo hi -> match_env f cenv e m2 te sp lo hi. Proof. - intros. inversion H1; constructor; auto. - intros. generalize (me_vars0 id); intro. - inversion H2; econstructor; eauto. - rewrite <- H5. eapply load_store_other; eauto. - left. generalize (me_bounded0 _ _ _ H4). unfold block in *. omega. + intros. inv H1. constructor; eauto. + (* vars *) + intros. geninv (me_vars0 id); econstructor; eauto. + (* bounds *) + intros. rewrite H0. eauto. eauto. Qed. -Lemma match_callstack_store_above: - forall f cs bound tbound m1, - match_callstack f cs bound tbound m1 -> - forall chunk b v m2, - store chunk m1 b 0 v = Some m2 -> - bound <= b -> - match_callstack f cs bound tbound m2. +(** [match_env] is insensitive to the Cminor values of stack-allocated data. *) + +Lemma match_env_extensional: + forall f cenv e m te1 sp lo hi te2, + match_env f cenv e m te1 sp lo hi -> + (forall id chunk, cenv!!id = Var_local chunk -> te2!id = te1!id) -> + match_env f cenv e m te2 sp lo hi. Proof. - induction 1; intros; econstructor; eauto. - eapply match_env_store_above with (b := b); eauto. omega. + intros. inv H; econstructor; eauto. + intros. geninv (me_vars0 id); econstructor; eauto. + rewrite <- H5. eauto. +Qed. + +(** [match_env] and allocations *) + +Inductive alloc_condition: var_info -> var_kind -> block -> option (block * Z) -> Prop := + | alloc_cond_local: forall chunk sp, + alloc_condition (Var_local chunk) (Vscalar chunk) sp None + | alloc_cond_stack_scalar: forall chunk pos sp, + alloc_condition (Var_stack_scalar chunk pos) (Vscalar chunk) sp (Some(sp, pos)) + | alloc_cond_stack_array: forall pos sz sp, + alloc_condition (Var_stack_array pos) (Varray sz) sp (Some(sp, pos)). + +Lemma match_env_alloc_same: + forall f1 cenv e m1 te sp lo lv m2 b f2 id info tv, + match_env f1 cenv e m1 te sp lo (Mem.nextblock m1) -> + Mem.alloc m1 0 (sizeof lv) = (m2, b) -> + inject_incr f1 f2 -> + alloc_condition info lv sp (f2 b) -> + (forall b', b' <> b -> f2 b' = f1 b') -> + te!id = Some tv -> + e!id = None -> + match_env f2 (PMap.set id info cenv) (PTree.set id (b, lv) e) m2 te sp lo (Mem.nextblock m2). +Proof. + intros until tv. + intros ME ALLOC INCR ACOND OTHER TE E. +(* + assert (ALLOC_RES: b = Mem.nextblock m1) by eauto with mem. + assert (ALLOC_NEXT: Mem.nextblock m2 = Zsucc(Mem.nextblock m1)) by eauto with mem. +*) + inv ME; constructor. +(* vars *) + intros. rewrite PMap.gsspec. destruct (peq id0 id). subst id0. + (* the new var *) + inv ACOND; econstructor. + (* local *) + rewrite PTree.gss. reflexivity. + eapply Mem.load_alloc_same'; eauto. omega. simpl; omega. apply Zdivide_0. + auto. eauto. constructor. + (* stack scalar *) + rewrite PTree.gss; reflexivity. + econstructor; eauto. rewrite Int.add_commut; rewrite Int.add_zero; auto. + (* stack array *) + rewrite PTree.gss; reflexivity. + econstructor; eauto. rewrite Int.add_commut; rewrite Int.add_zero; auto. + (* the other vars *) + geninv (me_vars0 id0); econstructor. + (* local *) + rewrite PTree.gso; eauto. eapply Mem.load_alloc_other; eauto. + rewrite OTHER; auto. + exploit me_bounded0; eauto. exploit Mem.alloc_result; eauto. unfold block; omega. + eauto. eapply val_inject_incr; eauto. + (* stack scalar *) + rewrite PTree.gso; eauto. eapply val_inject_incr; eauto. + (* stack array *) + rewrite PTree.gso; eauto. eapply val_inject_incr; eauto. + (* global scalar *) + rewrite PTree.gso; auto. auto. + (* global array *) + rewrite PTree.gso; auto. +(* low high *) + exploit Mem.nextblock_alloc; eauto. unfold block in *; omega. +(* bounded *) + exploit Mem.alloc_result; eauto. intro RES. + exploit Mem.nextblock_alloc; eauto. intro NEXT. + intros until lv0. rewrite PTree.gsspec. destruct (peq id0 id); intro EQ. + inv EQ. unfold block in *; omega. + exploit me_bounded0; eauto. unfold block in *; omega. +(* inj *) + intros until lv2. repeat rewrite PTree.gsspec. + exploit Mem.alloc_result; eauto. intro RES. + destruct (peq id1 id); destruct (peq id2 id); subst; intros A1 A2 DIFF. + congruence. + inv A1. exploit me_bounded0; eauto. unfold block; omega. + inv A2. exploit me_bounded0; eauto. unfold block; omega. + eauto. +(* inv *) + intros. destruct (zeq b0 b). + subst. exists id; exists lv. apply PTree.gss. + exploit me_inv0; eauto. rewrite <- OTHER; eauto. + intros [id' [lv' A]]. exists id'; exists lv'. + rewrite PTree.gso; auto. congruence. +(* incr *) + intros. eapply me_incr0; eauto. rewrite <- OTHER; eauto. + exploit Mem.alloc_result; eauto. unfold block; omega. +(* bounds *) + intros. rewrite PTree.gsspec in H. + rewrite (Mem.bounds_alloc _ _ _ _ _ ALLOC). + destruct (peq id0 id). + inv H. apply dec_eq_true. + rewrite dec_eq_false. eauto. + apply Mem.valid_not_valid_diff with m1. + exploit me_bounded0; eauto. intros [A B]. auto. + eauto with mem. +Qed. + +Lemma match_env_alloc_other: + forall f1 cenv e m1 te sp lo hi sz m2 b f2, + match_env f1 cenv e m1 te sp lo hi -> + Mem.alloc m1 0 sz = (m2, b) -> + inject_incr f1 f2 -> + (forall b', b' <> b -> f2 b' = f1 b') -> + hi <= b -> + match f2 b with None => True | Some(b',ofs) => sp < b' end -> + match_env f2 cenv e m2 te sp lo hi. +Proof. + intros until f2; intros ME ALLOC INCR OTHER BOUND TBOUND. + inv ME. + assert (BELOW: forall id b' lv, e!id = Some(b', lv) -> b' <> b). + intros. exploit me_bounded0; eauto. exploit Mem.alloc_result; eauto. + unfold block in *; omega. + econstructor; eauto. +(* vars *) + intros. geninv (me_vars0 id); econstructor. + (* local *) + eauto. eapply Mem.load_alloc_other; eauto. + rewrite OTHER; eauto. eauto. eapply val_inject_incr; eauto. + (* stack scalar *) + eauto. eapply val_inject_incr; eauto. + (* stack array *) + eauto. eapply val_inject_incr; eauto. + (* global scalar *) + auto. auto. + (* global array *) + auto. +(* inv *) + intros. rewrite OTHER in H. eauto. + red; intro; subst b0. rewrite H in TBOUND. omegaContradiction. +(* incr *) + intros. eapply me_incr0; eauto. rewrite <- OTHER; eauto. + exploit Mem.alloc_result; eauto. unfold block in *; omega. +(* bounds *) + intros. rewrite (Mem.bounds_alloc_other _ _ _ _ _ ALLOC). eauto. + exploit me_bounded0; eauto. +Qed. + +(** [match_env] and external calls *) + +Remark inject_incr_separated_same: + forall f1 f2 m1 m1', + inject_incr f1 f2 -> inject_separated f1 f2 m1 m1' -> + forall b, Mem.valid_block m1 b -> f2 b = f1 b. +Proof. + intros. case_eq (f1 b). + intros [b' delta] EQ. apply H; auto. + intros EQ. case_eq (f2 b). + intros [b'1 delta1] EQ1. exploit H0; eauto. intros [C D]. contradiction. + auto. +Qed. + +Remark inject_incr_separated_same': + forall f1 f2 m1 m1', + inject_incr f1 f2 -> inject_separated f1 f2 m1 m1' -> + forall b b' delta, + f2 b = Some(b', delta) -> Mem.valid_block m1' b' -> f1 b = Some(b', delta). +Proof. + intros. case_eq (f1 b). + intros [b'1 delta1] EQ. exploit H; eauto. congruence. + intros. exploit H0; eauto. intros [C D]. contradiction. +Qed. + +Lemma match_env_external_call: + forall f1 cenv e m1 te sp lo hi m2 f2 m1', + match_env f1 cenv e m1 te sp lo hi -> + mem_unchanged_on (loc_unmapped f1) m1 m2 -> + inject_incr f1 f2 -> + inject_separated f1 f2 m1 m1' -> + (forall b, Mem.valid_block m1 b -> Mem.bounds m2 b = Mem.bounds m1 b) -> + hi <= Mem.nextblock m1 -> sp < Mem.nextblock m1' -> + match_env f2 cenv e m2 te sp lo hi. +Proof. + intros until m1'. intros ME UNCHANGED INCR SEPARATED BOUNDS VALID VALID'. + destruct UNCHANGED as [UNCHANGED1 UNCHANGED2]. + inversion ME. constructor; auto. +(* vars *) + intros. geninv (me_vars0 id); try (econstructor; eauto; fail). + (* local *) + econstructor. + eauto. + apply UNCHANGED2; eauto. + rewrite <- H3. eapply inject_incr_separated_same; eauto. + red. exploit me_bounded0; eauto. omega. + eauto. eauto. +(* inv *) + intros. apply me_inv0 with delta. eapply inject_incr_separated_same'; eauto. +(* incr *) + intros. + exploit inject_incr_separated_same; eauto. + instantiate (1 := b). red; omega. intros. + apply me_incr0 with b delta. congruence. auto. +(* bounds *) + intros. rewrite BOUNDS; eauto. + red. exploit me_bounded0; eauto. omega. +Qed. + +(** * Invariant on abstract call stacks *) + +(** Call stacks represent abstractly the execution state of the current + Csharpminor and Cminor functions, as well as the states of the + calling functions. A call stack is a list of frames, each frame + collecting information on the current execution state of a Csharpminor + function and its Cminor translation. *) + +Inductive frame : Type := + Frame(cenv: compilenv) + (tf: Cminor.function) + (e: Csharpminor.env) + (te: Cminor.env) + (sp: block) + (lo hi: Z). + +Definition callstack : Type := list frame. + +(** Matching of call stacks imply: +- matching of environments for each of the frames +- matching of the global environments +- separation conditions over the memory blocks allocated for C#minor local variables; +- separation conditions over the memory blocks allocated for Cminor stack data; +- freeable permissions on the parts of the Cminor stack data blocks + that are not images of C#minor local variable blocks. +*) + +Definition padding_freeable (f: meminj) (m: mem) (tm: mem) (sp: block) (sz: Z) : Prop := + forall ofs, + 0 <= ofs < sz -> + Mem.perm tm sp ofs Freeable + \/ exists b, exists delta, + f b = Some(sp, delta) + /\ Mem.low_bound m b + delta <= ofs < Mem.high_bound m b + delta. + +Inductive match_callstack (f: meminj) (m: mem) (tm: mem): + callstack -> Z -> Z -> Prop := + | mcs_nil: + forall bound tbound, + match_globalenvs f -> + match_callstack f m tm nil bound tbound + | mcs_cons: + forall cenv tf e te sp lo hi cs bound tbound + (BOUND: hi <= bound) + (TBOUND: sp < tbound) + (MENV: match_env f cenv e m te sp lo hi) + (PERM: padding_freeable f m tm sp tf.(fn_stackspace)) + (MCS: match_callstack f m tm cs lo sp), + match_callstack f m tm (Frame cenv tf e te sp lo hi :: cs) bound tbound. + +(** [match_callstack] implies [match_globalenvs]. *) + +Lemma match_callstack_match_globalenvs: + forall f m tm cs bound tbound, + match_callstack f m tm cs bound tbound -> + match_globalenvs f. +Proof. + induction 1; eauto. +Qed. + +(** We now show invariance properties for [match_callstack] that + generalize those for [match_env]. *) + +Lemma padding_freeable_invariant: + forall f1 m1 tm1 sp sz cenv e te lo hi f2 m2 tm2, + padding_freeable f1 m1 tm1 sp sz -> + match_env f1 cenv e m1 te sp lo hi -> + (forall ofs, Mem.perm tm1 sp ofs Freeable -> Mem.perm tm2 sp ofs Freeable) -> + (forall b, b < hi -> Mem.bounds m2 b = Mem.bounds m1 b) -> + (forall b, b < hi -> f2 b = f1 b) -> + padding_freeable f2 m2 tm2 sp sz. +Proof. + intros; red; intros. + exploit H; eauto. intros [A | [b [delta [A B]]]]. + left; auto. + exploit me_inv; eauto. intros [id [lv C]]. + exploit me_bounded; eauto. intros [D E]. + right; exists b; exists delta. split. + rewrite H3; auto. + rewrite H2; auto. +Qed. + +Lemma match_callstack_store_mapped: + forall f m tm chunk b b' delta ofs ofs' v tv m' tm', + f b = Some(b', delta) -> + Mem.store chunk m b ofs v = Some m' -> + Mem.store chunk tm b' ofs' tv = Some tm' -> + forall cs lo hi, + match_callstack f m tm cs lo hi -> + match_callstack f m' tm' cs lo hi. +Proof. + induction 4. + constructor; auto. + constructor; auto. + eapply match_env_store_mapped; eauto. congruence. + eapply padding_freeable_invariant; eauto. + intros; eauto with mem. + intros. eapply Mem.bounds_store; eauto. +Qed. + +Lemma match_callstack_storev_mapped: + forall f m tm chunk a ta v tv m' tm', + val_inject f a ta -> + Mem.storev chunk m a v = Some m' -> + Mem.storev chunk tm ta tv = Some tm' -> + forall cs lo hi, + match_callstack f m tm cs lo hi -> + match_callstack f m' tm' cs lo hi. +Proof. + intros. destruct a; simpl in H0; try discriminate. + inv H. simpl in H1. + eapply match_callstack_store_mapped; eauto. +Qed. + +Lemma match_callstack_invariant: + forall f m tm cs bound tbound, + match_callstack f m tm cs bound tbound -> + forall m' tm', + (forall cenv e te sp lo hi, + hi <= bound -> + match_env f cenv e m te sp lo hi -> + match_env f cenv e m' te sp lo hi) -> + (forall b, + b < bound -> Mem.bounds m' b = Mem.bounds m b) -> + (forall b ofs p, + b < tbound -> Mem.perm tm b ofs p -> Mem.perm tm' b ofs p) -> + match_callstack f m' tm' cs bound tbound. +Proof. + induction 1; intros. + constructor; auto. + constructor; auto. + eapply padding_freeable_invariant; eauto. + intros. apply H1. omega. eapply IHmatch_callstack; eauto. - inversion H1. omega. + intros. eapply H0; eauto. inv MENV; omega. + intros. apply H1; auto. inv MENV; omega. + intros. apply H2; auto. omega. Qed. Lemma match_callstack_store_local: - forall f cenv e te sp lo hi cs bound tbound m1 m2 id b chunk v tv, + forall f cenv e te sp lo hi cs bound tbound m1 m2 tm tf id b chunk v tv, e!id = Some(b, Vscalar chunk) -> + Val.has_type v (type_of_chunk chunk) -> val_inject f (Val.load_result chunk v) tv -> - store chunk m1 b 0 v = Some m2 -> - match_callstack f (mkframe cenv e te sp lo hi :: cs) bound tbound m1 -> - match_callstack f (mkframe cenv e (PTree.set id tv te) sp lo hi :: cs) bound tbound m2. + Mem.store chunk m1 b 0 v = Some m2 -> + match_callstack f m1 tm (Frame cenv tf e te sp lo hi :: cs) bound tbound -> + match_callstack f m2 tm (Frame cenv tf e (PTree.set id tv te) sp lo hi :: cs) bound tbound. Proof. - intros. inversion H2. constructor; auto. + intros. inv H3. constructor; auto. eapply match_env_store_local; eauto. - eapply match_callstack_store_above; eauto. - inversion H16. - generalize (me_bounded0 _ _ _ H). omega. + eapply padding_freeable_invariant; eauto. + intros. eapply Mem.bounds_store; eauto. + eapply match_callstack_invariant; eauto. + intros. apply match_env_invariant with m1; auto. + intros. rewrite <- H6. eapply Mem.load_store_other; eauto. + left. inv MENV. exploit me_bounded0; eauto. unfold block in *; omega. + intros. eapply Mem.bounds_store; eauto. + intros. eapply Mem.bounds_store; eauto. Qed. (** A variant of [match_callstack_store_local] where the Cminor environment @@ -387,436 +884,385 @@ Qed. In this case, [match_callstack] is preserved even if no assignment takes place on the Cminor side. *) -Lemma match_env_extensional: - forall f cenv e m te1 sp lo hi, - match_env f cenv e m te1 sp lo hi -> - forall te2, - (forall id, te2!id = te1!id) -> - match_env f cenv e m te2 sp lo hi. -Proof. - induction 1; intros; econstructor; eauto. - intros. generalize (me_vars0 id); intro. - inversion H0; econstructor; eauto. - rewrite H. auto. -Qed. - Lemma match_callstack_store_local_unchanged: - forall f cenv e te sp lo hi cs bound tbound m1 m2 id b chunk v tv, + forall f cenv e te sp lo hi cs bound tbound m1 m2 id b chunk v tv tf tm, e!id = Some(b, Vscalar chunk) -> + Val.has_type v (type_of_chunk chunk) -> val_inject f (Val.load_result chunk v) tv -> - store chunk m1 b 0 v = Some m2 -> + Mem.store chunk m1 b 0 v = Some m2 -> te!id = Some tv -> - match_callstack f (mkframe cenv e te sp lo hi :: cs) bound tbound m1 -> - match_callstack f (mkframe cenv e te sp lo hi :: cs) bound tbound m2. + match_callstack f m1 tm (Frame cenv tf e te sp lo hi :: cs) bound tbound -> + match_callstack f m2 tm (Frame cenv tf e te sp lo hi :: cs) bound tbound. Proof. - intros. inversion H3. constructor; auto. - apply match_env_extensional with (PTree.set id tv te). - eapply match_env_store_local; eauto. + intros. exploit match_callstack_store_local; eauto. intro MCS. + inv MCS. constructor; auto. eapply match_env_extensional; eauto. intros. rewrite PTree.gsspec. case (peq id0 id); intros. congruence. auto. - eapply match_callstack_store_above; eauto. - inversion H17. - generalize (me_bounded0 _ _ _ H). omega. Qed. -(** Preservation of [match_callstack] by freeing all blocks allocated - for local variables at function entry (on the Csharpminor side). *) - Lemma match_callstack_incr_bound: - forall f cs bound tbound m, - match_callstack f cs bound tbound m -> - forall bound' tbound', + forall f m tm cs bound tbound bound' tbound', + match_callstack f m tm cs bound tbound -> bound <= bound' -> tbound <= tbound' -> - match_callstack f cs bound' tbound' m. + match_callstack f m tm cs bound' tbound'. Proof. intros. inversion H; constructor; auto. omega. omega. Qed. -Lemma load_freelist: - forall fbl chunk m b ofs, - (forall b', In b' fbl -> b' <> b) -> - load chunk (free_list m fbl) b ofs = load chunk m b ofs. -Proof. - induction fbl; simpl; intros. - auto. - rewrite load_free. apply IHfbl. - intros. apply H. tauto. - apply sym_not_equal. apply H. tauto. -Qed. - -Lemma match_env_freelist: - forall f cenv e m te sp lo hi fbl, - match_env f cenv e m te sp lo hi -> - (forall b, In b fbl -> hi <= b) -> - match_env f cenv e (free_list m fbl) te sp lo hi. -Proof. - intros. inversion H. econstructor; eauto. - intros. generalize (me_vars0 id); intro. - inversion H1; econstructor; eauto. - rewrite <- H4. apply load_freelist. - intros. generalize (H0 _ H8); intro. - generalize (me_bounded0 _ _ _ H3). unfold block; omega. -Qed. - -Lemma match_callstack_freelist_rec: - forall f cs bound tbound m, - match_callstack f cs bound tbound m -> - forall fbl, - (forall b, In b fbl -> bound <= b) -> - match_callstack f cs bound tbound (free_list m fbl). -Proof. - induction 1; intros; constructor; auto. - eapply match_env_freelist; eauto. - intros. generalize (H3 _ H4). omega. - apply IHmatch_callstack. intros. - generalize (H3 _ H4). inversion H1. omega. -Qed. - -Lemma blocks_of_env_charact: - forall b e, - In b (blocks_of_env e) <-> - exists id, exists lv, e!id = Some(b, lv). -Proof. - unfold blocks_of_env. - set (f := fun id_b_lv : positive * (block * var_kind) => - let (_, y) := id_b_lv in let (b0, _) := y in b0). - intros; split; intros. - exploit list_in_map_inv; eauto. intros [[id [b' lv]] [A B]]. - simpl in A. subst b'. exists id; exists lv. apply PTree.elements_complete. auto. - destruct H as [id [lv EQ]]. - change b with (f (id, (b, lv))). apply List.in_map. - apply PTree.elements_correct. auto. -Qed. - -Lemma match_callstack_freelist: - forall f cenv e te sp lo hi cs bound tbound m tm, - mem_inject f m tm -> - match_callstack f (mkframe cenv e te sp lo hi :: cs) bound tbound m -> - match_callstack f cs bound tbound (free_list m (blocks_of_env e)) - /\ mem_inject f (free_list m (blocks_of_env e)) (free tm sp). -Proof. - intros. inv H0. inv H14. split. - apply match_callstack_incr_bound with lo sp. - apply match_callstack_freelist_rec. auto. - intros. rewrite blocks_of_env_charact in H0. - destruct H0 as [id [lv EQ]]. exploit me_bounded0; eauto. omega. - omega. omega. - apply Mem.free_inject; auto. - intros. rewrite blocks_of_env_charact. eauto. -Qed. - -(** Preservation of [match_callstack] when allocating a block for - a local variable on the Csharpminor side. *) +(** Preservation of [match_callstack] by freeing all blocks allocated + for local variables at function entry (on the Csharpminor side) + and simultaneously freeing the Cminor stack data block. *) -Lemma load_from_alloc_is_undef: - forall m1 chunk m2 b, - alloc m1 0 (size_chunk chunk) = (m2, b) -> - load chunk m2 b 0 = Some Vundef. +Lemma in_blocks_of_env: + forall e id b lv, + e!id = Some(b, lv) -> In (b, 0, sizeof lv) (blocks_of_env e). Proof. - intros. - assert (exists v, load chunk m2 b 0 = Some v). - apply valid_access_load. - eapply valid_access_alloc_same; eauto. omega. omega. apply Zdivide_0. - destruct H0 as [v LOAD]. rewrite LOAD. decEq. - eapply load_alloc_same; eauto. + unfold blocks_of_env; intros. + change (b, 0, sizeof lv) with (block_of_binding (id, (b, lv))). + apply List.in_map. apply PTree.elements_correct. auto. Qed. -Lemma match_env_alloc_same: - forall m1 lv m2 b info f1 cenv1 e1 te sp lo id data tv, - alloc m1 0 (sizeof lv) = (m2, b) -> - match info with - | Var_local chunk => data = None /\ lv = Vscalar chunk - | Var_stack_scalar chunk pos => data = Some(sp, pos) /\ lv = Vscalar chunk - | Var_stack_array pos => data = Some(sp, pos) /\ exists sz, lv = Varray sz - | Var_global_scalar chunk => False - | Var_global_array => False - end -> - match_env f1 cenv1 e1 m1 te sp lo m1.(nextblock) -> - te!id = Some tv -> - e1!id = None -> - let f2 := extend_inject b data f1 in - let cenv2 := PMap.set id info cenv1 in - let e2 := PTree.set id (b, lv) e1 in - inject_incr f1 f2 -> - match_env f2 cenv2 e2 m2 te sp lo m2.(nextblock). +Lemma in_blocks_of_env_inv: + forall b lo hi e, + In (b, lo, hi) (blocks_of_env e) -> + exists id, exists lv, e!id = Some(b, lv) /\ lo = 0 /\ hi = sizeof lv. Proof. - intros. - assert (b = m1.(nextblock)). - injection H; intros. auto. - assert (m2.(nextblock) = Zsucc m1.(nextblock)). - injection H; intros. rewrite <- H7; reflexivity. - inversion H1. constructor. - (* me_vars *) - intros id0. unfold cenv2. rewrite PMap.gsspec. case (peq id0 id); intros. - (* same var *) - subst id0. destruct info. - (* info = Var_local chunk *) - elim H0; intros. - apply match_var_local with b Vundef tv. - unfold e2; rewrite PTree.gss. congruence. - eapply load_from_alloc_is_undef; eauto. - rewrite H8 in H. unfold sizeof in H. eauto. - unfold f2, extend_inject, eq_block. rewrite zeq_true. auto. - auto. - constructor. - (* info = Var_stack_scalar chunk ofs *) - elim H0; intros. - apply match_var_stack_scalar with b. - unfold e2; rewrite PTree.gss. congruence. - eapply val_inject_ptr. - unfold f2, extend_inject, eq_block. rewrite zeq_true. eauto. - rewrite Int.add_commut. rewrite Int.add_zero. auto. - (* info = Var_stack_array z *) - elim H0; intros A [sz B]. - apply match_var_stack_array with sz b. - unfold e2; rewrite PTree.gss. congruence. - eapply val_inject_ptr. - unfold f2, extend_inject, eq_block. rewrite zeq_true. eauto. - rewrite Int.add_commut. rewrite Int.add_zero. auto. - (* info = Var_global *) - contradiction. - contradiction. - (* other vars *) - generalize (me_vars0 id0); intros. - inversion H7. - eapply match_var_local with (v := v); eauto. - unfold e2; rewrite PTree.gso; eauto. - eapply load_alloc_other; eauto. - unfold f2, extend_inject, eq_block; rewrite zeq_false; auto. - generalize (me_bounded0 _ _ _ H9). unfold block in *; omega. - econstructor; eauto. - unfold e2; rewrite PTree.gso; eauto. - econstructor; eauto. - unfold e2; rewrite PTree.gso; eauto. - econstructor; eauto. - unfold e2; rewrite PTree.gso; eauto. - econstructor; eauto. - unfold e2; rewrite PTree.gso; eauto. - (* lo <= hi *) - unfold block in *; omega. - (* me_bounded *) - intros until lv0. unfold e2; rewrite PTree.gsspec. - case (peq id0 id); intros. - subst id0. inversion H7. subst b0. unfold block in *; omega. - generalize (me_bounded0 _ _ _ H7). rewrite H6. omega. - (* me_inj *) - intros until lv2. unfold e2; repeat rewrite PTree.gsspec. - case (peq id1 id); case (peq id2 id); intros. - congruence. - inversion H7. subst b1. rewrite H5. - generalize (me_bounded0 _ _ _ H8). unfold block; omega. - inversion H8. subst b2. rewrite H5. - generalize (me_bounded0 _ _ _ H7). unfold block; omega. - eauto. - (* me_inv *) - intros until delta. unfold f2, extend_inject, eq_block. - case (zeq b0 b); intros. - subst b0. exists id; exists lv. unfold e2. apply PTree.gss. - exploit me_inv0; eauto. intros [id' [lv' EQ]]. - exists id'; exists lv'. unfold e2. rewrite PTree.gso; auto. - congruence. - (* me_incr *) - intros until delta. unfold f2, extend_inject, eq_block. - case (zeq b0 b); intros. - subst b0. unfold block in *; omegaContradiction. - eauto. + unfold blocks_of_env; intros. + exploit list_in_map_inv; eauto. intros [[id [b' lv]] [A B]]. + unfold block_of_binding in A. inv A. + exists id; exists lv; intuition. apply PTree.elements_complete. auto. Qed. -Lemma match_env_alloc_other: - forall f1 cenv e m1 m2 te sp lo hi chunk b data, - alloc m1 0 (sizeof chunk) = (m2, b) -> - match data with None => True | Some (b', delta') => sp < b' end -> - hi <= m1.(nextblock) -> - match_env f1 cenv e m1 te sp lo hi -> - let f2 := extend_inject b data f1 in - inject_incr f1 f2 -> - match_env f2 cenv e m2 te sp lo hi. +(* +Lemma free_list_perm: + forall l m m', + Mem.free_list m l = Some m' -> + forall b ofs p, + Mem.perm m' b ofs p -> Mem.perm m b ofs p. Proof. - intros. - assert (b = m1.(nextblock)). injection H; auto. - rewrite <- H4 in H1. - inversion H2. constructor; auto. - (* me_vars *) - intros. generalize (me_vars0 id); intro. - inversion H5. - eapply match_var_local with (v := v); eauto. - eapply load_alloc_other; eauto. - unfold f2, extend_inject, eq_block. rewrite zeq_false. auto. - generalize (me_bounded0 _ _ _ H7). unfold block in *; omega. - econstructor; eauto. - econstructor; eauto. - econstructor; eauto. - econstructor; eauto. - (* me_bounded *) - intros until delta. unfold f2, extend_inject, eq_block. - case (zeq b0 b); intros. rewrite H5 in H0. omegaContradiction. - eauto. - (* me_incr *) - intros until delta. unfold f2, extend_inject, eq_block. - case (zeq b0 b); intros. subst b0. omegaContradiction. - eauto. + induction l; simpl; intros. + inv H; auto. + revert H. destruct a as [[b' lo'] hi']. + caseEq (Mem.free m b' lo' hi'); try congruence. + intros m1 FREE1 FREE2. + eauto with mem. Qed. +*) -Lemma match_callstack_alloc_other: - forall f1 cs bound tbound m1, - match_callstack f1 cs bound tbound m1 -> - forall lv m2 b data, - alloc m1 0 (sizeof lv) = (m2, b) -> - match data with None => True | Some (b', delta') => tbound <= b' end -> - bound <= m1.(nextblock) -> - let f2 := extend_inject b data f1 in +Lemma match_callstack_freelist: + forall f cenv tf e te sp lo hi cs m m' tm, + Mem.inject f m tm -> + Mem.free_list m (blocks_of_env e) = Some m' -> + match_callstack f m tm (Frame cenv tf e te sp lo hi :: cs) (Mem.nextblock m) (Mem.nextblock tm) -> + exists tm', + Mem.free tm sp 0 tf.(fn_stackspace) = Some tm' + /\ match_callstack f m' tm' cs (Mem.nextblock m') (Mem.nextblock tm') + /\ Mem.inject f m' tm'. +Proof. + intros until tm; intros INJ FREELIST MCS. inv MCS. inv MENV. + assert ({tm' | Mem.free tm sp 0 (fn_stackspace tf) = Some tm'}). + apply Mem.range_perm_free. + red; intros. + exploit PERM; eauto. intros [A | [b [delta [A B]]]]. + auto. + exploit me_inv0; eauto. intros [id [lv C]]. + exploit me_bounds0; eauto. intro D. rewrite D in B; simpl in B. + assert (Mem.range_perm m b 0 (sizeof lv) Freeable). + eapply free_list_freeable; eauto. eapply in_blocks_of_env; eauto. + replace ofs with ((ofs - delta) + delta) by omega. + eapply Mem.perm_inject; eauto. apply H0. omega. + destruct X as [tm' FREE]. + exploit nextblock_freelist; eauto. intro NEXT. + exploit Mem.nextblock_free; eauto. intro NEXT'. + exists tm'. split. auto. split. + rewrite NEXT; rewrite NEXT'. + apply match_callstack_incr_bound with lo sp; try omega. + apply match_callstack_invariant with m tm; auto. + intros. apply match_env_invariant with m; auto. + intros. rewrite <- H2. eapply load_freelist; eauto. + intros. exploit in_blocks_of_env_inv; eauto. + intros [id [lv [A [B C]]]]. + exploit me_bounded0; eauto. unfold block; omega. + intros. eapply bounds_freelist; eauto. + intros. eapply bounds_freelist; eauto. + intros. eapply Mem.perm_free_1; eauto. left; unfold block; omega. + eapply Mem.free_inject; eauto. + intros. exploit me_inv0; eauto. intros [id [lv A]]. + exists 0; exists (sizeof lv); split. + eapply in_blocks_of_env; eauto. + exploit me_bounds0; eauto. intro B. + exploit Mem.perm_in_bounds; eauto. rewrite B; simpl. auto. +Qed. + +(** Preservation of [match_callstack] by allocations. *) + +Lemma match_callstack_alloc_below: + forall f1 m1 tm sz m2 b f2, + Mem.alloc m1 0 sz = (m2, b) -> inject_incr f1 f2 -> - match_callstack f2 cs bound tbound m2. + (forall b', b' <> b -> f2 b' = f1 b') -> + forall cs bound tbound, + match_callstack f1 m1 tm cs bound tbound -> + bound <= b -> + match f2 b with None => True | Some(b',ofs) => tbound <= b' end -> + match_callstack f2 m2 tm cs bound tbound. Proof. - induction 1; intros. + induction 4; intros. constructor. - inversion H. constructor. - intros. auto. - intros. elim (mg_symbols0 _ _ H4); intros. - split; auto. elim (H3 b0); intros; congruence. - intros. generalize (mg_functions0 _ H4). elim (H3 b0); congruence. - constructor. auto. auto. - unfold f2; eapply match_env_alloc_other; eauto. - destruct data; auto. destruct p. omega. omega. - unfold f2; eapply IHmatch_callstack; eauto. - destruct data; auto. destruct p. omega. - inversion H1; omega. + inv H2. constructor. + intros. exploit mg_symbols0; eauto. intros [A B]. auto. + intros. rewrite H1; auto. + exploit Mem.alloc_result; eauto. + generalize (Mem.nextblock_pos m1). + unfold block; omega. + constructor; auto. + eapply match_env_alloc_other; eauto. omega. destruct (f2 b); auto. destruct p; omega. + eapply padding_freeable_invariant; eauto. + intros. eapply Mem.bounds_alloc_other; eauto. unfold block; omega. + intros. apply H1. unfold block; omega. + apply IHmatch_callstack. + inv MENV; omega. + destruct (f2 b); auto. destruct p; omega. Qed. Lemma match_callstack_alloc_left: - forall m1 lv m2 b info f1 cenv1 e1 te sp lo id data cs tv tbound, - alloc m1 0 (sizeof lv) = (m2, b) -> - match info with - | Var_local chunk => data = None /\ lv = Vscalar chunk - | Var_stack_scalar chunk pos => data = Some(sp, pos) /\ lv = Vscalar chunk - | Var_stack_array pos => data = Some(sp, pos) /\ exists sz, lv = Varray sz - | Var_global_scalar chunk => False - | Var_global_array => False - end -> - match_callstack f1 (mkframe cenv1 e1 te sp lo m1.(nextblock) :: cs) m1.(nextblock) tbound m1 -> - te!id = Some tv -> - e1!id = None -> - let f2 := extend_inject b data f1 in - let cenv2 := PMap.set id info cenv1 in - let e2 := PTree.set id (b, lv) e1 in + forall f1 m1 tm cenv tf e te sp lo cs lv m2 b f2 info id tv, + match_callstack f1 m1 tm + (Frame cenv tf e te sp lo (Mem.nextblock m1) :: cs) + (Mem.nextblock m1) (Mem.nextblock tm) -> + Mem.alloc m1 0 (sizeof lv) = (m2, b) -> inject_incr f1 f2 -> - match_callstack f2 (mkframe cenv2 e2 te sp lo m2.(nextblock) :: cs) m2.(nextblock) tbound m2. -Proof. - intros. inversion H1. constructor. omega. auto. - unfold f2, cenv2, e2. eapply match_env_alloc_same; eauto. - unfold f2; eapply match_callstack_alloc_other; eauto. - destruct info. - elim H0; intros. rewrite H20. auto. - elim H0; intros. rewrite H20. omega. - elim H0; intros. rewrite H20. omega. - contradiction. - contradiction. - inversion H18; omega. + alloc_condition info lv sp (f2 b) -> + (forall b', b' <> b -> f2 b' = f1 b') -> + te!id = Some tv -> + e!id = None -> + match_callstack f2 m2 tm + (Frame (PMap.set id info cenv) tf (PTree.set id (b, lv) e) te sp lo (Mem.nextblock m2) :: cs) + (Mem.nextblock m2) (Mem.nextblock tm). +Proof. + intros until tv; intros MCS ALLOC INCR ACOND OTHER TE E. + inv MCS. + exploit Mem.alloc_result; eauto. intro RESULT. + exploit Mem.nextblock_alloc; eauto. intro NEXT. + constructor. + omega. auto. + eapply match_env_alloc_same; eauto. + eapply padding_freeable_invariant; eauto. + intros. eapply Mem.bounds_alloc_other; eauto. unfold block in *; omega. + intros. apply OTHER. unfold block in *; omega. + eapply match_callstack_alloc_below; eauto. + inv MENV. unfold block in *; omega. + inv ACOND. auto. omega. omega. Qed. Lemma match_callstack_alloc_right: - forall f cs bound tm1 m tm2 lo hi b, - alloc tm1 lo hi = (tm2, b) -> - match_callstack f cs bound tm1.(nextblock) m -> - match_callstack f cs bound tm2.(nextblock) m. -Proof. - intros. eapply match_callstack_incr_bound; eauto. omega. - injection H; intros. rewrite <- H2; simpl. omega. -Qed. - -Lemma match_env_alloc: - forall m1 l h m2 b tm1 tm2 tb f1 ce e te sp lo hi, - alloc m1 l h = (m2, b) -> - alloc tm1 l h = (tm2, tb) -> - match_env f1 ce e m1 te sp lo hi -> - hi <= m1.(nextblock) -> - sp < tm1.(nextblock) -> - let f2 := extend_inject b (Some(tb, 0)) f1 in - inject_incr f1 f2 -> - match_env f2 ce e m2 te sp lo hi. + forall f m tm cs tf sp tm' te, + match_callstack f m tm cs (Mem.nextblock m) (Mem.nextblock tm) -> + Mem.alloc tm 0 tf.(fn_stackspace) = (tm', sp) -> + Mem.inject f m tm -> + match_callstack f m tm' + (Frame gce tf empty_env te sp (Mem.nextblock m) (Mem.nextblock m) :: cs) + (Mem.nextblock m) (Mem.nextblock tm'). Proof. + intros. + exploit Mem.alloc_result; eauto. intro RES. + exploit Mem.nextblock_alloc; eauto. intro NEXT. + constructor. omega. unfold block in *; omega. +(* match env *) + constructor. +(* vars *) + intros. generalize (global_compilenv_charact id); intro. + destruct (gce!!id); try contradiction. + constructor. apply PTree.gempty. auto. + constructor. apply PTree.gempty. +(* low high *) + omega. +(* bounded *) + intros. rewrite PTree.gempty in H2. congruence. +(* inj *) + intros. rewrite PTree.gempty in H2. congruence. +(* inv *) intros. - assert (BEQ: b = m1.(nextblock)). injection H; auto. - assert (TBEQ: tb = tm1.(nextblock)). injection H0; auto. - inversion H1. constructor; auto. - (* me_vars *) - intros. generalize (me_vars0 id); intro. inversion H5. - (* var_local *) - eapply match_var_local with (v := v); eauto. - eapply load_alloc_other; eauto. - generalize (me_bounded0 _ _ _ H7). intro. - unfold f2, extend_inject. case (zeq b0 b); intro. - subst b0. rewrite BEQ in H12. omegaContradiction. - auto. - (* var_stack_scalar *) - econstructor; eauto. - (* var_stack_array *) - econstructor; eauto. - (* var_global_scalar *) - econstructor; eauto. - (* var_global_array *) - econstructor; eauto. - (* me_bounded *) - intros until delta. unfold f2, extend_inject. case (zeq b0 b); intro. - intro. injection H5; clear H5; intros. - rewrite H6 in TBEQ. rewrite TBEQ in H3. omegaContradiction. - eauto. - (* me_inj *) - intros until delta. unfold f2, extend_inject. case (zeq b0 b); intros. - injection H5; clear H5; intros; subst b0 tb0 delta. - rewrite BEQ in H6. omegaContradiction. - eauto. -Qed. - -Lemma match_callstack_alloc_rec: - forall f1 cs bound tbound m1, - match_callstack f1 cs bound tbound m1 -> - forall l h m2 b tm1 tm2 tb, - alloc m1 l h = (m2, b) -> - alloc tm1 l h = (tm2, tb) -> - bound <= m1.(nextblock) -> - tbound <= tm1.(nextblock) -> - let f2 := extend_inject b (Some(tb, 0)) f1 in - inject_incr f1 f2 -> - match_callstack f2 cs bound tbound m2. + assert (sp <> sp). apply Mem.valid_not_valid_diff with tm. + eapply Mem.valid_block_inject_2; eauto. eauto with mem. + tauto. +(* incr *) + intros. rewrite RES. change (Mem.valid_block tm tb). + eapply Mem.valid_block_inject_2; eauto. +(* bounds *) + unfold empty_env; intros. rewrite PTree.gempty in H2. congruence. +(* padding freeable *) + red; intros. left. eapply Mem.perm_alloc_2; eauto. +(* previous call stack *) + rewrite RES. apply match_callstack_invariant with m tm; auto. + intros. eapply Mem.perm_alloc_1; eauto. +Qed. + +(** Decidability of the predicate "this is not a padding location" *) + +Definition is_reachable (f: meminj) (m: mem) (sp: block) (ofs: Z) : Prop := + exists b, exists delta, + f b = Some(sp, delta) + /\ Mem.low_bound m b + delta <= ofs < Mem.high_bound m b + delta. + +Lemma is_reachable_dec: + forall f cenv e m te sp lo hi ofs, + match_env f cenv e m te sp lo hi -> + {is_reachable f m sp ofs} + {~is_reachable f m sp ofs}. Proof. - induction 1; intros. - constructor. - inversion H. constructor. - intros. elim (mg_symbols0 _ _ H5); intros. - split; auto. elim (H4 b0); intros; congruence. - intros. generalize (mg_functions0 _ H5). elim (H4 b0); congruence. - constructor. auto. auto. - unfold f2. eapply match_env_alloc; eauto. omega. omega. - unfold f2; eapply IHmatch_callstack; eauto. - inversion H1; omega. - omega. -Qed. - -Lemma match_callstack_alloc: - forall f1 cs m1 tm1 l h m2 b tm2 tb, - match_callstack f1 cs m1.(nextblock) tm1.(nextblock) m1 -> - alloc m1 l h = (m2, b) -> - alloc tm1 l h = (tm2, tb) -> - let f2 := extend_inject b (Some(tb, 0)) f1 in + intros. + set (P := fun (b: block) => + match f b with + | None => False + | Some(b', delta) => + b' = sp /\ Mem.low_bound m b + delta <= ofs < Mem.high_bound m b + delta + end). + assert ({forall b, Intv.In b (lo, hi) -> ~P b} + {exists b, Intv.In b (lo, hi) /\ P b}). + apply Intv.forall_dec. intro b. unfold P. + destruct (f b) as [[b' delta] | ]. + destruct (eq_block b' sp). + destruct (zle (Mem.low_bound m b + delta) ofs). + destruct (zlt ofs (Mem.high_bound m b + delta)). + right; auto. + left; intuition. + left; intuition. + left; intuition. + left; intuition. + inv H. destruct H0. + right; red; intros [b [delta [A [B C]]]]. + elim (n b). + exploit me_inv0; eauto. intros [id [lv D]]. exploit me_bounded0; eauto. + red. rewrite A. auto. + left. destruct e0 as [b [A B]]. red in B; revert B. + case_eq (f b). intros [b' delta] EQ [C [D E]]. subst b'. + exists b; exists delta. auto. + tauto. +Qed. + +(** Preservation of [match_callstack] by external calls. *) + +Lemma match_callstack_external_call: + forall f1 f2 m1 m2 m1' m2', + mem_unchanged_on (loc_unmapped f1) m1 m2 -> + mem_unchanged_on (loc_out_of_reach f1 m1) m1' m2' -> inject_incr f1 f2 -> - match_callstack f2 cs m2.(nextblock) tm2.(nextblock) m2. + inject_separated f1 f2 m1 m1' -> + (forall b, Mem.valid_block m1 b -> Mem.bounds m2 b = Mem.bounds m1 b) -> + forall cs bound tbound, + match_callstack f1 m1 m1' cs bound tbound -> + bound <= Mem.nextblock m1 -> tbound <= Mem.nextblock m1' -> + match_callstack f2 m2 m2' cs bound tbound. +Proof. + intros until m2'. + intros UNMAPPED OUTOFREACH INCR SEPARATED BOUNDS. + destruct OUTOFREACH as [OUTOFREACH1 OUTOFREACH2]. + induction 1; intros; constructor. +(* base case *) + constructor; intros. + exploit mg_symbols; eauto. intros [A B]. auto. + replace (f2 b) with (f1 b). eapply mg_functions; eauto. + symmetry. eapply inject_incr_separated_same; eauto. + red. generalize (Mem.nextblock_pos m1); omega. +(* inductive case *) + auto. auto. + eapply match_env_external_call; eauto. omega. omega. + (* padding-freeable *) + red; intros. + destruct (is_reachable_dec _ _ _ _ _ _ _ _ ofs MENV). + destruct i as [b [delta [A B]]]. + right; exists b; exists delta; split. + apply INCR; auto. rewrite BOUNDS. auto. + exploit me_inv; eauto. intros [id [lv C]]. + exploit me_bounded; eauto. intros. red; omega. + exploit PERM; eauto. intros [A|A]; try contradiction. left. + apply OUTOFREACH1; auto. red; intros. + assert ((ofs < Mem.low_bound m1 b0 + delta \/ ofs >= Mem.high_bound m1 b0 + delta) + \/ Mem.low_bound m1 b0 + delta <= ofs < Mem.high_bound m1 b0 + delta) + by omega. destruct H4; auto. + elim n. exists b0; exists delta; auto. + (* induction *) + eapply IHmatch_callstack; eauto. inv MENV; omega. omega. +Qed. + +Remark external_call_nextblock_incr: + forall ef vargs m1 t vres m2, + external_call ef vargs m1 t vres m2 -> + Mem.nextblock m1 <= Mem.nextblock m2. Proof. - intros. unfold f2 in *. - apply match_callstack_incr_bound with m1.(nextblock) tm1.(nextblock). - eapply match_callstack_alloc_rec; eauto. omega. omega. - injection H0; intros; subst m2; simpl; omega. - injection H1; intros; subst tm2; simpl; omega. + intros. + generalize (external_call_valid_block _ _ _ _ _ _ (Mem.nextblock m1 - 1) H). + unfold Mem.valid_block. omega. Qed. -(** [match_callstack] implies [match_globalenvs]. *) +(** * Soundness of chunk and type inference. *) -Lemma match_callstack_match_globalenvs: - forall f cs bound tbound m, - match_callstack f cs bound tbound m -> - match_globalenvs f. +Lemma load_normalized: + forall chunk m b ofs v, + Mem.load chunk m b ofs = Some v -> val_normalized v chunk. Proof. - induction 1; eauto. + intros. + exploit Mem.load_type; eauto. intro TY. + exploit Mem.load_cast; eauto. intro CST. + red. destruct chunk; destruct v; simpl in *; auto; contradiction. +Qed. + +Lemma chunktype_expr_correct: + forall f m tm cenv tf e te sp lo hi cs bound tbound, + match_callstack f m tm (Frame cenv tf e te sp lo hi :: cs) bound tbound -> + forall a v, + Csharpminor.eval_expr gve e m a v -> + forall chunk (CTE: chunktype_expr cenv a = OK chunk), + val_normalized v chunk. +Proof. + intros until tbound; intro MCS. induction 1; intros; try (monadInv CTE). +(* var *) + assert (chunk0 = chunk). + unfold chunktype_expr in CTE. + inv MCS. inv MENV. generalize (me_vars0 id); intro MV. + inv MV; rewrite <- H1 in CTE; monadInv CTE; inv H; try congruence. + unfold gve in H6. simpl in H6. congruence. + subst chunk0. + inv H; exploit load_normalized; eauto. unfold val_normalized; auto. +(* const *) + eapply chunktype_const_correct; eauto. +(* unop *) + eapply chunktype_unop_correct; eauto. +(* binop *) + eapply chunktype_binop_correct; eauto. +(* load *) + destruct v1; simpl in H0; try discriminate. + eapply load_normalized; eauto. +(* cond *) + eapply chunktype_merge_correct; eauto. + destruct vb1; eauto. +Qed. + +Lemma type_expr_correct: + forall f m tm cenv tf e te sp lo hi cs bound tbound, + match_callstack f m tm (Frame cenv tf e te sp lo hi :: cs) bound tbound -> + forall a v ty, + Csharpminor.eval_expr gve e m a v -> + type_expr cenv a = OK ty -> + Val.has_type v ty. +Proof. + intros. monadInv H1. apply val_normalized_has_type. + eapply chunktype_expr_correct; eauto. +Qed. + +Lemma type_exprlist_correct: + forall f m tm cenv tf e te sp lo hi cs bound tbound, + match_callstack f m tm (Frame cenv tf e te sp lo hi :: cs) bound tbound -> + forall al vl tyl, + Csharpminor.eval_exprlist gve e m al vl -> + type_exprlist cenv al = OK tyl -> + Val.has_type_list vl tyl. +Proof. + intros. monadInv H1. + generalize al vl H0 tyl H2. induction 1; intros. + inv H3. simpl. auto. + inv H5. simpl. split. + eapply type_expr_correct; eauto. + auto. Qed. (** * Correctness of Cminor construction functions *) @@ -910,7 +1356,7 @@ Lemma eval_binop_compat: Csharpminor.eval_binop op v1 v2 m = Some v -> val_inject f v1 tv1 -> val_inject f v2 tv2 -> - mem_inject f m tm -> + Mem.inject f m tm -> exists tv, Cminor.eval_binop op tv1 tv2 = Some tv /\ val_inject f v tv. @@ -924,8 +1370,8 @@ Proof. destruct (eq_block b1 b0); inv H4. assert (b3 = b2) by congruence. subst b3. unfold eq_block; rewrite zeq_true. TrivialOp. - replace x0 with x by congruence. decEq. decEq. - apply Int.sub_shifted. + replace delta0 with delta by congruence. + decEq. decEq. apply Int.sub_shifted. inv H0; try discriminate; inv H1; inv H; TrivialOp. inv H0; try discriminate; inv H1; inv H; TrivialOp. destruct (Int.eq i0 Int.zero); inv H1. TrivialOp. @@ -952,28 +1398,28 @@ Proof. exists v; split; auto. eapply val_inject_eval_compare_null; eauto. exists v; split; auto. eapply val_inject_eval_compare_null; eauto. (* cmp ptr ptr *) - caseEq (valid_pointer m b1 (Int.signed ofs1) && valid_pointer m b0 (Int.signed ofs0)); + caseEq (Mem.valid_pointer m b1 (Int.signed ofs1) && Mem.valid_pointer m b0 (Int.signed ofs0)); intro EQ; rewrite EQ in H4; try discriminate. elim (andb_prop _ _ EQ); intros. destruct (eq_block b1 b0); inv H4. (* same blocks in source *) assert (b3 = b2) by congruence. subst b3. - assert (x0 = x) by congruence. subst x0. + assert (delta0 = delta) by congruence. subst delta0. exists (Val.of_bool (Int.cmp c ofs1 ofs0)); split. unfold eq_block; rewrite zeq_true; simpl. decEq. decEq. rewrite Int.translate_cmp. auto. - eapply valid_pointer_inject_no_overflow; eauto. - eapply valid_pointer_inject_no_overflow; eauto. + eapply Mem.valid_pointer_inject_no_overflow; eauto. + eapply Mem.valid_pointer_inject_no_overflow; eauto. apply val_inject_val_of_bool. (* different blocks in source *) simpl. exists v; split; [idtac | eapply val_inject_eval_compare_mismatch; eauto]. destruct (eq_block b2 b3); auto. - exploit different_pointers_inject; eauto. intros [A|A]. + exploit Mem.different_pointers_inject; eauto. intros [A|A]. congruence. decEq. destruct c; simpl in H6; inv H6; unfold Int.cmp. - predSpec Int.eq Int.eq_spec (Int.add ofs1 (Int.repr x)) (Int.add ofs0 (Int.repr x0)). + predSpec Int.eq Int.eq_spec (Int.add ofs1 (Int.repr delta)) (Int.add ofs0 (Int.repr delta0)). congruence. auto. - predSpec Int.eq Int.eq_spec (Int.add ofs1 (Int.repr x)) (Int.add ofs0 (Int.repr x0)). + predSpec Int.eq Int.eq_spec (Int.add ofs1 (Int.repr delta)) (Int.add ofs0 (Int.repr delta0)). congruence. auto. (* cmpu *) inv H0; try discriminate; inv H1; inv H; TrivialOp. @@ -1038,6 +1484,29 @@ Qed. (** Correctness of [make_store]. *) +Inductive val_content_inject (f: meminj): memory_chunk -> val -> val -> Prop := + | val_content_inject_8_signed: + forall n, + val_content_inject f Mint8signed (Vint (Int.sign_ext 8 n)) (Vint n) + | val_content_inject_8_unsigned: + forall n, + val_content_inject f Mint8unsigned (Vint (Int.zero_ext 8 n)) (Vint n) + | val_content_inject_16_signed: + forall n, + val_content_inject f Mint16signed (Vint (Int.sign_ext 16 n)) (Vint n) + | val_content_inject_16_unsigned: + forall n, + val_content_inject f Mint16unsigned (Vint (Int.zero_ext 16 n)) (Vint n) + | val_content_inject_32: + forall n, + val_content_inject f Mfloat32 (Vfloat (Float.singleoffloat n)) (Vfloat n) + | val_content_inject_base: + forall chunk v1 v2, + val_inject f v1 v2 -> + val_content_inject f chunk v1 v2. + +Hint Resolve val_content_inject_base. + Lemma store_arg_content_inject: forall f sp te tm a v va chunk, eval_expr tge sp te tm a va -> @@ -1056,12 +1525,30 @@ Proof. destruct chunk; trivial; inv H; simpl in H6; inv H6; econstructor; (split; [eauto|idtac]); - destruct v1; simpl in H0; inv H0; try (constructor; constructor). - apply val_content_inject_8. auto. apply Int.zero_ext_idem. compute; auto. - apply val_content_inject_8; auto. apply Int.zero_ext_sign_ext. compute; auto. - apply val_content_inject_16; auto. apply Int.zero_ext_idem. compute; auto. - apply val_content_inject_16; auto. apply Int.zero_ext_sign_ext. compute; auto. - apply val_content_inject_32. apply Float.singleoffloat_idem. + destruct v1; simpl in H0; inv H0; constructor; constructor. +Qed. + +Lemma storev_mapped_inject': + forall f chunk m1 a1 v1 n1 m2 a2 v2, + Mem.inject f m1 m2 -> + Mem.storev chunk m1 a1 v1 = Some n1 -> + val_inject f a1 a2 -> + val_content_inject f chunk v1 v2 -> + exists n2, + Mem.storev chunk m2 a2 v2 = Some n2 /\ Mem.inject f n1 n2. +Proof. + intros. + assert (forall v1', + (forall b ofs, Mem.store chunk m1 b ofs v1 = Mem.store chunk m1 b ofs v1') -> + Mem.storev chunk m1 a1 v1' = Some n1). + intros. rewrite <- H0. destruct a1; simpl; auto. + inv H2; (eapply Mem.storev_mapped_inject; [eauto|idtac|eauto|eauto]); + auto; apply H3; intros. + apply Mem.store_int8_sign_ext. + apply Mem.store_int8_zero_ext. + apply Mem.store_int16_sign_ext. + apply Mem.store_int16_zero_ext. + apply Mem.store_float32_truncate. Qed. Lemma make_store_correct: @@ -1069,69 +1556,63 @@ Lemma make_store_correct: eval_expr tge sp te tm addr tvaddr -> eval_expr tge sp te tm rhs tvrhs -> Mem.storev chunk m vaddr vrhs = Some m' -> - mem_inject f m tm -> + Mem.inject f m tm -> val_inject f vaddr tvaddr -> val_inject f vrhs tvrhs -> - exists tm', + exists tm', exists tvrhs', step tge (State fn (make_store chunk addr rhs) k sp te tm) E0 (State fn Sskip k sp te tm') - /\ mem_inject f m' tm' - /\ nextblock tm' = nextblock tm. + /\ Mem.storev chunk tm tvaddr tvrhs' = Some tm' + /\ Mem.inject f m' tm'. Proof. intros. unfold make_store. exploit store_arg_content_inject. eexact H0. eauto. intros [tv [EVAL VCINJ]]. - exploit storev_mapped_inject_1; eauto. + exploit storev_mapped_inject'; eauto. intros [tm' [STORE MEMINJ]]. - exists tm'. - split. eapply step_store; eauto. - split. auto. - unfold storev in STORE; destruct tvaddr; try discriminate. - eapply nextblock_store; eauto. + exists tm'; exists tv. + split. eapply step_store; eauto. + auto. Qed. (** Correctness of the variable accessors [var_get], [var_addr], and [var_set]. *) Lemma var_get_correct: - forall cenv id a f e te sp lo hi m cs tm b chunk v, + forall cenv id a f tf e te sp lo hi m cs tm b chunk v, var_get cenv id = OK a -> - match_callstack f (mkframe cenv e te sp lo hi :: cs) m.(nextblock) tm.(nextblock) m -> - mem_inject f m tm -> + match_callstack f m tm (Frame cenv tf e te sp lo hi :: cs) (Mem.nextblock m) (Mem.nextblock tm) -> + Mem.inject f m tm -> eval_var_ref gve e id b chunk -> - load chunk m b 0 = Some v -> + Mem.load chunk m b 0 = Some v -> exists tv, eval_expr tge (Vptr sp Int.zero) te tm a tv /\ val_inject f v tv. Proof. unfold var_get; intros. - assert (match_var f id e m te sp cenv!!id). - inversion H0. inversion H17. auto. - inversion H4; subst; rewrite <- H5 in H; inversion H; subst. + assert (match_var f id e m te sp cenv!!id). inv H0. inv MENV. auto. + inv H4; rewrite <- H5 in H; inv H; inv H2; try congruence. (* var_local *) - inversion H2; [subst|congruence]. exists v'; split. - apply eval_Evar. auto. - replace v with v0. auto. congruence. + apply eval_Evar. auto. + congruence. (* var_stack_scalar *) - inversion H2; [subst|congruence]. assert (b0 = b). congruence. subst b0. assert (chunk0 = chunk). congruence. subst chunk0. - exploit loadv_inject; eauto. - unfold loadv. eexact H3. + exploit Mem.loadv_inject; eauto. + unfold Mem.loadv. eexact H3. intros [tv [LOAD INJ]]. exists tv; split. eapply eval_Eload; eauto. eapply make_stackaddr_correct; eauto. auto. (* var_global_scalar *) - inversion H2; [congruence|subst]. simpl in H9; simpl in H10. + simpl in *. assert (match_globalenvs f). eapply match_callstack_match_globalenvs; eauto. - inversion H11. destruct (mg_symbols0 _ _ H9) as [A B]. + inv H2. exploit mg_symbols0; eauto. intros [A B]. assert (chunk0 = chunk). congruence. subst chunk0. - assert (loadv chunk m (Vptr b Int.zero) = Some v). assumption. assert (val_inject f (Vptr b Int.zero) (Vptr b Int.zero)). - econstructor; eauto. - generalize (loadv_inject _ _ _ _ _ _ _ H1 H12 H13). + econstructor; eauto. + exploit Mem.loadv_inject; eauto. simpl. eauto. intros [tv [LOAD INJ]]. exists tv; split. eapply eval_Eload; eauto. eapply make_globaladdr_correct; eauto. @@ -1139,8 +1620,8 @@ Proof. Qed. Lemma var_addr_correct: - forall cenv id a f e te sp lo hi m cs tm b, - match_callstack f (mkframe cenv e te sp lo hi :: cs) m.(nextblock) tm.(nextblock) m -> + forall cenv id a f tf e te sp lo hi m cs tm b, + match_callstack f m tm (Frame cenv tf e te sp lo hi :: cs) (Mem.nextblock m) (Mem.nextblock tm) -> var_addr cenv id = OK a -> eval_var_addr gve e id b -> exists tv, @@ -1149,201 +1630,188 @@ Lemma var_addr_correct: Proof. unfold var_addr; intros. assert (match_var f id e m te sp cenv!!id). - inversion H. inversion H15. auto. - inversion H2; subst; rewrite <- H3 in H0; inversion H0; subst; clear H0. + inv H. inv MENV. auto. + inv H2; rewrite <- H3 in H0; inv H0; inv H1; try congruence. (* var_stack_scalar *) - inversion H1; [subst|congruence]. exists (Vptr sp (Int.repr ofs)); split. - eapply make_stackaddr_correct. - replace b with b0. auto. congruence. + eapply make_stackaddr_correct. congruence. (* var_stack_array *) - inversion H1; [subst|congruence]. exists (Vptr sp (Int.repr ofs)); split. - eapply make_stackaddr_correct. - replace b with b0. auto. congruence. + eapply make_stackaddr_correct. congruence. (* var_global_scalar *) - inversion H1; [congruence|subst]. assert (match_globalenvs f). eapply match_callstack_match_globalenvs; eauto. - inversion H7. destruct (mg_symbols0 _ _ H6) as [A B]. + inv H1. exploit mg_symbols0; eauto. intros [A B]. exists (Vptr b Int.zero); split. eapply make_globaladdr_correct. eauto. econstructor; eauto. (* var_global_array *) - inversion H1; [congruence|subst]. assert (match_globalenvs f). eapply match_callstack_match_globalenvs; eauto. - inversion H6. destruct (mg_symbols0 _ _ H5) as [A B]. + inv H1. exploit mg_symbols0; eauto. intros [A B]. exists (Vptr b Int.zero); split. eapply make_globaladdr_correct. eauto. econstructor; eauto. Qed. Lemma var_set_correct: - forall cenv id rhs a f e te sp lo hi m cs tm tv v m' fn k, - var_set cenv id rhs = OK a -> - match_callstack f (mkframe cenv e te sp lo hi :: cs) m.(nextblock) tm.(nextblock) m -> + forall cenv id rhs rhs_chunk a f tf e te sp lo hi m cs tm tv v m' fn k, + var_set cenv id rhs rhs_chunk = OK a -> + match_callstack f m tm (Frame cenv tf e te sp lo hi :: cs) (Mem.nextblock m) (Mem.nextblock tm) -> eval_expr tge (Vptr sp Int.zero) te tm rhs tv -> val_inject f v tv -> - mem_inject f m tm -> + Mem.inject f m tm -> exec_assign gve e m id v m' -> + val_normalized v rhs_chunk -> exists te', exists tm', step tge (State fn a k (Vptr sp Int.zero) te tm) E0 (State fn Sskip k (Vptr sp Int.zero) te' tm') /\ - mem_inject f m' tm' /\ - match_callstack f (mkframe cenv e te' sp lo hi :: cs) m'.(nextblock) tm'.(nextblock) m' /\ + Mem.inject f m' tm' /\ + match_callstack f m' tm' (Frame cenv tf e te' sp lo hi :: cs) (Mem.nextblock m') (Mem.nextblock tm') /\ (forall id', id' <> id -> te'!id' = te!id'). Proof. - unfold var_set; intros. - inv H4. - assert (NEXTBLOCK: nextblock m' = nextblock m). - eapply nextblock_store; eauto. - inversion H0; subst. - assert (match_var f id e m te sp cenv!!id). inversion H19; auto. - inv H4; rewrite <- H7 in H; inv H. + intros until k. + intros VS MCS EVAL VINJ MINJ ASG VNORM. + unfold var_set in VS. inv ASG. + assert (NEXTBLOCK: Mem.nextblock m' = Mem.nextblock m). + eapply Mem.nextblock_store; eauto. + assert (MV: match_var f id e m te sp cenv!!id). + inv MCS. inv MENV. auto. + inv MV; rewrite <- H1 in VS; inv VS; inv H; try congruence. (* var_local *) - inversion H5; [subst|congruence]. assert (b0 = b) by congruence. subst b0. assert (chunk0 = chunk) by congruence. subst chunk0. + generalize H8; clear H8. case_eq (chunktype_compat rhs_chunk chunk). + (* compatible chunks *) + intros CCOMPAT EQ; inv EQ. + exploit chunktype_compat_correct; eauto. intro VNORM'. + exists (PTree.set id tv te); exists tm. + split. eapply step_assign. eauto. + split. eapply Mem.store_unmapped_inject; eauto. + split. rewrite NEXTBLOCK. eapply match_callstack_store_local; eauto. + eapply val_normalized_has_type; eauto. red in VNORM'. congruence. + intros. apply PTree.gso; auto. + (* incompatible chunks but same type *) + intros. destruct (typ_eq (type_of_chunk chunk) (type_of_chunk rhs_chunk)); inv H8. exploit make_cast_correct; eauto. - intros [tv' [EVAL INJ]]. + intros [tv' [EVAL' INJ']]. exists (PTree.set id tv' te); exists tm. split. eapply step_assign. eauto. - split. eapply store_unmapped_inject; eauto. + split. eapply Mem.store_unmapped_inject; eauto. split. rewrite NEXTBLOCK. eapply match_callstack_store_local; eauto. + rewrite e0. eapply val_normalized_has_type; eauto. intros. apply PTree.gso; auto. (* var_stack_scalar *) - inversion H5; [subst|congruence]. assert (b0 = b) by congruence. subst b0. assert (chunk0 = chunk) by congruence. subst chunk0. - assert (storev chunk m (Vptr b Int.zero) v = Some m'). assumption. + assert (Mem.storev chunk m (Vptr b Int.zero) v = Some m'). assumption. exploit make_store_correct. eapply make_stackaddr_correct. eauto. eauto. eauto. eauto. eauto. - intros [tm' [EVAL [MEMINJ TNEXTBLOCK]]]. + intros [tm' [tvrhs' [EVAL' [STORE' MEMINJ]]]]. exists te; exists tm'. split. eauto. split. auto. - split. rewrite NEXTBLOCK; rewrite TNEXTBLOCK. - eapply match_callstack_mapped; eauto. - inversion H9; congruence. + split. rewrite NEXTBLOCK. rewrite (nextblock_storev _ _ _ _ _ STORE'). + eapply match_callstack_storev_mapped; eauto. auto. (* var_global_scalar *) - inversion H5; [congruence|subst]. simpl in H4; simpl in H10. + simpl in *. assert (chunk0 = chunk) by congruence. subst chunk0. - assert (storev chunk m (Vptr b Int.zero) v = Some m'). assumption. + assert (Mem.storev chunk m (Vptr b Int.zero) v = Some m'). assumption. assert (match_globalenvs f). eapply match_callstack_match_globalenvs; eauto. - inversion H12. destruct (mg_symbols0 _ _ H4) as [A B]. + exploit mg_symbols; eauto. intros [A B]. exploit make_store_correct. eapply make_globaladdr_correct; eauto. - eauto. eauto. eauto. eauto. eauto. - intros [tm' [EVAL [MEMINJ TNEXTBLOCK]]]. + eauto. eauto. eauto. eauto. eauto. + intros [tm' [tvrhs' [EVAL' [STORE' TNEXTBLOCK]]]]. exists te; exists tm'. split. eauto. split. auto. - split. rewrite NEXTBLOCK; rewrite TNEXTBLOCK. - eapply match_callstack_mapped; eauto. congruence. + split. rewrite NEXTBLOCK. rewrite (nextblock_storev _ _ _ _ _ STORE'). + eapply match_callstack_store_mapped; eauto. auto. Qed. -Lemma match_env_extensional': - forall f cenv e m te1 sp lo hi, - match_env f cenv e m te1 sp lo hi -> - forall te2, - (forall id, - match cenv!!id with - | Var_local _ => te2!id = te1!id - | _ => True - end) -> - match_env f cenv e m te2 sp lo hi. -Proof. - induction 1; intros; econstructor; eauto. - intros. generalize (me_vars0 id); intro. - inversion H0; econstructor; eauto. - generalize (H id). rewrite <- H1. congruence. -Qed. - - Lemma match_callstack_extensional: - forall f cenv e te1 te2 sp lo hi cs bound tbound m, - (forall id, - match cenv!!id with - | Var_local _ => te2!id = te1!id - | _ => True - end) -> - match_callstack f (mkframe cenv e te1 sp lo hi :: cs) bound tbound m -> - match_callstack f (mkframe cenv e te2 sp lo hi :: cs) bound tbound m. + forall f cenv tf e te1 te2 sp lo hi cs bound tbound m tm, + (forall id chunk, cenv!!id = Var_local chunk -> te2!id = te1!id) -> + match_callstack f m tm (Frame cenv tf e te1 sp lo hi :: cs) bound tbound -> + match_callstack f m tm (Frame cenv tf e te2 sp lo hi :: cs) bound tbound. Proof. intros. inv H0. constructor; auto. - apply match_env_extensional' with te1; auto. + apply match_env_extensional with te1; auto. Qed. Lemma var_set_self_correct: - forall cenv id a f e te sp lo hi m cs tm tv v m' fn k, - var_set cenv id (Evar id) = OK a -> - match_callstack f (mkframe cenv e te sp lo hi :: cs) m.(nextblock) tm.(nextblock) m -> + forall cenv id ty a f tf e te sp lo hi m cs tm tv te' v m' fn k, + var_set_self cenv id ty = OK a -> + match_callstack f m tm (Frame cenv tf e te sp lo hi :: cs) (Mem.nextblock m) (Mem.nextblock tm) -> val_inject f v tv -> - mem_inject f m tm -> + Mem.inject f m tm -> exec_assign gve e m id v m' -> - exists te', exists tm', - step tge (State fn a k (Vptr sp Int.zero) (PTree.set id tv te) tm) - E0 (State fn Sskip k (Vptr sp Int.zero) te' tm') /\ - mem_inject f m' tm' /\ - match_callstack f (mkframe cenv e te' sp lo hi :: cs) m'.(nextblock) tm'.(nextblock) m'. -Proof. - unfold var_set; intros. - inv H3. - assert (NEXTBLOCK: nextblock m' = nextblock m). - eapply nextblock_store; eauto. - inversion H0; subst. - assert (EVAR: eval_expr tge (Vptr sp Int.zero) (PTree.set id tv te) tm (Evar id) tv). - constructor. apply PTree.gss. - assert (match_var f id e m te sp cenv!!id). inversion H18; auto. - inv H3; rewrite <- H6 in H; inv H. + Val.has_type v ty -> + te'!id = Some tv -> + (forall i, i <> id -> te'!i = te!i) -> + exists te'', exists tm', + step tge (State fn a k (Vptr sp Int.zero) te' tm) + E0 (State fn Sskip k (Vptr sp Int.zero) te'' tm') /\ + Mem.inject f m' tm' /\ + match_callstack f m' tm' (Frame cenv tf e te'' sp lo hi :: cs) (Mem.nextblock m') (Mem.nextblock tm') /\ + (forall id', id' <> id -> te''!id' = te'!id'). +Proof. + intros until k. + intros VS MCS VINJ MINJ ASG VTY VAL OTHERS. + unfold var_set_self in VS. inv ASG. + assert (NEXTBLOCK: Mem.nextblock m' = Mem.nextblock m). + eapply Mem.nextblock_store; eauto. + assert (MV: match_var f id e m te sp cenv!!id). + inv MCS. inv MENV. auto. + assert (EVAR: eval_expr tge (Vptr sp Int.zero) te' tm (Evar id) tv). + constructor. auto. + inv MV; rewrite <- H1 in VS; inv VS; inv H; try congruence. (* var_local *) - inversion H4; [subst|congruence]. assert (b0 = b) by congruence. subst b0. assert (chunk0 = chunk) by congruence. subst chunk0. - exploit make_cast_correct; eauto. - intros [tv' [EVAL INJ]]. - exists (PTree.set id tv' (PTree.set id tv te)); exists tm. + destruct (typ_eq (type_of_chunk chunk) ty); inv H8. + exploit make_cast_correct; eauto. + intros [tv' [EVAL' INJ']]. + exists (PTree.set id tv' te'); exists tm. split. eapply step_assign. eauto. - split. eapply store_unmapped_inject; eauto. - rewrite NEXTBLOCK. + split. eapply Mem.store_unmapped_inject; eauto. + split. rewrite NEXTBLOCK. apply match_callstack_extensional with (PTree.set id tv' te). - intros. destruct (cenv!!id0); auto. - repeat rewrite PTree.gsspec. destruct (peq id0 id); auto. + intros. repeat rewrite PTree.gsspec. destruct (peq id0 id); auto. eapply match_callstack_store_local; eauto. + intros; apply PTree.gso; auto. (* var_stack_scalar *) - inversion H4; [subst|congruence]. assert (b0 = b) by congruence. subst b0. assert (chunk0 = chunk) by congruence. subst chunk0. - assert (storev chunk m (Vptr b Int.zero) v = Some m'). assumption. + assert (Mem.storev chunk m (Vptr b Int.zero) v = Some m'). assumption. exploit make_store_correct. eapply make_stackaddr_correct. eauto. eauto. eauto. eauto. eauto. - intros [tm' [EVAL [MEMINJ TNEXTBLOCK]]]. - exists (PTree.set id tv te); exists tm'. + intros [tm' [tvrhs' [EVAL' [STORE' MEMINJ]]]]. + exists te'; exists tm'. split. eauto. split. auto. - rewrite NEXTBLOCK; rewrite TNEXTBLOCK. + split. rewrite NEXTBLOCK. rewrite (nextblock_storev _ _ _ _ _ STORE'). apply match_callstack_extensional with te. - intros. caseEq (cenv!!id0); intros; auto. - rewrite PTree.gsspec. destruct (peq id0 id). congruence. auto. - eapply match_callstack_mapped; eauto. - inversion H8; congruence. + intros. apply OTHERS. congruence. + eapply match_callstack_storev_mapped; eauto. + auto. (* var_global_scalar *) - inversion H4; [congruence|subst]. simpl in H3; simpl in H9. + simpl in *. assert (chunk0 = chunk) by congruence. subst chunk0. - assert (storev chunk m (Vptr b Int.zero) v = Some m'). assumption. + assert (Mem.storev chunk m (Vptr b Int.zero) v = Some m'). assumption. assert (match_globalenvs f). eapply match_callstack_match_globalenvs; eauto. - inversion H11. destruct (mg_symbols0 _ _ H3) as [A B]. + exploit mg_symbols; eauto. intros [A B]. exploit make_store_correct. eapply make_globaladdr_correct; eauto. - eauto. eauto. eauto. eauto. eauto. - intros [tm' [EVAL [MEMINJ TNEXTBLOCK]]]. - exists (PTree.set id tv te); exists tm'. + eauto. eauto. eauto. eauto. eauto. + intros [tm' [tvrhs' [EVAL' [STORE' MEMINJ]]]]. + exists te'; exists tm'. split. eauto. split. auto. - rewrite NEXTBLOCK; rewrite TNEXTBLOCK. + split. rewrite NEXTBLOCK. rewrite (nextblock_storev _ _ _ _ _ STORE'). apply match_callstack_extensional with te. - intros. caseEq (cenv!!id0); intros; auto. - rewrite PTree.gsspec. destruct (peq id0 id). congruence. auto. - eapply match_callstack_mapped; eauto. congruence. + intros. apply OTHERS. congruence. + eapply match_callstack_store_mapped; eauto. + auto. Qed. (** * Correctness of stack allocation of local variables *) @@ -1361,26 +1829,38 @@ Proof. destruct (zlt sz 8); omega. Qed. -Remark assign_variables_incr: - forall atk vars cenv sz cenv' sz', - assign_variables atk vars (cenv, sz) = (cenv', sz') -> sz <= sz'. +Remark assign_variable_incr: + forall atk id lv cenv sz cenv' sz', + assign_variable atk (id, lv) (cenv, sz) = (cenv', sz') -> sz <= sz'. Proof. - induction vars; intros until sz'; simpl. - intro. replace sz' with sz. omega. congruence. - destruct a. destruct v. case (Identset.mem i atk); intros. - generalize (IHvars _ _ _ _ H). - generalize (size_chunk_pos m). intro. - generalize (align_le sz (size_chunk m) H0). omega. - eauto. - intro. generalize (IHvars _ _ _ _ H). + intros until sz'; simpl. + destruct lv. case (Identset.mem id atk); intros. + inv H. generalize (size_chunk_pos m). intro. + generalize (align_le sz (size_chunk m) H). omega. + inv H. omega. + intros. inv H. generalize (align_le sz (array_alignment z) (array_alignment_pos z)). assert (0 <= Zmax 0 z). apply Zmax_bound_l. omega. omega. Qed. + +Remark assign_variables_incr: + forall atk vars cenv sz cenv' sz', + assign_variables atk vars (cenv, sz) = (cenv', sz') -> sz <= sz'. +Proof. + induction vars; intros until sz'. + simpl; intros. replace sz' with sz. omega. congruence. +Opaque assign_variable. + destruct a as [id lv]. simpl. + case_eq (assign_variable atk (id, lv) (cenv, sz)). intros cenv1 sz1 EQ1 EQ2. + apply Zle_trans with sz1. eapply assign_variable_incr; eauto. eauto. +Transparent assign_variable. +Qed. + Remark inj_offset_aligned_array: forall stacksize sz, - inj_offset_aligned (align stacksize (array_alignment sz)) sz. + Mem.inj_offset_aligned (align stacksize (array_alignment sz)) sz. Proof. intros; red; intros. apply Zdivides_trans with (array_alignment sz). @@ -1402,7 +1882,7 @@ Qed. Remark inj_offset_aligned_array': forall stacksize sz, - inj_offset_aligned (align stacksize (array_alignment sz)) (Zmax 0 sz). + Mem.inj_offset_aligned (align stacksize (array_alignment sz)) (Zmax 0 sz). Proof. intros. replace (array_alignment sz) with (array_alignment (Zmax 0 sz)). @@ -1413,7 +1893,7 @@ Qed. Remark inj_offset_aligned_var: forall stacksize chunk, - inj_offset_aligned (align stacksize (size_chunk chunk)) (size_chunk chunk). + Mem.inj_offset_aligned (align stacksize (size_chunk chunk)) (size_chunk chunk). Proof. intros. replace (align stacksize (size_chunk chunk)) @@ -1422,31 +1902,127 @@ Proof. decEq. destruct chunk; reflexivity. Qed. +Lemma match_callstack_alloc_variable: + forall atk id lv cenv sz cenv' sz' tm sp e tf m m' b te lo cs f tv, + assign_variable atk (id, lv) (cenv, sz) = (cenv', sz') -> + Mem.valid_block tm sp -> + Mem.bounds tm sp = (0, tf.(fn_stackspace)) -> + Mem.range_perm tm sp 0 tf.(fn_stackspace) Freeable -> + tf.(fn_stackspace) <= Int.max_signed -> + Mem.alloc m 0 (sizeof lv) = (m', b) -> + match_callstack f m tm + (Frame cenv tf e te sp lo (Mem.nextblock m) :: cs) + (Mem.nextblock m) (Mem.nextblock tm) -> + Mem.inject f m tm -> + 0 <= sz -> sz' <= tf.(fn_stackspace) -> + (forall b delta, f b = Some(sp, delta) -> Mem.high_bound m b + delta <= sz) -> + e!id = None -> + te!id = Some tv -> + exists f', + inject_incr f f' + /\ Mem.inject f' m' tm + /\ match_callstack f' m' tm + (Frame cenv' tf (PTree.set id (b, lv) e) te sp lo (Mem.nextblock m') :: cs) + (Mem.nextblock m') (Mem.nextblock tm) + /\ (forall b delta, + f' b = Some(sp, delta) -> Mem.high_bound m' b + delta <= sz'). +Proof. + intros until tv. intros ASV VALID BOUNDS PERMS NOOV ALLOC MCS INJ LO HI RANGE E TE. + generalize ASV. unfold assign_variable. + caseEq lv. + (* 1. lv = LVscalar chunk *) + intros chunk LV. case (Identset.mem id atk). + (* 1.1 info = Var_stack_scalar chunk ofs *) + set (ofs := align sz (size_chunk chunk)). + intro EQ; injection EQ; intros; clear EQ. rewrite <- H0. + generalize (size_chunk_pos chunk); intro SIZEPOS. + generalize (align_le sz (size_chunk chunk) SIZEPOS). fold ofs. intro SZOFS. + exploit Mem.alloc_left_mapped_inject. + eauto. eauto. eauto. + instantiate (1 := ofs). + generalize Int.min_signed_neg. omega. + right; rewrite BOUNDS; simpl. generalize Int.min_signed_neg. omega. + intros. apply Mem.perm_implies with Freeable; auto with mem. + apply PERMS. rewrite LV in H1. simpl in H1. omega. + rewrite LV; simpl. rewrite Zminus_0_r. unfold ofs. + apply inj_offset_aligned_var. + intros. generalize (RANGE _ _ H1). omega. + intros [f1 [MINJ1 [INCR1 [SAME OTHER]]]]. + exists f1; split. auto. split. auto. split. + eapply match_callstack_alloc_left; eauto. + rewrite <- LV; auto. + rewrite SAME; constructor. + intros. rewrite (Mem.bounds_alloc _ _ _ _ _ ALLOC). + destruct (eq_block b0 b); simpl. + subst b0. assert (delta = ofs) by congruence. subst delta. + rewrite LV. simpl. omega. + rewrite OTHER in H1; eauto. generalize (RANGE _ _ H1). omega. + (* 1.2 info = Var_local chunk *) + intro EQ; injection EQ; intros; clear EQ. subst sz'. rewrite <- H0. + exploit Mem.alloc_left_unmapped_inject; eauto. + intros [f1 [MINJ1 [INCR1 [SAME OTHER]]]]. + exists f1; split. auto. split. auto. split. + eapply match_callstack_alloc_left; eauto. + rewrite <- LV; auto. + rewrite SAME; constructor. + intros. rewrite (Mem.bounds_alloc _ _ _ _ _ ALLOC). + destruct (eq_block b0 b); simpl. + subst b0. congruence. + rewrite OTHER in H; eauto. + (* 2 info = Var_stack_array ofs *) + intros dim LV EQ. injection EQ; clear EQ; intros. rewrite <- H0. + assert (0 <= Zmax 0 dim). apply Zmax1. + generalize (align_le sz (array_alignment dim) (array_alignment_pos dim)). intro. + set (ofs := align sz (array_alignment dim)) in *. + exploit Mem.alloc_left_mapped_inject. eauto. eauto. eauto. + instantiate (1 := ofs). + generalize Int.min_signed_neg. omega. + right; rewrite BOUNDS; simpl. generalize Int.min_signed_neg. omega. + intros. apply Mem.perm_implies with Freeable; auto with mem. + apply PERMS. rewrite LV in H3. simpl in H3. omega. + rewrite LV; simpl. rewrite Zminus_0_r. unfold ofs. + apply inj_offset_aligned_array'. + intros. generalize (RANGE _ _ H3). omega. + intros [f1 [MINJ1 [INCR1 [SAME OTHER]]]]. + exists f1; split. auto. split. auto. split. + eapply match_callstack_alloc_left; eauto. + rewrite <- LV; auto. + rewrite SAME; constructor. + intros. rewrite (Mem.bounds_alloc _ _ _ _ _ ALLOC). + destruct (eq_block b0 b); simpl. + subst b0. assert (delta = ofs) by congruence. subst delta. + rewrite LV. simpl. omega. + rewrite OTHER in H3; eauto. generalize (RANGE _ _ H3). omega. +Qed. + Lemma match_callstack_alloc_variables_rec: - forall tm sp cenv' sz' te lo cs atk, - valid_block tm sp -> - low_bound tm sp = 0 -> - high_bound tm sp = sz' -> - sz' <= Int.max_signed -> + forall tm sp cenv' tf te lo cs atk, + Mem.valid_block tm sp -> + Mem.bounds tm sp = (0, tf.(fn_stackspace)) -> + Mem.range_perm tm sp 0 tf.(fn_stackspace) Freeable -> + tf.(fn_stackspace) <= Int.max_signed -> forall e m vars e' m', alloc_variables e m vars e' m' -> forall f cenv sz, - assign_variables atk vars (cenv, sz) = (cenv', sz') -> - match_callstack f (mkframe cenv e te sp lo m.(nextblock) :: cs) - m.(nextblock) tm.(nextblock) m -> - mem_inject f m tm -> + assign_variables atk vars (cenv, sz) = (cenv', tf.(fn_stackspace)) -> + match_callstack f m tm + (Frame cenv tf e te sp lo (Mem.nextblock m) :: cs) + (Mem.nextblock m) (Mem.nextblock tm) -> + Mem.inject f m tm -> 0 <= sz -> - (forall b delta, f b = Some(sp, delta) -> high_bound m b + delta <= sz) -> + (forall b delta, + f b = Some(sp, delta) -> Mem.high_bound m b + delta <= sz) -> (forall id lv, In (id, lv) vars -> te!id <> None) -> list_norepet (List.map (@fst ident var_kind) vars) -> (forall id lv, In (id, lv) vars -> e!id = None) -> exists f', inject_incr f f' - /\ mem_inject f' m' tm - /\ match_callstack f' (mkframe cenv' e' te sp lo m'.(nextblock) :: cs) - m'.(nextblock) tm.(nextblock) m'. + /\ Mem.inject f' m' tm + /\ match_callstack f' m' tm + (Frame cenv' tf e' te sp lo (Mem.nextblock m') :: cs) + (Mem.nextblock m') (Mem.nextblock tm). Proof. - intros until atk. intros VB LB HB NOOV. + intros until atk. intros VALID BOUNDS PERM NOOV. induction 1. (* base case *) intros. simpl in H. inversion H; subst cenv sz. @@ -1462,81 +2038,18 @@ Proof. assert (exists tv, te!id = Some tv). assert (te!id <> None). eapply DEFINED. simpl; left; auto. destruct (te!id). exists v; auto. congruence. - elim H1; intros tv TEID; clear H1. - assert (UNDEFINED1: forall (id0 : ident) (lv0 : var_kind), - In (id0, lv0) vars -> - (PTree.set id (b1, lv) e)!id0 = None). - intros. rewrite PTree.gso. eapply UNDEFINED; eauto with coqlib. - simpl in NOREPET. inversion NOREPET. red; intro; subst id0. - elim H4. change id with (fst (id, lv0)). apply List.in_map. auto. - assert (NOREPET1: list_norepet (map (fst (A:=ident) (B:=var_kind)) vars)). - inv NOREPET; auto. - generalize ASV1. unfold assign_variable. - caseEq lv. - (* 1. lv = LVscalar chunk *) - intros chunk LV. case (Identset.mem id atk). - (* 1.1 info = Var_stack_scalar chunk ... *) - set (ofs := align sz (size_chunk chunk)). - intro EQ; injection EQ; intros; clear EQ. - set (f1 := extend_inject b1 (Some (sp, ofs)) f). - generalize (size_chunk_pos chunk); intro SIZEPOS. - generalize (align_le sz (size_chunk chunk) SIZEPOS). fold ofs. intro SZOFS. - assert (mem_inject f1 m1 tm /\ inject_incr f f1). - assert (Int.min_signed < 0). compute; auto. - generalize (assign_variables_incr _ _ _ _ _ _ ASVS). intro. - unfold f1; eapply alloc_mapped_inject; eauto. - omega. omega. omega. omega. unfold sizeof; rewrite LV. omega. - rewrite Zminus_0_r. unfold ofs. rewrite LV. simpl. - apply inj_offset_aligned_var. - intros. left. generalize (BOUND _ _ H5). omega. - elim H3; intros MINJ1 INCR1; clear H3. - exploit IHalloc_variables; eauto. - unfold f1; rewrite <- H2; eapply match_callstack_alloc_left; eauto with coqlib. - rewrite <- H1. omega. - intros until delta; unfold f1, extend_inject, eq_block. - rewrite (high_bound_alloc _ _ _ _ _ H b). - case (zeq b b1); intros. - inversion H3. unfold sizeof; rewrite LV. omega. - generalize (BOUND _ _ H3). omega. - intros [f' [INCR2 [MINJ2 MATCH2]]]. - exists f'; intuition. eapply inject_incr_trans; eauto. - (* 1.2 info = Var_local chunk *) - intro EQ; injection EQ; intros; clear EQ. subst sz1. - exploit alloc_unmapped_inject; eauto. - set (f1 := extend_inject b1 None f). intros [MINJ1 INCR1]. - exploit IHalloc_variables; eauto. - unfold f1; rewrite <- H2; eapply match_callstack_alloc_left; eauto with coqlib. - intros until delta; unfold f1, extend_inject, eq_block. - rewrite (high_bound_alloc _ _ _ _ _ H b). - case (zeq b b1); intros. discriminate. - eapply BOUND; eauto. - intros [f' [INCR2 [MINJ2 MATCH2]]]. - exists f'; intuition. eapply inject_incr_trans; eauto. - (* 2. lv = LVarray dim, info = Var_stack_array *) - intros dim LV EQ. injection EQ; clear EQ; intros. - assert (0 <= Zmax 0 dim). apply Zmax1. - generalize (align_le sz (array_alignment dim) (array_alignment_pos dim)). intro. - set (ofs := align sz (array_alignment dim)) in *. - set (f1 := extend_inject b1 (Some (sp, ofs)) f). - assert (mem_inject f1 m1 tm /\ inject_incr f f1). - assert (Int.min_signed < 0). compute; auto. - generalize (assign_variables_incr _ _ _ _ _ _ ASVS). intro. - unfold f1; eapply alloc_mapped_inject; eauto. - omega. omega. omega. omega. unfold sizeof; rewrite LV. omega. - rewrite Zminus_0_r. unfold ofs. rewrite LV. simpl. - apply inj_offset_aligned_array'. - intros. left. generalize (BOUND _ _ H7). omega. - destruct H5 as [MINJ1 INCR1]. - exploit IHalloc_variables; eauto. - unfold f1; rewrite <- H2; eapply match_callstack_alloc_left; eauto with coqlib. - rewrite <- H1. omega. - intros until delta; unfold f1, extend_inject, eq_block. - rewrite (high_bound_alloc _ _ _ _ _ H b). - case (zeq b b1); intros. - inversion H5. unfold sizeof; rewrite LV. omega. - generalize (BOUND _ _ H5). omega. - intros [f' [INCR2 [MINJ2 MATCH2]]]. - exists f'; intuition. eapply inject_incr_trans; eauto. + destruct H1 as [tv TEID]. + assert (sz1 <= fn_stackspace tf). eapply assign_variables_incr; eauto. + exploit match_callstack_alloc_variable; eauto with coqlib. + intros [f1 [INCR1 [INJ1 [MCS1 BOUND1]]]]. + exploit IHalloc_variables; eauto. + apply Zle_trans with sz; auto. eapply assign_variable_incr; eauto. + inv NOREPET; auto. + intros. rewrite PTree.gso. eapply UNDEFINED; eauto with coqlib. + simpl in NOREPET. inversion NOREPET. red; intro; subst id0. + elim H5. change id with (fst (id, lv0)). apply List.in_map. auto. + intros [f2 [INCR2 [INJ2 MCS2]]]. + exists f2; intuition. eapply inject_incr_trans; eauto. Qed. Lemma set_params_defined: @@ -1578,56 +2091,32 @@ Qed. of Csharpminor local variables and of the Cminor stack data block. *) Lemma match_callstack_alloc_variables: - forall fn cenv sz m e m' tm tm' sp f cs targs body, - build_compilenv gce fn = (cenv, sz) -> - sz <= Int.max_signed -> + forall fn cenv tf m e m' tm tm' sp f cs targs body, + build_compilenv gce fn = (cenv, tf.(fn_stackspace)) -> + tf.(fn_stackspace) <= Int.max_signed -> list_norepet (fn_params_names fn ++ fn_vars_names fn) -> alloc_variables Csharpminor.empty_env m (fn_variables fn) e m' -> - Mem.alloc tm 0 sz = (tm', sp) -> - match_callstack f cs m.(nextblock) tm.(nextblock) m -> - mem_inject f m tm -> + Mem.alloc tm 0 tf.(fn_stackspace) = (tm', sp) -> + match_callstack f m tm cs (Mem.nextblock m) (Mem.nextblock tm) -> + Mem.inject f m tm -> let tvars := make_vars (fn_params_names fn) (fn_vars_names fn) body in let te := set_locals tvars (set_params targs (fn_params_names fn)) in exists f', inject_incr f f' - /\ mem_inject f' m' tm' - /\ match_callstack f' (mkframe cenv e te sp m.(nextblock) m'.(nextblock) :: cs) - m'.(nextblock) tm'.(nextblock) m'. + /\ Mem.inject f' m' tm' + /\ match_callstack f' m' tm' + (Frame cenv tf e te sp (Mem.nextblock m) (Mem.nextblock m') :: cs) + (Mem.nextblock m') (Mem.nextblock tm'). Proof. intros. - assert (SP: sp = nextblock tm). injection H3; auto. unfold build_compilenv in H. - eapply match_callstack_alloc_variables_rec with (sz' := sz); eauto with mem. - eapply low_bound_alloc_same; eauto. - eapply high_bound_alloc_same; eauto. - (* match_callstack *) - constructor. omega. change (valid_block tm' sp). eapply valid_new_block; eauto. - constructor. - (* me_vars *) - intros. generalize (global_compilenv_charact id). - destruct (gce!!id); intro; try contradiction. - constructor. - unfold Csharpminor.empty_env. apply PTree.gempty. auto. - constructor. - unfold Csharpminor.empty_env. apply PTree.gempty. - (* me_low_high *) - omega. - (* me_bounded *) - intros until lv. unfold Csharpminor.empty_env. rewrite PTree.gempty. congruence. - (* me_inj *) - intros until lv2. unfold Csharpminor.empty_env; rewrite PTree.gempty; congruence. - (* me_inv *) - intros. exploit mi_mappedblocks; eauto. intro A. - elim (fresh_block_alloc _ _ _ _ _ H3 A). - (* me_incr *) - intros. exploit mi_mappedblocks; eauto. intro A. - rewrite SP; auto. - rewrite SP; auto. - eapply alloc_right_inject; eauto. - omega. - intros. exploit mi_mappedblocks; eauto. unfold valid_block; intro. - unfold block in SP; omegaContradiction. - (* defined *) + eapply match_callstack_alloc_variables_rec; eauto with mem. + eapply Mem.bounds_alloc_same; eauto. + red; intros; eauto with mem. + eapply match_callstack_alloc_right; eauto. + eapply Mem.alloc_right_inject; eauto. omega. + intros. elim (Mem.valid_not_valid_diff tm sp sp); eauto with mem. + eapply Mem.valid_block_inject_2; eauto. intros. unfold te. apply set_locals_params_defined. elim (in_app_or _ _ _ H6); intros. elim (list_in_map_inv _ _ _ H7). intros x [A B]. @@ -1645,15 +2134,16 @@ Qed. (** Correctness of the code generated by [store_parameters] to store in memory the values of parameters that are stack-allocated. *) -Inductive vars_vals_match: - meminj -> list (ident * memory_chunk) -> list val -> env -> Prop := +Inductive vars_vals_match (f:meminj): + list (ident * memory_chunk) -> list val -> env -> Prop := | vars_vals_nil: - forall f te, + forall te, vars_vals_match f nil nil te | vars_vals_cons: - forall f te id chunk vars v vals tv, + forall te id chunk vars v vals tv, te!id = Some tv -> val_inject f v tv -> + Val.has_type v (type_of_chunk chunk) -> vars_vals_match f vars vals te -> vars_vals_match f ((id, chunk) :: vars) (v :: vals) te. @@ -1666,24 +2156,25 @@ Lemma vars_vals_match_extensional: Proof. induction 1; intros. constructor. - econstructor; eauto. rewrite <- H. eapply H2. left. reflexivity. - apply IHvars_vals_match. intros. eapply H2; eauto. right. eauto. + econstructor; eauto. + rewrite <- H. eauto with coqlib. + apply IHvars_vals_match. intros. eapply H3; eauto with coqlib. Qed. Lemma store_parameters_correct: forall e m1 params vl m2, bind_parameters e m1 params vl m2 -> - forall s f te1 cenv sp lo hi cs tm1 fn k, + forall s f te1 cenv tf sp lo hi cs tm1 fn k, vars_vals_match f params vl te1 -> - list_norepet (List.map (@fst ident memory_chunk) params) -> - mem_inject f m1 tm1 -> - match_callstack f (mkframe cenv e te1 sp lo hi :: cs) m1.(nextblock) tm1.(nextblock) m1 -> + list_norepet (List.map param_name params) -> + Mem.inject f m1 tm1 -> + match_callstack f m1 tm1 (Frame cenv tf e te1 sp lo hi :: cs) (Mem.nextblock m1) (Mem.nextblock tm1) -> store_parameters cenv params = OK s -> exists te2, exists tm2, star step tge (State fn s k (Vptr sp Int.zero) te1 tm1) E0 (State fn Sskip k (Vptr sp Int.zero) te2 tm2) - /\ mem_inject f m2 tm2 - /\ match_callstack f (mkframe cenv e te2 sp lo hi :: cs) m2.(nextblock) tm2.(nextblock) m2. + /\ Mem.inject f m2 tm2 + /\ match_callstack f m2 tm2 (Frame cenv tf e te2 sp lo hi :: cs) (Mem.nextblock m2) (Mem.nextblock tm2). Proof. induction 1. (* base case *) @@ -1692,17 +2183,15 @@ Proof. (* inductive case *) intros until k. intros VVM NOREPET MINJ MATCH STOREP. monadInv STOREP. - inversion VVM. subst f0 id0 chunk0 vars v vals te. - inversion NOREPET. subst hd tl. - exploit var_set_correct; eauto. - constructor; auto. - econstructor; eauto. - econstructor; eauto. + inv VVM. + inv NOREPET. + exploit var_set_self_correct; eauto. + econstructor; eauto. econstructor; eauto. intros [te2 [tm2 [EXEC1 [MINJ1 [MATCH1 UNCHANGED1]]]]]. assert (vars_vals_match f params vl te2). apply vars_vals_match_extensional with te1; auto. intros. apply UNCHANGED1. red; intro; subst id0. - elim H4. change id with (fst (id, lv)). apply List.in_map. auto. + elim H4. change id with (param_name (id, lv)). apply List.in_map. auto. exploit IHbind_parameters; eauto. intros [te3 [tm3 [EXEC2 [MINJ2 MATCH2]]]]. exists te3; exists tm3. @@ -1715,50 +2204,42 @@ Qed. Lemma vars_vals_match_holds_1: forall f params args targs, - list_norepet (List.map (@fst ident memory_chunk) params) -> - List.length params = List.length args -> + list_norepet (List.map param_name params) -> val_list_inject f args targs -> + Val.has_type_list args (List.map type_of_chunk (List.map param_chunk params)) -> vars_vals_match f params args (set_params targs (List.map (@fst ident memory_chunk) params)). Proof. - induction params; destruct args; simpl; intros; try discriminate. + induction params; simpl; intros. + destruct args; simpl in H1; try contradiction. inv H0. constructor. - inversion H1. subst v0 vl targs. - inversion H. subst hd tl. - destruct a as [id chunk]. econstructor. - simpl. rewrite PTree.gss. reflexivity. - auto. + destruct args; simpl in H1; try contradiction. destruct H1. inv H0. inv H. + destruct a as [id chunk]; simpl in *. econstructor. + rewrite PTree.gss. reflexivity. + auto. auto. apply vars_vals_match_extensional - with (set_params vl' (map (@fst ident memory_chunk) params)). + with (set_params vl' (map param_name params)). eapply IHparams; eauto. intros. simpl. apply PTree.gso. red; intro; subst id0. - elim H5. change (fst (id, chunk)) with (fst (id, lv)). - apply List.in_map; auto. + elim H4. change id with (param_name (id, lv)). apply List.in_map; auto. Qed. Lemma vars_vals_match_holds: forall f params args targs, - List.length params = List.length args -> + list_norepet (List.map param_name params) -> val_list_inject f args targs -> + Val.has_type_list args (List.map type_of_chunk (List.map param_chunk params)) -> forall vars, - list_norepet (vars ++ List.map (@fst ident memory_chunk) params) -> + list_norepet (vars ++ List.map param_name params) -> vars_vals_match f params args - (set_locals vars (set_params targs (List.map (@fst ident memory_chunk) params))). + (set_locals vars (set_params targs (List.map param_name params))). Proof. induction vars; simpl; intros. eapply vars_vals_match_holds_1; eauto. - inversion H1. subst hd tl. + inv H2. eapply vars_vals_match_extensional; eauto. - intros. apply PTree.gso. red; intro; subst id; elim H4. - apply in_or_app. right. change a with (fst (a, lv)). apply List.in_map; auto. -Qed. - -Lemma bind_parameters_length: - forall e m1 params args m2, - bind_parameters e m1 params args m2 -> - List.length params = List.length args. -Proof. - induction 1; simpl; eauto. + intros. apply PTree.gso. red; intro; subst id; elim H5. + apply in_or_app. right. change a with (param_name (a, lv)). apply List.in_map; auto. Qed. Remark identset_removelist_charact: @@ -1815,45 +2296,44 @@ Qed. and initialize the blocks corresponding to function parameters). *) Lemma function_entry_ok: - forall fn m e m1 vargs m2 f cs tm cenv sz tm1 sp tvargs body s fn' k, + forall fn m e m1 vargs m2 f cs tm cenv tf tm1 sp tvargs body s fn' k, + list_norepet (fn_params_names fn ++ fn_vars_names fn) -> alloc_variables empty_env m (fn_variables fn) e m1 -> bind_parameters e m1 fn.(Csharpminor.fn_params) vargs m2 -> - match_callstack f cs m.(nextblock) tm.(nextblock) m -> - build_compilenv gce fn = (cenv, sz) -> - sz <= Int.max_signed -> - Mem.alloc tm 0 sz = (tm1, sp) -> + match_callstack f m tm cs (Mem.nextblock m) (Mem.nextblock tm) -> + build_compilenv gce fn = (cenv, tf.(fn_stackspace)) -> + tf.(fn_stackspace) <= Int.max_signed -> + Mem.alloc tm 0 tf.(fn_stackspace) = (tm1, sp) -> let vars := make_vars (fn_params_names fn) (fn_vars_names fn) body in let te := set_locals vars (set_params tvargs (fn_params_names fn)) in val_list_inject f vargs tvargs -> - mem_inject f m tm -> - list_norepet (fn_params_names fn ++ fn_vars_names fn) -> + Val.has_type_list vargs (Csharpminor.fn_sig fn).(sig_args) -> + Mem.inject f m tm -> store_parameters cenv fn.(Csharpminor.fn_params) = OK s -> exists f2, exists te2, exists tm2, star step tge (State fn' s k (Vptr sp Int.zero) te tm1) E0 (State fn' Sskip k (Vptr sp Int.zero) te2 tm2) - /\ mem_inject f2 m2 tm2 + /\ Mem.inject f2 m2 tm2 /\ inject_incr f f2 - /\ match_callstack f2 - (mkframe cenv e te2 sp m.(nextblock) m1.(nextblock) :: cs) - m2.(nextblock) tm2.(nextblock) m2. + /\ match_callstack f2 m2 tm2 + (Frame cenv tf e te2 sp (Mem.nextblock m) (Mem.nextblock m1) :: cs) + (Mem.nextblock m2) (Mem.nextblock tm2). Proof. - intros. - exploit bind_parameters_length; eauto. intro LEN1. + intros. exploit match_callstack_alloc_variables; eauto. intros [f1 [INCR1 [MINJ1 MATCH1]]]. exploit vars_vals_match_holds. - eauto. apply val_list_inject_incr with f. eauto. eauto. - eapply make_vars_norepet. auto. + eapply list_norepet_append_left. eexact H. + apply val_list_inject_incr with f. eauto. eauto. + auto. eapply make_vars_norepet. auto. intro VVM. exploit store_parameters_correct. - eauto. eauto. - unfold fn_params_names in H7. eapply list_norepet_append_left; eauto. - eexact MINJ1. fold (fn_params_names fn). eexact MATCH1. eauto. + eauto. eauto. eapply list_norepet_append_left; eauto. + eexact MINJ1. fold (fn_params_names fn). eexact MATCH1. eauto. intros [te2 [tm2 [EXEC [MINJ2 MATCH2]]]]. - exists f1; exists te2; exists tm2. - split. eauto. auto. + exists f1; exists te2; exists tm2. eauto. Qed. (** * Semantic preservation for the translation *) @@ -1890,11 +2370,11 @@ Proof. Qed. Lemma transl_expr_correct: - forall f m tm cenv e te sp lo hi cs - (MINJ: mem_inject f m tm) - (MATCH: match_callstack f - (mkframe cenv e te sp lo hi :: cs) - m.(nextblock) tm.(nextblock) m), + forall f m tm cenv tf e te sp lo hi cs + (MINJ: Mem.inject f m tm) + (MATCH: match_callstack f m tm + (Frame cenv tf e te sp lo hi :: cs) + (Mem.nextblock m) (Mem.nextblock tm)), forall a v, Csharpminor.eval_expr gve e m a v -> forall ta @@ -1922,7 +2402,7 @@ Proof. exists tv; split. econstructor; eauto. auto. (* Eload *) exploit IHeval_expr; eauto. intros [tv1 [EVAL1 INJ1]]. - exploit loadv_inject; eauto. intros [tv [LOAD INJ]]. + exploit Mem.loadv_inject; eauto. intros [tv [LOAD INJ]]. exists tv; split. econstructor; eauto. auto. (* Econdition *) exploit IHeval_expr1; eauto. intros [tv1 [EVAL1 INJ1]]. @@ -1935,11 +2415,11 @@ Proof. Qed. Lemma transl_exprlist_correct: - forall f m tm cenv e te sp lo hi cs - (MINJ: mem_inject f m tm) - (MATCH: match_callstack f - (mkframe cenv e te sp lo hi :: cs) - m.(nextblock) tm.(nextblock) m), + forall f m tm cenv tf e te sp lo hi cs + (MINJ: Mem.inject f m tm) + (MATCH: match_callstack f m tm + (Frame cenv tf e te sp lo hi :: cs) + (Mem.nextblock m) (Mem.nextblock tm)), forall a v, Csharpminor.eval_exprlist gve e m a v -> forall ta @@ -1957,86 +2437,84 @@ Qed. (** ** Semantic preservation for statements and functions *) -Inductive match_cont: Csharpminor.cont -> Cminor.cont -> compilenv -> exit_env -> callstack -> Prop := - | match_Kstop: forall cenv xenv, - match_cont Csharpminor.Kstop Kstop cenv xenv nil - | match_Kseq: forall s k ts tk cenv xenv cs, - transl_stmt cenv xenv s = OK ts -> - match_cont k tk cenv xenv cs -> - match_cont (Csharpminor.Kseq s k) (Kseq ts tk) cenv xenv cs - | match_Kseq2: forall s1 s2 k ts1 tk cenv xenv cs, - transl_stmt cenv xenv s1 = OK ts1 -> - match_cont (Csharpminor.Kseq s2 k) tk cenv xenv cs -> +Inductive match_cont: Csharpminor.cont -> Cminor.cont -> option typ -> compilenv -> exit_env -> callstack -> Prop := + | match_Kstop: forall ty cenv xenv, + match_cont Csharpminor.Kstop Kstop ty cenv xenv nil + | match_Kseq: forall s k ts tk ty cenv xenv cs, + transl_stmt ty cenv xenv s = OK ts -> + match_cont k tk ty cenv xenv cs -> + match_cont (Csharpminor.Kseq s k) (Kseq ts tk) ty cenv xenv cs + | match_Kseq2: forall s1 s2 k ts1 tk ty cenv xenv cs, + transl_stmt ty cenv xenv s1 = OK ts1 -> + match_cont (Csharpminor.Kseq s2 k) tk ty cenv xenv cs -> match_cont (Csharpminor.Kseq (Csharpminor.Sseq s1 s2) k) - (Kseq ts1 tk) cenv xenv cs - | match_Kblock: forall k tk cenv xenv cs, - match_cont k tk cenv xenv cs -> - match_cont (Csharpminor.Kblock k) (Kblock tk) cenv (true :: xenv) cs - | match_Kblock2: forall k tk cenv xenv cs, - match_cont k tk cenv xenv cs -> - match_cont k (Kblock tk) cenv (false :: xenv) cs - | match_Kcall_none: forall fn e k tfn sp te tk cenv xenv lo hi cs sz cenv', + (Kseq ts1 tk) ty cenv xenv cs + | match_Kblock: forall k tk ty cenv xenv cs, + match_cont k tk ty cenv xenv cs -> + match_cont (Csharpminor.Kblock k) (Kblock tk) ty cenv (true :: xenv) cs + | match_Kblock2: forall k tk ty cenv xenv cs, + match_cont k tk ty cenv xenv cs -> + match_cont k (Kblock tk) ty cenv (false :: xenv) cs + | match_Kcall_none: forall fn e k tfn sp te tk ty cenv xenv lo hi cs sz cenv', transl_funbody cenv sz fn = OK tfn -> - match_cont k tk cenv xenv cs -> + match_cont k tk fn.(fn_return) cenv xenv cs -> match_cont (Csharpminor.Kcall None fn e k) (Kcall None tfn (Vptr sp Int.zero) te tk) - cenv' nil - (mkframe cenv e te sp lo hi :: cs) - | match_Kcall_some: forall id fn e k tfn s sp te tk cenv xenv lo hi cs sz cenv', + ty cenv' nil + (Frame cenv tfn e te sp lo hi :: cs) + | match_Kcall_some: forall id fn e k tfn s sp te tk ty cenv xenv lo hi cs sz cenv', transl_funbody cenv sz fn = OK tfn -> - var_set cenv id (Evar id) = OK s -> - match_cont k tk cenv xenv cs -> + var_set_self cenv id (typ_of_opttyp ty) = OK s -> + match_cont k tk fn.(fn_return) cenv xenv cs -> match_cont (Csharpminor.Kcall (Some id) fn e k) (Kcall (Some id) tfn (Vptr sp Int.zero) te (Kseq s tk)) - cenv' nil - (mkframe cenv e te sp lo hi :: cs). + ty cenv' nil + (Frame cenv tfn e te sp lo hi :: cs). Inductive match_states: Csharpminor.state -> Cminor.state -> Prop := | match_state: forall fn s k e m tfn ts tk sp te tm cenv xenv f lo hi cs sz (TRF: transl_funbody cenv sz fn = OK tfn) - (TR: transl_stmt cenv xenv s = OK ts) - (MINJ: mem_inject f m tm) - (MCS: match_callstack f - (mkframe cenv e te sp lo hi :: cs) - m.(nextblock) tm.(nextblock) m) - (MK: match_cont k tk cenv xenv cs), + (TR: transl_stmt fn.(fn_return) cenv xenv s = OK ts) + (MINJ: Mem.inject f m tm) + (MCS: match_callstack f m tm + (Frame cenv tfn e te sp lo hi :: cs) + (Mem.nextblock m) (Mem.nextblock tm)) + (MK: match_cont k tk fn.(fn_return) cenv xenv cs), match_states (Csharpminor.State fn s k e m) (State tfn ts tk (Vptr sp Int.zero) te tm) | match_state_seq: forall fn s1 s2 k e m tfn ts1 tk sp te tm cenv xenv f lo hi cs sz (TRF: transl_funbody cenv sz fn = OK tfn) - (TR: transl_stmt cenv xenv s1 = OK ts1) - (MINJ: mem_inject f m tm) - (MCS: match_callstack f - (mkframe cenv e te sp lo hi :: cs) - m.(nextblock) tm.(nextblock) m) - (MK: match_cont (Csharpminor.Kseq s2 k) tk cenv xenv cs), + (TR: transl_stmt fn.(fn_return) cenv xenv s1 = OK ts1) + (MINJ: Mem.inject f m tm) + (MCS: match_callstack f m tm + (Frame cenv tfn e te sp lo hi :: cs) + (Mem.nextblock m) (Mem.nextblock tm)) + (MK: match_cont (Csharpminor.Kseq s2 k) tk fn.(fn_return) cenv xenv cs), match_states (Csharpminor.State fn (Csharpminor.Sseq s1 s2) k e m) (State tfn ts1 tk (Vptr sp Int.zero) te tm) | match_callstate: forall fd args k m tfd targs tk tm f cs cenv (TR: transl_fundef gce fd = OK tfd) - (MINJ: mem_inject f m tm) - (MCS: match_callstack f cs m.(nextblock) tm.(nextblock) m) - (MK: match_cont k tk cenv nil cs) + (MINJ: Mem.inject f m tm) + (MCS: match_callstack f m tm cs (Mem.nextblock m) (Mem.nextblock tm)) + (MK: match_cont k tk (Csharpminor.funsig fd).(sig_res) cenv nil cs) (ISCC: Csharpminor.is_call_cont k) - (ARGSINJ: val_list_inject f args targs), + (ARGSINJ: val_list_inject f args targs) + (ARGSTY: Val.has_type_list args (Csharpminor.funsig fd).(sig_args)), match_states (Csharpminor.Callstate fd args k m) (Callstate tfd targs tk tm) | match_returnstate: - forall v k m tv tk tm f cs cenv - (MINJ: mem_inject f m tm) - (MCS: match_callstack f cs m.(nextblock) tm.(nextblock) m) - (MK: match_cont k tk cenv nil cs) - (RESINJ: val_inject f v tv), + forall v k m tv tk tm f cs ty cenv + (MINJ: Mem.inject f m tm) + (MCS: match_callstack f m tm cs (Mem.nextblock m) (Mem.nextblock tm)) + (MK: match_cont k tk ty cenv nil cs) + (RESINJ: val_inject f v tv) + (RESTY: Val.has_type v (typ_of_opttyp ty)), match_states (Csharpminor.Returnstate v k m) (Returnstate tv tk tm). -Remark nextblock_freelist: - forall lb m, nextblock (free_list m lb) = nextblock m. -Proof. induction lb; intros; simpl; auto. Qed. - Remark val_inject_function_pointer: forall v fd f tv, Genv.find_funct tge v = Some fd -> @@ -2052,22 +2530,22 @@ Proof. Qed. Lemma match_call_cont: - forall k tk cenv xenv cs, - match_cont k tk cenv xenv cs -> - match_cont (Csharpminor.call_cont k) (call_cont tk) cenv nil cs. + forall k tk ty cenv xenv cs, + match_cont k tk ty cenv xenv cs -> + match_cont (Csharpminor.call_cont k) (call_cont tk) ty cenv nil cs. Proof. induction 1; simpl; auto; econstructor; eauto. Qed. Lemma match_is_call_cont: - forall tfn te sp tm k tk cenv xenv cs, - match_cont k tk cenv xenv cs -> + forall tfn te sp tm k tk ty cenv xenv cs, + match_cont k tk ty cenv xenv cs -> Csharpminor.is_call_cont k -> exists tk', star step tge (State tfn Sskip tk sp te tm) E0 (State tfn Sskip tk' sp te tm) /\ is_call_cont tk' - /\ match_cont k tk' cenv nil cs. + /\ match_cont k tk' ty cenv nil cs. Proof. induction 1; simpl; intros; try contradiction. econstructor; split. apply star_refl. split. exact I. econstructor; eauto. @@ -2080,8 +2558,6 @@ Qed. (** Properties of [switch] compilation *) -Require Import Switch. - Remark switch_table_shift: forall n sl base dfl, switch_target n (S dfl) (switch_table sl (S base)) = @@ -2097,20 +2573,20 @@ Proof. induction sl; intros; simpl. auto. decEq; auto. Qed. -Inductive transl_lblstmt_cont (cenv: compilenv) (xenv: exit_env): lbl_stmt -> cont -> cont -> Prop := +Inductive transl_lblstmt_cont (ty: option typ) (cenv: compilenv) (xenv: exit_env): lbl_stmt -> cont -> cont -> Prop := | tlsc_default: forall s k ts, - transl_stmt cenv (switch_env (LSdefault s) xenv) s = OK ts -> - transl_lblstmt_cont cenv xenv (LSdefault s) k (Kblock (Kseq ts k)) + transl_stmt ty cenv (switch_env (LSdefault s) xenv) s = OK ts -> + transl_lblstmt_cont ty cenv xenv (LSdefault s) k (Kblock (Kseq ts k)) | tlsc_case: forall i s ls k ts k', - transl_stmt cenv (switch_env (LScase i s ls) xenv) s = OK ts -> - transl_lblstmt_cont cenv xenv ls k k' -> - transl_lblstmt_cont cenv xenv (LScase i s ls) k (Kblock (Kseq ts k')). + transl_stmt ty cenv (switch_env (LScase i s ls) xenv) s = OK ts -> + transl_lblstmt_cont ty cenv xenv ls k k' -> + transl_lblstmt_cont ty cenv xenv (LScase i s ls) k (Kblock (Kseq ts k')). Lemma switch_descent: - forall cenv xenv k ls body s, - transl_lblstmt cenv (switch_env ls xenv) ls body = OK s -> + forall ty cenv xenv k ls body s, + transl_lblstmt ty cenv (switch_env ls xenv) ls body = OK s -> exists k', - transl_lblstmt_cont cenv xenv ls k k' + transl_lblstmt_cont ty cenv xenv ls k k' /\ (forall f sp e m, plus step tge (State f s k sp e m) E0 (State f body k' sp e m)). Proof. @@ -2127,14 +2603,14 @@ Proof. Qed. Lemma switch_ascent: - forall f n sp e m cenv xenv k ls k1, + forall f n sp e m ty cenv xenv k ls k1, let tbl := switch_table ls O in let ls' := select_switch n ls in - transl_lblstmt_cont cenv xenv ls k k1 -> + transl_lblstmt_cont ty cenv xenv ls k k1 -> exists k2, star step tge (State f (Sexit (switch_target n (length tbl) tbl)) k1 sp e m) E0 (State f (Sexit O) k2 sp e m) - /\ transl_lblstmt_cont cenv xenv ls' k k2. + /\ transl_lblstmt_cont ty cenv xenv ls' k k2. Proof. induction ls; intros; unfold tbl, ls'; simpl. inv H. econstructor; split. apply star_refl. econstructor; eauto. @@ -2151,10 +2627,10 @@ Proof. Qed. Lemma switch_match_cont: - forall cenv xenv k cs tk ls tk', - match_cont k tk cenv xenv cs -> - transl_lblstmt_cont cenv xenv ls tk tk' -> - match_cont (Csharpminor.Kseq (seq_of_lbl_stmt ls) k) tk' cenv (false :: switch_env ls xenv) cs. + forall ty cenv xenv k cs tk ls tk', + match_cont k tk ty cenv xenv cs -> + transl_lblstmt_cont ty cenv xenv ls tk tk' -> + match_cont (Csharpminor.Kseq (seq_of_lbl_stmt ls) k) tk' ty cenv (false :: switch_env ls xenv) cs. Proof. induction ls; intros; simpl. inv H0. apply match_Kblock2. econstructor; eauto. @@ -2162,11 +2638,11 @@ Proof. Qed. Lemma transl_lblstmt_suffix: - forall n cenv xenv ls body ts, - transl_lblstmt cenv (switch_env ls xenv) ls body = OK ts -> + forall n ty cenv xenv ls body ts, + transl_lblstmt ty cenv (switch_env ls xenv) ls body = OK ts -> let ls' := select_switch n ls in exists body', exists ts', - transl_lblstmt cenv (switch_env ls' xenv) ls' body' = OK ts'. + transl_lblstmt ty cenv (switch_env ls' xenv) ls' body' = OK ts'. Proof. induction ls; simpl; intros. monadInv H. @@ -2180,13 +2656,13 @@ Qed. Lemma switch_match_states: forall fn k e m tfn ts tk sp te tm cenv xenv f lo hi cs sz ls body tk' (TRF: transl_funbody cenv sz fn = OK tfn) - (TR: transl_lblstmt cenv (switch_env ls xenv) ls body = OK ts) - (MINJ: mem_inject f m tm) - (MCS: match_callstack f - (mkframe cenv e te sp lo hi :: cs) - m.(nextblock) tm.(nextblock) m) - (MK: match_cont k tk cenv xenv cs) - (TK: transl_lblstmt_cont cenv xenv ls tk tk'), + (TR: transl_lblstmt (fn_return fn) cenv (switch_env ls xenv) ls body = OK ts) + (MINJ: Mem.inject f m tm) + (MCS: match_callstack f m tm + (Frame cenv tfn e te sp lo hi :: cs) + (Mem.nextblock m) (Mem.nextblock tm)) + (MK: match_cont k tk (fn_return fn) cenv xenv cs) + (TK: transl_lblstmt_cont (fn_return fn) cenv xenv ls tk tk'), exists S, plus step tge (State tfn (Sexit O) tk' (Vptr sp Int.zero) te tm) E0 S /\ match_states (Csharpminor.State fn (seq_of_lbl_stmt ls) k e m) S. @@ -2206,22 +2682,35 @@ Qed. Section FIND_LABEL. Variable lbl: label. +Variable ty: option typ. Variable cenv: compilenv. Variable cs: callstack. Remark find_label_var_set: - forall id e s k, - var_set cenv id e = OK s -> + forall id e chunk s k, + var_set cenv id e chunk = OK s -> find_label lbl s k = None. Proof. intros. unfold var_set in H. - destruct (cenv!!id); monadInv H; reflexivity. + destruct (cenv!!id); try (monadInv H; reflexivity). + destruct (chunktype_compat chunk m). inv H; auto. + destruct (typ_eq (type_of_chunk m) (type_of_chunk chunk)); inv H; auto. +Qed. + +Remark find_label_var_set_self: + forall id ty s k, + var_set_self cenv id ty = OK s -> + find_label lbl s k = None. +Proof. + intros. unfold var_set_self in H. + destruct (cenv!!id); try (monadInv H; reflexivity). + destruct (typ_eq (type_of_chunk m) ty0); inv H; reflexivity. Qed. Lemma transl_lblstmt_find_label_context: - forall cenv xenv ls body ts tk1 tk2 ts' tk', - transl_lblstmt cenv (switch_env ls xenv) ls body = OK ts -> - transl_lblstmt_cont cenv xenv ls tk1 tk2 -> + forall xenv ls body ts tk1 tk2 ts' tk', + transl_lblstmt ty cenv (switch_env ls xenv) ls body = OK ts -> + transl_lblstmt_cont ty cenv xenv ls tk1 tk2 -> find_label lbl body tk2 = Some (ts', tk') -> find_label lbl ts tk1 = Some (ts', tk'). Proof. @@ -2234,30 +2723,30 @@ Qed. Lemma transl_find_label: forall s k xenv ts tk, - transl_stmt cenv xenv s = OK ts -> - match_cont k tk cenv xenv cs -> + transl_stmt ty cenv xenv s = OK ts -> + match_cont k tk ty cenv xenv cs -> match Csharpminor.find_label lbl s k with | None => find_label lbl ts tk = None | Some(s', k') => exists ts', exists tk', exists xenv', find_label lbl ts tk = Some(ts', tk') - /\ transl_stmt cenv xenv' s' = OK ts' - /\ match_cont k' tk' cenv xenv' cs + /\ transl_stmt ty cenv xenv' s' = OK ts' + /\ match_cont k' tk' ty cenv xenv' cs end with transl_lblstmt_find_label: forall ls xenv body k ts tk tk1, - transl_lblstmt cenv (switch_env ls xenv) ls body = OK ts -> - match_cont k tk cenv xenv cs -> - transl_lblstmt_cont cenv xenv ls tk tk1 -> + transl_lblstmt ty cenv (switch_env ls xenv) ls body = OK ts -> + match_cont k tk ty cenv xenv cs -> + transl_lblstmt_cont ty cenv xenv ls tk tk1 -> find_label lbl body tk1 = None -> match Csharpminor.find_label_ls lbl ls k with | None => find_label lbl ts tk = None | Some(s', k') => exists ts', exists tk', exists xenv', find_label lbl ts tk = Some(ts', tk') - /\ transl_stmt cenv xenv' s' = OK ts' - /\ match_cont k' tk' cenv xenv' cs + /\ transl_stmt ty cenv xenv' s' = OK ts' + /\ match_cont k' tk' ty cenv xenv' cs end. Proof. intros. destruct s; try (monadInv H); simpl; auto. @@ -2265,7 +2754,10 @@ Proof. eapply find_label_var_set; eauto. (* call *) destruct o; monadInv H; simpl; auto. - eapply find_label_var_set; eauto. + destruct (list_eq_dec typ_eq x1 (sig_args s)); monadInv EQ4. + simpl. eapply find_label_var_set_self; eauto. + destruct (list_eq_dec typ_eq x1 (sig_args s)); monadInv EQ3. + simpl; eauto. (* seq *) exploit (transl_find_label s1). eauto. eapply match_Kseq. eexact EQ1. eauto. destruct (Csharpminor.find_label lbl s1 (Csharpminor.Kseq s2 k)) as [[s' k'] | ]. @@ -2287,6 +2779,7 @@ Proof. eapply transl_lblstmt_find_label. eauto. eauto. eauto. reflexivity. (* return *) destruct o; monadInv H; auto. + destruct (typ_eq x0 (typ_of_opttyp ty)); monadInv EQ2; auto. (* label *) destruct (ident_eq lbl l). exists x; exists tk; exists xenv; auto. @@ -2316,7 +2809,7 @@ Proof. induction vars; intros. monadInv H. auto. simpl in H. destruct a as [id lv]. monadInv H. - simpl. rewrite (find_label_var_set id (Evar id)); auto. + simpl. rewrite (find_label_var_set_self id (type_of_chunk lv)); auto. Qed. End FIND_LABEL. @@ -2324,12 +2817,12 @@ End FIND_LABEL. Lemma transl_find_label_body: forall cenv xenv size f tf k tk cs lbl s' k', transl_funbody cenv size f = OK tf -> - match_cont k tk cenv xenv cs -> + match_cont k tk (fn_return f) cenv xenv cs -> Csharpminor.find_label lbl f.(Csharpminor.fn_body) (Csharpminor.call_cont k) = Some (s', k') -> exists ts', exists tk', exists xenv', find_label lbl tf.(fn_body) (call_cont tk) = Some(ts', tk') - /\ transl_stmt cenv xenv' s' = OK ts' - /\ match_cont k' tk' cenv xenv' cs. + /\ transl_stmt (fn_return f) cenv xenv' s' = OK ts' + /\ match_cont k' tk' (fn_return f) cenv xenv' cs. Proof. intros. monadInv H. simpl. rewrite (find_label_store_parameters lbl cenv (Csharpminor.fn_params f)); auto. @@ -2337,8 +2830,7 @@ Proof. instantiate (1 := lbl). rewrite H1. auto. Qed. - -Require Import Coq.Program.Equality. +(** The simulation diagram. *) Fixpoint seq_left_depth (s: Csharpminor.stmt) : nat := match s with @@ -2384,16 +2876,17 @@ Proof. (* skip call *) monadInv TR. left. exploit match_is_call_cont; eauto. intros [tk' [A [B C]]]. - exploit match_callstack_freelist; eauto. intros [P Q]. + exploit match_callstack_freelist; eauto. intros [tm' [P [Q R]]]. econstructor; split. eapply plus_right. eexact A. apply step_skip_call. auto. - rewrite (sig_preserved_body _ _ _ _ TRF). auto. traceEq. - econstructor; eauto. rewrite nextblock_freelist. simpl. eauto. + rewrite (sig_preserved_body _ _ _ _ TRF). auto. eauto. traceEq. + econstructor; eauto. exact I. (* assign *) monadInv TR. exploit transl_expr_correct; eauto. intros [tv [EVAL VINJ]]. - exploit var_set_correct; eauto. intros [te' [tm' [EXEC [MINJ' [MCS' OTHER]]]]]. + exploit var_set_correct; eauto. eapply chunktype_expr_correct; eauto. + intros [te' [tm' [EXEC [MINJ' [MCS' OTHER]]]]]. left; econstructor; split. apply plus_one. eexact EXEC. econstructor; eauto. @@ -2405,19 +2898,20 @@ Proof. exploit transl_expr_correct. eauto. eauto. eexact H0. eauto. intros [tv2 [EVAL2 VINJ2]]. exploit make_store_correct. eexact EVAL1. eexact EVAL2. eauto. eauto. auto. auto. - intros [tm' [EXEC [MINJ' NEXTBLOCK]]]. + intros [tm' [tv' [EXEC [STORE' MINJ']]]]. left; econstructor; split. apply plus_one. eexact EXEC. - unfold storev in H1; destruct vaddr; try discriminate. econstructor; eauto. - replace (nextblock m') with (nextblock m). rewrite NEXTBLOCK. eauto. - eapply match_callstack_mapped; eauto. inv VINJ1. congruence. - symmetry. eapply nextblock_store; eauto. + eapply match_callstack_storev_mapped. eexact VINJ1. eauto. eauto. + rewrite (nextblock_storev _ _ _ _ _ H1). + rewrite (nextblock_storev _ _ _ _ _ STORE'). + eauto. (* call *) simpl in H1. exploit functions_translated; eauto. intros [tfd [FIND TRANS]]. simpl in TR. destruct optid; monadInv TR. (* with return value *) + destruct (list_eq_dec typ_eq x1 (sig_args (Csharpminor.funsig fd))); monadInv EQ4. exploit transl_expr_correct; eauto. intros [tvf [EVAL1 VINJ1]]. assert (tvf = vf). @@ -2434,7 +2928,10 @@ Proof. econstructor; eauto. eapply match_Kcall_some with (cenv' := cenv); eauto. red; auto. + eapply type_exprlist_correct; eauto. + (* without return value *) + destruct (list_eq_dec typ_eq x1 (sig_args (Csharpminor.funsig fd))); monadInv EQ3. exploit transl_expr_correct; eauto. intros [tvf [EVAL1 VINJ1]]. assert (tvf = vf). @@ -2450,6 +2947,7 @@ Proof. econstructor; eauto. eapply match_Kcall_none with (cenv' := cenv); eauto. red; auto. + eapply type_exprlist_correct; eauto. (* seq *) monadInv TR. @@ -2531,23 +3029,21 @@ Proof. (* return none *) monadInv TR. left. - exploit match_callstack_freelist; eauto. intros [A B]. + exploit match_callstack_freelist; eauto. intros [tm' [A [B C]]]. econstructor; split. - apply plus_one. apply step_return_0. -(* - rewrite (sig_preserved_body _ _ _ _ TRF). auto. -*) - econstructor; eauto. rewrite nextblock_freelist. simpl. eauto. - eapply match_call_cont; eauto. + apply plus_one. eapply step_return_0. eauto. + econstructor; eauto. eapply match_call_cont; eauto. + simpl; auto. (* return some *) - monadInv TR. left. + monadInv TR. destruct (typ_eq x0 (typ_of_opttyp (fn_return f))); monadInv EQ2. + left. exploit transl_expr_correct; eauto. intros [tv [EVAL VINJ]]. - exploit match_callstack_freelist; eauto. intros [A B]. + exploit match_callstack_freelist; eauto. intros [tm' [A [B C]]]. econstructor; split. - apply plus_one. apply step_return_1. eauto. - econstructor; eauto. rewrite nextblock_freelist. simpl. eauto. - eapply match_call_cont; eauto. + apply plus_one. eapply step_return_1. eauto. eauto. + econstructor; eauto. eapply match_call_cont; eauto. + eapply type_expr_correct; eauto. (* label *) monadInv TR. @@ -2569,8 +3065,11 @@ Proof. destruct (zle sz Int.max_signed); try congruence. intro TRBODY. generalize TRBODY; intro TMP. monadInv TMP. - caseEq (alloc tm 0 sz). intros tm' sp ALLOC'. - exploit function_entry_ok; eauto. + set (tf := mkfunction (Csharpminor.fn_sig f) (fn_params_names f) + (make_vars (fn_params_names f) (fn_vars_names f) (Sseq x1 x0)) + sz (Sseq x1 x0)) in *. + caseEq (Mem.alloc tm 0 (fn_stackspace tf)). intros tm' sp ALLOC'. + exploit function_entry_ok; eauto; simpl; auto. intros [f2 [te2 [tm2 [EXEC [MINJ2 [IINCR MCS2]]]]]]. left; econstructor; split. eapply plus_left. constructor; simpl; eauto. @@ -2583,10 +3082,19 @@ Proof. (* external call *) monadInv TR. - exploit event_match_inject; eauto. intros [A B]. + exploit external_call_mem_inject; eauto. + intros [f' [vres' [tm' [EC [VINJ [MINJ' [UNMAPPED [OUTOFREACH [INCR SEPARATED]]]]]]]]]. left; econstructor; split. apply plus_one. econstructor; eauto. econstructor; eauto. + apply match_callstack_incr_bound with (Mem.nextblock m) (Mem.nextblock tm). + eapply match_callstack_external_call; eauto. + intros. eapply external_call_bounds; eauto. + omega. omega. + eapply external_call_nextblock_incr; eauto. + eapply external_call_nextblock_incr; eauto. + simpl. change (Val.has_type vres (proj_sig_res (ef_sig ef))). + eapply external_call_well_typed; eauto. (* return *) inv MK; inv H. @@ -2595,26 +3103,29 @@ Proof. apply plus_one. econstructor; eauto. simpl. econstructor; eauto. (* one argument *) - exploit var_set_self_correct; eauto. - intros [te' [tm' [A [B C]]]]. + exploit var_set_self_correct. eauto. eauto. eauto. eauto. eauto. eauto. + instantiate (1 := PTree.set id tv te). apply PTree.gss. + intros; apply PTree.gso; auto. + intros [te' [tm' [A [B [C D]]]]]. left; econstructor; split. eapply plus_left. econstructor. simpl. eapply star_left. econstructor. eapply star_one. eexact A. reflexivity. traceEq. - econstructor; eauto. + econstructor; eauto. Qed. Lemma match_globalenvs_init: - let m := Genv.init_mem prog in - match_globalenvs (meminj_init m). + forall m, + Genv.init_mem prog = Some m -> + match_globalenvs (Mem.flat_inj (Mem.nextblock m)). Proof. intros. constructor. intros. split. - unfold meminj_init. rewrite zlt_true. auto. - unfold m; eapply Genv.find_symbol_not_fresh; eauto. - rewrite <- H. apply symbols_preserved. - intros. unfold meminj_init. rewrite zlt_true. auto. - generalize (nextblock_pos m). omega. + unfold Mem.flat_inj. rewrite zlt_true. auto. + eapply Genv.find_symbol_not_fresh; eauto. + rewrite <- H0. apply symbols_preserved. + intros. unfold Mem.flat_inj. rewrite zlt_true. auto. + generalize (Mem.nextblock_pos m). omega. Qed. Lemma transl_initial_states: @@ -2625,21 +3136,19 @@ Proof. exploit function_ptr_translated; eauto. intros [tf [FIND TR]]. econstructor; split. econstructor. + apply (Genv.init_mem_transf_partial2 _ _ _ TRANSL). eauto. simpl. fold tge. rewrite symbols_preserved. - replace (prog_main tprog) with (prog_main prog). eexact H. + replace (prog_main tprog) with (prog_main prog). eexact H0. symmetry. unfold transl_program in TRANSL. eapply transform_partial_program2_main; eauto. eexact FIND. - rewrite <- H1. apply sig_preserved; auto. - rewrite (Genv.init_mem_transf_partial2 _ _ _ TRANSL). - fold m0. - eapply match_callstate with (f := meminj_init m0) (cs := @nil frame). + rewrite <- H2. apply sig_preserved; auto. + eapply match_callstate with (f := Mem.flat_inj (Mem.nextblock m0)) (cs := @nil frame). auto. - apply init_inject. unfold m0. apply Genv.initmem_inject_neutral. - constructor. apply match_globalenvs_init. + eapply Genv.initmem_inject; eauto. + constructor. apply match_globalenvs_init. auto. instantiate (1 := gce). constructor. - red; auto. - constructor. + red; auto. constructor. rewrite H2; simpl; auto. Qed. Lemma transl_final_states: diff --git a/cfrontend/Csem.v b/cfrontend/Csem.v index f352df7..bd26b0f 100644 --- a/cfrontend/Csem.v +++ b/cfrontend/Csem.v @@ -22,7 +22,7 @@ Require Import Integers. Require Import Floats. Require Import Values. Require Import AST. -Require Import Mem. +Require Import Memory. Require Import Events. Require Import Globalenvs. Require Import Csyntax. @@ -294,8 +294,8 @@ Function sem_cmp (c:comparison) match v1,v2 with | Vint n1, Vint n2 => Some (Val.of_bool (Int.cmp c n1 n2)) | Vptr b1 ofs1, Vptr b2 ofs2 => - if valid_pointer m b1 (Int.signed ofs1) - && valid_pointer m b2 (Int.signed ofs2) then + if Mem.valid_pointer m b1 (Int.signed ofs1) + && Mem.valid_pointer m b2 (Int.signed ofs2) then if zeq b1 b2 then Some (Val.of_bool (Int.cmp c ofs1 ofs2)) else sem_cmp_mismatch c @@ -412,15 +412,15 @@ Inductive cast : val -> type -> type -> val -> Prop := maps names of functions and global variables to memory block references, and function pointers to their definitions. (See module [Globalenvs].) *) -Definition genv := Genv.t fundef. +Definition genv := Genv.t fundef type. (** The local environment maps local variables to block references. The current value of the variable is stored in the associated memory block. *) -Definition env := PTree.t block. (* map variable -> location *) +Definition env := PTree.t (block * type). (* map variable -> location & type *) -Definition empty_env: env := (PTree.empty block). +Definition empty_env: env := (PTree.empty (block * type)). (** [load_value_of_type ty m b ofs] computes the value of a datum of type [ty] residing in memory [m] at block [b], offset [ofs]. @@ -463,7 +463,7 @@ Inductive alloc_variables: env -> mem -> | alloc_variables_cons: forall e m id ty vars m1 b1 m2 e2, Mem.alloc m 0 (sizeof ty) = (m1, b1) -> - alloc_variables (PTree.set id b1 e) m1 vars e2 m2 -> + alloc_variables (PTree.set id (b1, ty) e) m1 vars e2 m2 -> alloc_variables e m ((id, ty) :: vars) e2 m2. (** Initialization of local variables that are parameters to a function. @@ -479,15 +479,18 @@ Inductive bind_parameters: env -> bind_parameters e m nil nil m | bind_parameters_cons: forall e m id ty params v1 vl b m1 m2, - PTree.get id e = Some b -> + PTree.get id e = Some(b, ty) -> store_value_of_type ty m b Int.zero v1 = Some m1 -> bind_parameters e m1 params vl m2 -> bind_parameters e m ((id, ty) :: params) (v1 :: vl) m2. -(** Return the list of blocks in the codomain of [e]. *) +(** Return the list of blocks in the codomain of [e], with low and high bounds. *) -Definition blocks_of_env (e: env) : list block := - List.map (@snd ident block) (PTree.elements e). +Definition block_of_binding (id_b_ty: ident * (block * type)) := + match id_b_ty with (id, (b, ty)) => (b, 0, sizeof ty) end. + +Definition blocks_of_env (e: env) : list (block * Z * Z) := + List.map block_of_binding (PTree.elements e). (** Selection of the appropriate case of a [switch], given the value [n] of the selector expression. *) @@ -586,7 +589,7 @@ Inductive eval_expr: expr -> val -> Prop := with eval_lvalue: expr -> block -> int -> Prop := | eval_Evar_local: forall id l ty, - e!id = Some l -> + e!id = Some(l, ty) -> eval_lvalue (Expr (Evar id) ty) l Int.zero | eval_Evar_global: forall id l ty, e!id = None -> @@ -844,20 +847,23 @@ Inductive step: state -> trace -> state -> Prop := step (State f Sskip (Kfor3 a2 a3 s k) e m) E0 (State f (Sfor Sskip a2 a3 s) k e m) - | step_return_0: forall f k e m, + | step_return_0: forall f k e m m', f.(fn_return) = Tvoid -> + Mem.free_list m (blocks_of_env e) = Some m' -> step (State f (Sreturn None) k e m) - E0 (Returnstate Vundef (call_cont k) (Mem.free_list m (blocks_of_env e))) - | step_return_1: forall f a k e m v, + E0 (Returnstate Vundef (call_cont k) m') + | step_return_1: forall f a k e m v m', f.(fn_return) <> Tvoid -> eval_expr e m a v -> + Mem.free_list m (blocks_of_env e) = Some m' -> step (State f (Sreturn (Some a)) k e m) - E0 (Returnstate v (call_cont k) (Mem.free_list m (blocks_of_env e))) - | step_skip_call: forall f k e m, + E0 (Returnstate v (call_cont k) m') + | step_skip_call: forall f k e m m', is_call_cont k -> f.(fn_return) = Tvoid -> + Mem.free_list m (blocks_of_env e) = Some m' -> step (State f Sskip k e m) - E0 (Returnstate Vundef k (Mem.free_list m (blocks_of_env e))) + E0 (Returnstate Vundef k m') | step_switch: forall f a sl k e m n, eval_expr e m a (Vint n) -> @@ -886,10 +892,10 @@ Inductive step: state -> trace -> state -> Prop := step (Callstate (Internal f) vargs k m) E0 (State f f.(fn_body) k e m2) - | step_external_function: forall id targs tres vargs k m vres t, - event_match (external_function id targs tres) vargs t vres -> + | step_external_function: forall id targs tres vargs k m vres t m', + external_call (external_function id targs tres) vargs m t vres m' -> step (Callstate (External id targs tres) vargs k m) - t (Returnstate vres k m) + t (Returnstate vres k m') | step_returnstate_0: forall v f e k m, step (Returnstate v (Kcall None f e k) m) @@ -1084,15 +1090,16 @@ Inductive exec_stmt: env -> mem -> statement -> trace -> mem -> outcome -> Prop by the call. *) with eval_funcall: mem -> fundef -> list val -> trace -> mem -> val -> Prop := - | eval_funcall_internal: forall m f vargs t e m1 m2 m3 out vres, + | eval_funcall_internal: forall m f vargs t e m1 m2 m3 out vres m4, alloc_variables empty_env m (f.(fn_params) ++ f.(fn_vars)) e m1 -> bind_parameters e m1 f.(fn_params) vargs m2 -> exec_stmt e m2 f.(fn_body) t m3 out -> outcome_result_value out f.(fn_return) vres -> - eval_funcall m (Internal f) vargs t (Mem.free_list m3 (blocks_of_env e)) vres - | eval_funcall_external: forall m id targs tres vargs t vres, - event_match (external_function id targs tres) vargs t vres -> - eval_funcall m (External id targs tres) vargs t m vres. + Mem.free_list m3 (blocks_of_env e) = Some m4 -> + eval_funcall m (Internal f) vargs t m4 vres + | eval_funcall_external: forall m id targs tres vargs t vres m', + external_call (external_function id targs tres) vargs m t vres m' -> + eval_funcall m (External id targs tres) vargs t m' vres. Scheme exec_stmt_ind2 := Minimality for exec_stmt Sort Prop with eval_funcall_ind2 := Minimality for eval_funcall Sort Prop. @@ -1212,9 +1219,9 @@ End SEMANTICS. without arguments and with an empty continuation. *) Inductive initial_state (p: program): state -> Prop := - | initial_state_intro: forall b f, + | initial_state_intro: forall b f m0, let ge := Genv.globalenv p in - let m0 := Genv.init_mem p in + Genv.init_mem p = Some m0 -> Genv.find_symbol ge p.(prog_main) = Some b -> Genv.find_funct_ptr ge b = Some f -> initial_state p (Callstate f nil Kstop m0). @@ -1236,18 +1243,18 @@ Definition exec_program (p: program) (beh: program_behavior) : Prop := (** Big-step execution of a whole program. *) Inductive bigstep_program_terminates (p: program): trace -> int -> Prop := - | bigstep_program_terminates_intro: forall b f m1 t r, + | bigstep_program_terminates_intro: forall b f m0 m1 t r, let ge := Genv.globalenv p in - let m0 := Genv.init_mem p in + Genv.init_mem p = Some m0 -> Genv.find_symbol ge p.(prog_main) = Some b -> Genv.find_funct_ptr ge b = Some f -> eval_funcall ge m0 f nil t m1 (Vint r) -> bigstep_program_terminates p t r. Inductive bigstep_program_diverges (p: program): traceinf -> Prop := - | bigstep_program_diverges_intro: forall b f t, + | bigstep_program_diverges_intro: forall b f m0 t, let ge := Genv.globalenv p in - let m0 := Genv.init_mem p in + Genv.init_mem p = Some m0 -> Genv.find_symbol ge p.(prog_main) = Some b -> Genv.find_funct_ptr ge b = Some f -> evalinf_funcall ge m0 f nil t -> @@ -1525,16 +1532,16 @@ Proof. (* Out_normal *) assert (fn_return f = Tvoid /\ vres = Vundef). destruct (fn_return f); auto || contradiction. - destruct H5. subst vres. apply step_skip_call; auto. + destruct H6. subst vres. apply step_skip_call; auto. (* Out_return None *) assert (fn_return f = Tvoid /\ vres = Vundef). destruct (fn_return f); auto || contradiction. - destruct H6. subst vres. - rewrite <- (is_call_cont_call_cont k H4). rewrite <- H5. + destruct H7. subst vres. + rewrite <- (is_call_cont_call_cont k H5). rewrite <- H6. apply step_return_0; auto. (* Out_return Some *) destruct H3. subst vres. - rewrite <- (is_call_cont_call_cont k H4). rewrite <- H5. + rewrite <- (is_call_cont_call_cont k H5). rewrite <- H6. eapply step_return_1; eauto. reflexivity. traceEq. @@ -1697,9 +1704,9 @@ Qed. Theorem bigstep_program_terminates_exec: forall t r, bigstep_program_terminates prog t r -> exec_program prog (Terminates t r). Proof. - intros. inv H. unfold ge0, m0 in *. + intros. inv H. econstructor. - econstructor. eauto. eauto. + econstructor. eauto. eauto. eauto. apply eval_funcall_steps. eauto. red; auto. econstructor. Qed. @@ -1717,7 +1724,7 @@ Proof. eapply evalinf_funcall_forever; eauto. destruct (forever_silent_or_reactive _ _ _ _ _ _ H) as [A | [t [s' [T' [B [C D]]]]]]. - left. econstructor. econstructor. eauto. eauto. auto. + left. econstructor. econstructor; eauto. eauto. right. exists t. split. econstructor. econstructor; eauto. eauto. auto. subst T. rewrite <- (E0_right t) at 1. apply traceinf_prefix_app. constructor. diff --git a/cfrontend/Csharpminor.v b/cfrontend/Csharpminor.v index 5cdbd84..2fddc6c 100644 --- a/cfrontend/Csharpminor.v +++ b/cfrontend/Csharpminor.v @@ -18,7 +18,7 @@ Require Import AST. Require Import Integers. Require Import Floats. Require Import Values. -Require Import Mem. +Require Import Memory. Require Import Events. Require Import Globalenvs. Require Cminor. @@ -89,13 +89,24 @@ Inductive var_kind : Type := | Vscalar: memory_chunk -> var_kind | Varray: Z -> var_kind. -(** Functions are composed of a signature, a list of parameter names +Definition sizeof (lv: var_kind) : Z := + match lv with + | Vscalar chunk => size_chunk chunk + | Varray sz => Zmax 0 sz + end. + +(** Functions are composed of a return type, a list of parameter names with associated memory chunks (parameters must be scalar), a list of local variables with associated [var_kind] description, and a statement representing the function body. *) +Definition param_name (p: ident * memory_chunk) := fst p. +Definition param_chunk (p: ident * memory_chunk) := snd p. +Definition variable_name (v: ident * var_kind) := fst v. +Definition variable_kind (v: ident * var_kind) := snd v. + Record function : Type := mkfunction { - fn_sig: signature; + fn_return: option typ; fn_params: list (ident * memory_chunk); fn_vars: list (ident * var_kind); fn_body: stmt @@ -105,12 +116,25 @@ Definition fundef := AST.fundef function. Definition program : Type := AST.program fundef var_kind. +Definition fn_sig (f: function) := + mksignature (List.map type_of_chunk (List.map param_chunk f.(fn_params))) + f.(fn_return). + Definition funsig (fd: fundef) := match fd with - | Internal f => f.(fn_sig) - | External ef => ef.(ef_sig) + | Internal f => fn_sig f + | External ef => ef_sig ef end. +Definition var_of_param (p: ident * memory_chunk) : ident * var_kind := + (fst p, Vscalar (snd p)). + +Definition fn_variables (f: function) := + List.map var_of_param f.(fn_params) ++ f.(fn_vars). + +Definition fn_params_names (f: function) := List.map param_name f.(fn_params). +Definition fn_vars_names (f: function) := List.map variable_name f.(fn_vars). + (** * Operational semantics *) (** Three kinds of evaluation environments are involved: @@ -120,28 +144,11 @@ Definition funsig (fd: fundef) := to memory blocks and variable informations. *) -Definition genv := Genv.t fundef. +Definition genv := Genv.t fundef var_kind. Definition gvarenv := PTree.t var_kind. Definition env := PTree.t (block * var_kind). Definition empty_env : env := PTree.empty (block * var_kind). -Definition sizeof (lv: var_kind) : Z := - match lv with - | Vscalar chunk => size_chunk chunk - | Varray sz => Zmax 0 sz - end. - -Definition fn_variables (f: function) := - List.map - (fun id_chunk => (fst id_chunk, Vscalar (snd id_chunk))) f.(fn_params) - ++ f.(fn_vars). - -Definition fn_params_names (f: function) := - List.map (@fst ident memory_chunk) f.(fn_params). - -Definition fn_vars_names (f: function) := - List.map (@fst ident var_kind) f.(fn_vars). - (** Continuations *) Inductive cont: Type := @@ -256,8 +263,8 @@ Definition eval_binop (op: binary_operation) (arg1 arg2: val) (m: mem): option val := match op, arg1, arg2 with | Cminor.Ocmp c, Vptr b1 n1, Vptr b2 n2 => - if valid_pointer m b1 (Int.signed n1) - && valid_pointer m b2 (Int.signed n2) + if Mem.valid_pointer m b1 (Int.signed n1) + && Mem.valid_pointer m b2 (Int.signed n2) then Cminor.eval_binop op arg1 arg2 else None | _, _, _ => @@ -279,11 +286,13 @@ Inductive alloc_variables: env -> mem -> alloc_variables (PTree.set id (b1, lv) e) m1 vars e2 m2 -> alloc_variables e m ((id, lv) :: vars) e2 m2. -(** List of blocks mentioned in an environment *) +(** List of blocks mentioned in an environment, with low and high bounds *) + +Definition block_of_binding (id_b_lv: ident * (block * var_kind)) := + match id_b_lv with (id, (b, lv)) => (b, 0, sizeof lv) end. -Definition blocks_of_env (e: env) : list block := - List.map (fun id_b_lv => match id_b_lv with (id, (b, lv)) => b end) - (PTree.elements e). +Definition blocks_of_env (e: env) : list (block * Z * Z) := + List.map block_of_binding (PTree.elements e). (** Initialization of local variables that are parameters. The value of the corresponding argument is stored into the memory block @@ -418,11 +427,12 @@ Inductive step: state -> trace -> state -> Prop := | step_skip_block: forall f k e m, step (State f Sskip (Kblock k) e m) E0 (State f Sskip k e m) - | step_skip_call: forall f k e m, + | step_skip_call: forall f k e m m', is_call_cont k -> - f.(fn_sig).(sig_res) = None -> + f.(fn_return) = None -> + Mem.free_list m (blocks_of_env e) = Some m' -> step (State f Sskip k e m) - E0 (Returnstate Vundef k (Mem.free_list m (blocks_of_env e))) + E0 (Returnstate Vundef k m') | step_assign: forall f id a k e m m' v, eval_expr e m a v -> @@ -478,18 +488,17 @@ Inductive step: state -> trace -> state -> Prop := step (State f (Sswitch a cases) k e m) E0 (State f (seq_of_lbl_stmt (select_switch n cases)) k e m) - | step_return_0: forall f k e m, - f.(fn_sig).(sig_res) = None -> + | step_return_0: forall f k e m m', + f.(fn_return) = None -> + Mem.free_list m (blocks_of_env e) = Some m' -> step (State f (Sreturn None) k e m) - E0 (Returnstate Vundef (call_cont k) - (Mem.free_list m (blocks_of_env e))) - | step_return_1: forall f a k e m v, - f.(fn_sig).(sig_res) <> None -> + E0 (Returnstate Vundef (call_cont k) m') + | step_return_1: forall f a k e m v m', + f.(fn_return) <> None -> eval_expr e m a v -> + Mem.free_list m (blocks_of_env e) = Some m' -> step (State f (Sreturn (Some a)) k e m) - E0 (Returnstate v (call_cont k) - (Mem.free_list m (blocks_of_env e))) - + E0 (Returnstate v (call_cont k) m') | step_label: forall f lbl s k e m, step (State f (Slabel lbl s) k e m) E0 (State f s k e m) @@ -506,10 +515,10 @@ Inductive step: state -> trace -> state -> Prop := step (Callstate (Internal f) vargs k m) E0 (State f f.(fn_body) k e m2) - | step_external_function: forall ef vargs k m t vres, - event_match ef vargs t vres -> + | step_external_function: forall ef vargs k m t vres m', + external_call ef vargs m t vres m' -> step (Callstate (External ef) vargs k m) - t (Returnstate vres k m) + t (Returnstate vres k m') | step_return: forall v optid f e k m m', exec_opt_assign e m optid v m' -> @@ -524,9 +533,9 @@ End RELSEM. without arguments and with an empty continuation. *) Inductive initial_state (p: program): state -> Prop := - | initial_state_intro: forall b f, + | initial_state_intro: forall b f m0, let ge := Genv.globalenv p in - let m0 := Genv.init_mem p in + Genv.init_mem p = Some m0 -> Genv.find_symbol ge p.(prog_main) = Some b -> Genv.find_funct_ptr ge b = Some f -> funsig f = mksignature nil (Some Tint) -> diff --git a/cfrontend/Cshmgen.v b/cfrontend/Cshmgen.v index b40b94c..548c8df 100644 --- a/cfrontend/Cshmgen.v +++ b/cfrontend/Cshmgen.v @@ -34,11 +34,6 @@ Open Local Scope error_monad_scope. (** * Operations on C types *) -Definition signature_of_function (f: Csyntax.function) : signature := - mksignature - (typlist_of_typelist (type_of_params (Csyntax.fn_params f))) - (opttyp_of_type (Csyntax.fn_return f)). - Definition chunk_of_type (ty: type): res memory_chunk := match access_mode ty with | By_value chunk => OK chunk @@ -615,7 +610,7 @@ Definition transl_function (f: Csyntax.function) : res function := do tparams <- transl_params (Csyntax.fn_params f); do tvars <- transl_vars (Csyntax.fn_vars f); do tbody <- transl_statement 1%nat 0%nat (Csyntax.fn_body f); - OK (mkfunction (signature_of_function f) tparams tvars tbody). + OK (mkfunction (opttyp_of_type (Csyntax.fn_return f)) tparams tvars tbody). Definition transl_fundef (f: Csyntax.fundef) : res fundef := match f with diff --git a/cfrontend/Cshmgenproof1.v b/cfrontend/Cshmgenproof1.v index 86ecd2a..ebc188e 100644 --- a/cfrontend/Cshmgenproof1.v +++ b/cfrontend/Cshmgenproof1.v @@ -20,7 +20,7 @@ Require Import Floats. Require Import AST. Require Import Values. Require Import Events. -Require Import Mem. +Require Import Memory. Require Import Globalenvs. Require Import Csyntax. Require Import Csem. @@ -31,6 +31,29 @@ Require Import Cshmgen. (** * Properties of operations over types *) +Remark type_of_chunk_of_type: + forall ty chunk, + chunk_of_type ty = OK chunk -> + type_of_chunk chunk = typ_of_type ty. +Proof. + intros. unfold chunk_of_type in H. destruct ty; simpl in H; try monadInv H. + destruct i; destruct s; monadInv H; reflexivity. + destruct f; monadInv H; reflexivity. + reflexivity. reflexivity. +Qed. + +Remark transl_params_types: + forall p tp, + transl_params p = OK tp -> + map type_of_chunk (map param_chunk tp) = typlist_of_typelist (type_of_params p). +Proof. + induction p; simpl; intros. + inv H. auto. + destruct a as [id ty]. generalize H; clear H. case_eq (chunk_of_type ty); intros. + monadInv H0. simpl. f_equal; auto. apply type_of_chunk_of_type; auto. + inv H0. +Qed. + Lemma transl_fundef_sig1: forall f tf args res, transl_fundef f = OK tf -> @@ -39,9 +62,10 @@ Lemma transl_fundef_sig1: Proof. intros. destruct f; monadInv H. monadInv EQ. simpl. - simpl in H0. inversion H0. reflexivity. - simpl. - simpl in H0. congruence. + simpl in H0. inversion H0. + unfold fn_sig; simpl. unfold signature_of_type. f_equal. + apply transl_params_types; auto. + simpl. simpl in H0. congruence. Qed. Lemma transl_fundef_sig2: @@ -109,7 +133,7 @@ Qed. Lemma transl_params_names: forall vars tvars, transl_params vars = OK tvars -> - List.map (@fst ident memory_chunk) tvars = Ctyping.var_names vars. + List.map param_name tvars = Ctyping.var_names vars. Proof. exact (map_partial_names _ _ chunk_of_type). Qed. @@ -117,7 +141,7 @@ Qed. Lemma transl_vars_names: forall vars tvars, transl_vars vars = OK tvars -> - List.map (@fst ident var_kind) tvars = Ctyping.var_names vars. + List.map variable_name tvars = Ctyping.var_names vars. Proof. exact (map_partial_names _ _ var_kind_of_type). Qed. diff --git a/cfrontend/Cshmgenproof2.v b/cfrontend/Cshmgenproof2.v index 199192c..769aee7 100644 --- a/cfrontend/Cshmgenproof2.v +++ b/cfrontend/Cshmgenproof2.v @@ -20,7 +20,7 @@ Require Import Floats. Require Import AST. Require Import Values. Require Import Events. -Require Import Mem. +Require Import Memory. Require Import Globalenvs. Require Import Csyntax. Require Import Csem. diff --git a/cfrontend/Cshmgenproof3.v b/cfrontend/Cshmgenproof3.v index 836f1e4..7e3658b 100644 --- a/cfrontend/Cshmgenproof3.v +++ b/cfrontend/Cshmgenproof3.v @@ -20,7 +20,7 @@ Require Import Floats. Require Import AST. Require Import Values. Require Import Events. -Require Import Mem. +Require Import Memory. Require Import Globalenvs. Require Import Smallstep. Require Import Csyntax. @@ -52,13 +52,13 @@ Lemma functions_translated: forall v f, Genv.find_funct ge v = Some f -> exists tf, Genv.find_funct tge v = Some tf /\ transl_fundef f = OK tf. -Proof (Genv.find_funct_transf_partial2 transl_fundef transl_globvar TRANSL). +Proof (Genv.find_funct_transf_partial2 transl_fundef transl_globvar _ TRANSL). Lemma function_ptr_translated: forall b f, Genv.find_funct_ptr ge b = Some f -> exists tf, Genv.find_funct_ptr tge b = Some tf /\ transl_fundef f = OK tf. -Proof (Genv.find_funct_ptr_transf_partial2 transl_fundef transl_globvar TRANSL). +Proof (Genv.find_funct_ptr_transf_partial2 transl_fundef transl_globvar _ TRANSL). Lemma functions_well_typed: forall v f, @@ -82,41 +82,24 @@ Proof. assumption. Qed. -Lemma sig_translated: - forall fd tfd targs tres, - classify_fun (type_of_fundef fd) = fun_case_f targs tres -> - transl_fundef fd = OK tfd -> - funsig tfd = signature_of_type targs tres. -Proof. - intros. destruct fd; monadInv H0; inv H. - monadInv EQ. simpl. auto. - simpl. auto. -Qed. - (** * Matching between environments *) (** In this section, we define a matching relation between a Clight local environment and a Csharpminor local environment, parameterized by an assignment of types to the Clight variables. *) -Definition match_var_kind (ty: type) (vk: var_kind) : Prop := - match access_mode ty with - | By_value chunk => vk = Vscalar chunk - | _ => True - end. - Record match_env (tyenv: typenv) (e: Csem.env) (te: Csharpminor.env) : Prop := mk_match_env { me_local: - forall id b, - e!id = Some b -> - exists vk, exists ty, + forall id b ty, + e!id = Some (b, ty) -> + exists vk, tyenv!id = Some ty - /\ match_var_kind ty vk + /\ var_kind_of_type ty = OK vk /\ te!id = Some (b, vk); me_local_inv: forall id b vk, - te!id = Some (b, vk) -> e!id = Some b; + te!id = Some (b, vk) -> exists ty, e!id = Some(b, ty); me_global: forall id ty, e!id = None -> tyenv!id = Some ty -> @@ -124,64 +107,44 @@ Record match_env (tyenv: typenv) (e: Csem.env) (te: Csharpminor.env) : Prop := (forall chunk, access_mode ty = By_value chunk -> (global_var_env tprog)!id = Some (Vscalar chunk)) }. - Lemma match_env_same_blocks: forall tyenv e te, match_env tyenv e te -> - forall b, In b (Csem.blocks_of_env e) <-> In b (blocks_of_env te). -Proof. - intros. inv H. - unfold Csem.blocks_of_env, blocks_of_env. - set (f := (fun id_b_lv : positive * (block * var_kind) => - let (_, y) := id_b_lv in let (b0, _) := y in b0)). - split; intros. - exploit list_in_map_inv; eauto. intros [[id b'] [A B]]. - simpl in A; subst b'. - exploit (me_local0 id b). apply PTree.elements_complete; auto. - intros [vk [ty [C [D E]]]]. - change b with (f (id, (b, vk))). - apply List.in_map. apply PTree.elements_correct. auto. - exploit list_in_map_inv; eauto. intros [[id [b' vk]] [A B]]. - simpl in A; subst b'. - exploit (me_local_inv0 id b vk). apply PTree.elements_complete; auto. - intro. - change b with (snd (id, b)). - apply List.in_map. apply PTree.elements_correct. auto. -Qed. - -Remark free_list_charact: - forall l m, - free_list m l = - mkmem (fun b => if In_dec eq_block b l then empty_block 0 0 else m.(blocks) b) - m.(nextblock) - m.(nextblock_pos). + blocks_of_env te = Csem.blocks_of_env e. Proof. - induction l; intros; simpl. - destruct m; simpl. decEq. apply extensionality. auto. - rewrite IHl. unfold free; simpl. decEq. apply extensionality; intro b. - unfold update. destruct (eq_block a b). - subst b. apply zeq_true. - rewrite zeq_false; auto. - destruct (In_dec eq_block b l); auto. -Qed. - -Lemma mem_free_list_same: - forall m l1 l2, - (forall b, In b l1 <-> In b l2) -> - free_list m l1 = free_list m l2. -Proof. - intros. repeat rewrite free_list_charact. decEq. apply extensionality; intro b. - destruct (In_dec eq_block b l1); destruct (In_dec eq_block b l2); auto. - rewrite H in i. contradiction. - rewrite <- H in i. contradiction. + intros. + set (R := fun (x: (block * type)) (y: (block * var_kind)) => + match x, y with + | (b1, ty), (b2, vk) => b2 = b1 /\ var_kind_of_type ty = OK vk + end). + assert (list_forall2 + (fun i_x i_y => fst i_x = fst i_y /\ R (snd i_x) (snd i_y)) + (PTree.elements e) (PTree.elements te)). + apply PTree.elements_canonical_order. + intros id [b ty] GET. exploit me_local; eauto. intros [vk [A [B C]]]. + exists (b, vk); split; auto. red. auto. + intros id [b vk] GET. + exploit me_local_inv; eauto. intros [ty A]. + exploit me_local; eauto. intros [vk' [B [C D]]]. + assert (vk' = vk) by congruence. subst vk'. + exists (b, ty); split; auto. red. auto. + + unfold blocks_of_env, Csem.blocks_of_env. + generalize H0. induction 1. auto. + simpl. f_equal; auto. + unfold block_of_binding, Csem.block_of_binding. + destruct a1 as [id1 [blk1 ty1]]. destruct b1 as [id2 [blk2 vk2]]. + simpl in *. destruct H1 as [A [B C]]. subst blk2 id2. f_equal. + apply sizeof_var_kind_of_type. auto. Qed. Lemma match_env_free_blocks: - forall tyenv e te m, + forall tyenv e te m m', match_env tyenv e te -> - Mem.free_list m (Csem.blocks_of_env e) = Mem.free_list m (blocks_of_env te). + Mem.free_list m (Csem.blocks_of_env e) = Some m' -> + Mem.free_list m (blocks_of_env te) = Some m'. Proof. - intros. apply mem_free_list_same. intros; eapply match_env_same_blocks; eauto. + intros. rewrite (match_env_same_blocks _ _ _ H). auto. Qed. Definition match_globalenv (tyenv: typenv) (gv: gvarenv): Prop := @@ -203,14 +166,6 @@ Proof. intros. red in H. eauto. Qed. -Lemma match_var_kind_of_type: - forall ty vk, var_kind_of_type ty = OK vk -> match_var_kind ty vk. -Proof. - intros; red. - caseEq (access_mode ty); auto. - intros chunk AM. generalize (var_kind_by_value _ _ AM). congruence. -Qed. - (** The following lemmas establish the [match_env] invariant at the beginning of a function invocation, after allocation of local variables and initialization of the parameters. *) @@ -233,17 +188,16 @@ Proof. caseEq (transl_vars vars); simpl; [intros tvrs TVARS | congruence]. intro EQ; inversion EQ; subst tvars; clear EQ. set (te2 := PTree.set id (b1, vk) te1). - assert (match_env (add_var tyenv (id, ty)) (PTree.set id b1 e) te2). + assert (match_env (add_var tyenv (id, ty)) (PTree.set id (b1, ty) e) te2). inversion H1. unfold te2, add_var. constructor. (* me_local *) - intros until b. simpl. repeat rewrite PTree.gsspec. + intros until ty0. simpl. repeat rewrite PTree.gsspec. destruct (peq id0 id); intros. - inv H3. exists vk; exists ty; intuition. - apply match_var_kind_of_type. congruence. + inv H3. exists vk; intuition. auto. (* me_local_inv *) intros until vk0. repeat rewrite PTree.gsspec. - destruct (peq id0 id); intros. congruence. eauto. + destruct (peq id0 id); intros. exists ty; congruence. eauto. (* me_global *) intros until ty0. repeat rewrite PTree.gsspec. simpl. destruct (peq id0 id); intros. discriminate. @@ -276,9 +230,8 @@ Proof. unfold store_value_of_type in H0. rewrite H4 in H0. apply bind_parameters_cons with b m1. assert (tyenv!id = Some ty). apply H2. apply in_eq. - destruct (me_local _ _ _ H3 _ _ H) as [vk [ty' [A [B C]]]]. - assert (ty' = ty) by congruence. subst ty'. - red in B; rewrite H4 in B. congruence. + destruct (me_local _ _ _ H3 _ _ _ H) as [vk [A [B C]]]. + exploit var_kind_by_value; eauto. congruence. assumption. apply IHbind_parameters with tyenv; auto. intros. apply H2. apply in_cons; auto. @@ -422,9 +375,9 @@ Proof. inversion H2; clear H2; subst. inversion H; subst; clear H. (* local variable *) - exploit me_local; eauto. intros [vk [ty' [A [B C]]]]. - assert (ty' = ty) by congruence. subst ty'. - red in B; rewrite ACC in B. + exploit me_local; eauto. intros [vk [A [B C]]]. + assert (vk = Vscalar chunk). + exploit var_kind_by_value; eauto. congruence. subst vk. eapply eval_Evar. eapply eval_var_ref_local. eauto. assumption. @@ -440,7 +393,7 @@ Proof. inversion H2; clear H2; subst. inversion H; subst; clear H. (* local variable *) - exploit me_local; eauto. intros [vk [ty' [A [B C]]]]. + exploit me_local; eauto. intros [vk [A [B C]]]. eapply eval_Eaddrof. eapply eval_var_addr_local. eauto. (* global variable *) @@ -473,9 +426,10 @@ Proof. inversion H2; clear H2; subst. inversion H; subst; clear H. (* local variable *) - exploit me_local; eauto. intros [vk [ty' [A [B C]]]]. - assert (ty' = ty) by congruence. subst ty'. - red in B; rewrite ACC in B; subst vk. + exploit me_local; eauto. intros [vk [A [B C]]]. + assert (vk = Vscalar chunk). + exploit var_kind_by_value; eauto. congruence. + subst vk. eapply step_assign. eauto. econstructor. eapply eval_var_ref_local. eauto. assumption. (* global variable *) @@ -514,10 +468,11 @@ Proof. (* local variable *) split. auto. subst id0 ty l ofs. exploit me_local; eauto. - intros [vk [ty [A [B C]]]]. - assert (ty = typeof lhs) by congruence. rewrite <- H3. - generalize B; unfold match_var_kind. destruct (access_mode ty); auto. - intros. subst vk. apply eval_var_ref_local; auto. + intros [vk [A [B C]]]. + case_eq (access_mode (typeof lhs)); intros; auto. + assert (vk = Vscalar m0). + exploit var_kind_by_value; eauto. congruence. + subst vk. apply eval_var_ref_local; auto. (* global variable *) split. auto. subst id0 ty l ofs. exploit me_global; eauto. intros [A B]. @@ -542,7 +497,6 @@ Proof. constructor. econstructor. eauto. auto. Qed. - (** * Proof of semantic preservation *) (** ** Semantic preservation for expressions *) @@ -794,12 +748,12 @@ Qed. Lemma transl_Evar_local_correct: forall (id : ident) (l : block) (ty : type), - e ! id = Some l -> + e ! id = Some(l, ty) -> eval_lvalue_prop (Expr (Csyntax.Evar id) ty) l Int.zero. Proof. intros; red; intros. inversion WT; clear WT; subst. monadInv TR. exploit (me_local _ _ _ MENV); eauto. - intros [vk [ty' [A [B C]]]]. + intros [vk [A [B C]]]. econstructor. eapply eval_var_addr_local. eauto. Qed. @@ -1296,7 +1250,7 @@ Proof. apply plus_one. econstructor; eauto. exploit transl_expr_correct; eauto. exploit transl_exprlist_correct; eauto. - eapply sig_translated; eauto. congruence. + eapply transl_fundef_sig1; eauto. congruence. econstructor; eauto. eapply functions_well_typed; eauto. econstructor; eauto. simpl. auto. @@ -1310,7 +1264,7 @@ Proof. apply plus_one. econstructor; eauto. exploit transl_expr_correct; eauto. exploit transl_exprlist_correct; eauto. - eapply sig_translated; eauto. congruence. + eapply transl_fundef_sig1; eauto. congruence. econstructor; eauto. eapply functions_well_typed; eauto. econstructor; eauto. simpl; auto. @@ -1521,16 +1475,18 @@ Proof. monadInv TR. inv MTR. econstructor; split. apply plus_one. constructor. monadInv TRF. simpl. rewrite H. auto. - rewrite (match_env_free_blocks _ _ _ m MENV). econstructor; eauto. + eapply match_env_free_blocks; eauto. + econstructor; eauto. eapply match_cont_call_cont. eauto. (* return some *) - monadInv TR. inv MTR. inv WT. inv H2. + monadInv TR. inv MTR. inv WT. inv H3. econstructor; split. apply plus_one. constructor. monadInv TRF. simpl. - unfold opttyp_of_type. destruct (fn_return f); congruence. - exploit transl_expr_correct; eauto. - rewrite (match_env_free_blocks _ _ _ m MENV). econstructor; eauto. + unfold opttyp_of_type. destruct (Csyntax.fn_return f); congruence. + exploit transl_expr_correct; eauto. + eapply match_env_free_blocks; eauto. + econstructor; eauto. eapply match_cont_call_cont. eauto. (* skip call *) @@ -1539,7 +1495,8 @@ Proof. econstructor; split. apply plus_one. apply step_skip_call. auto. monadInv TRF. simpl. rewrite H0. auto. - rewrite (match_env_free_blocks _ _ _ m MENV). constructor. eauto. + eapply match_env_free_blocks; eauto. + constructor. eauto. (* switch *) monadInv TR. inv WT. @@ -1627,7 +1584,7 @@ Proof. exploit function_ptr_translated; eauto. intros [tf [A B]]. assert (C: Genv.find_symbol tge (prog_main tprog) = Some b). rewrite symbols_preserved. replace (prog_main tprog) with (prog_main prog). - exact H1. symmetry. unfold transl_program in TRANSL. + exact H2. symmetry. unfold transl_program in TRANSL. eapply transform_partial_program2_main; eauto. exploit function_ptr_well_typed. eauto. intro WTF. assert (exists targs, type_of_fundef f = Tfunction targs (Tint I32 Signed)). @@ -1635,16 +1592,15 @@ Proof. eapply Genv.find_funct_ptr_symbol_inversion; eauto. destruct H as [targs D]. assert (targs = Tnil). - inv H0. inv H9. simpl in D. unfold type_of_function in D. rewrite <- H4 in D. + inv H0. inv H10. simpl in D. unfold type_of_function in D. rewrite <- H5 in D. simpl in D. congruence. - simpl in D. inv D. inv H8. inv H. - destruct targs; simpl in H5; congruence. + simpl in D. inv D. + exploit external_call_arity; eauto. destruct targs; simpl; congruence. subst targs. assert (funsig tf = signature_of_type Tnil (Tint I32 Signed)). - eapply sig_translated; eauto. rewrite D; auto. + eapply transl_fundef_sig2; eauto. econstructor; split. - econstructor; eauto. - rewrite (@Genv.init_mem_transf_partial2 _ _ _ _ transl_fundef transl_globvar prog tprog TRANSL). + econstructor; eauto. eapply Genv.init_mem_transf_partial2; eauto. constructor; auto. constructor. exact I. Qed. diff --git a/common/Determinism.v b/common/Determinism.v index 430ee93..862d5a5 100644 --- a/common/Determinism.v +++ b/common/Determinism.v @@ -32,8 +32,8 @@ Axiom traceinf_extensionality: (** * Deterministic worlds *) (** One source of possible nondeterminism is that our semantics leave - unspecified the results of calls to external - functions. Different results to e.g. a "read" operation can of + unspecified the results of system calls. + Different results to e.g. a "read" operation can of course lead to different behaviors for the program. We address this issue by modeling a notion of deterministic external world that uniquely determines the results of external calls. *) @@ -61,13 +61,21 @@ Definition nextworld (w: world) (evname: ident) (evargs: list eventval) : world and [T] the infinite trace of interest. *) +Inductive possible_event: world -> event -> world -> Prop := + | possible_event_syscall: forall w1 evname evargs evres w2, + nextworld w1 evname evargs = Some (evres, w2) -> + possible_event w1 (Event_syscall evname evargs evres) w2 + | possible_event_load: forall w label, + possible_event w (Event_load label) w + | possible_event_store: forall w label, + possible_event w (Event_store label) w. + Inductive possible_trace: world -> trace -> world -> Prop := | possible_trace_nil: forall w, possible_trace w E0 w - | possible_trace_cons: forall w0 evname evargs evres w1 t w2, - nextworld w0 evname evargs = Some (evres, w1) -> - possible_trace w1 t w2 -> - possible_trace w0 (mkevent evname evargs evres :: t) w2. + | possible_trace_cons: forall w1 ev w2 t w3, + possible_event w1 ev w2 -> possible_trace w2 t w3 -> + possible_trace w1 (ev :: t) w3. Lemma possible_trace_app: forall t2 w2 w0 t1 w1, @@ -90,11 +98,28 @@ Proof. exists w1; split. econstructor; eauto. auto. Qed. +Lemma possible_event_final_world: + forall w ev w1 w2, + possible_event w ev w1 -> possible_event w ev w2 -> w1 = w2. +Proof. + intros. inv H; inv H0; congruence. +Qed. + +Lemma possible_trace_final_world: + forall w0 t w1, possible_trace w0 t w1 -> + forall w2, possible_trace w0 t w2 -> w1 = w2. +Proof. + induction 1; intros. + inv H. auto. + inv H1. assert (w2 = w5) by (eapply possible_event_final_world; eauto). + subst; eauto. +Qed. + CoInductive possible_traceinf: world -> traceinf -> Prop := - | possible_traceinf_cons: forall w0 evname evargs evres w1 T, - nextworld w0 evname evargs = Some (evres, w1) -> - possible_traceinf w1 T -> - possible_traceinf w0 (Econsinf (mkevent evname evargs evres) T). + | possible_traceinf_cons: forall w1 ev w2 T, + possible_event w1 ev w2 -> + possible_traceinf w2 T -> + possible_traceinf w1 (Econsinf ev T). Lemma possible_traceinf_app: forall t2 w0 t1 w1, @@ -149,34 +174,13 @@ Definition possible_behavior (w: world) (b: program_behavior) : Prop := | Goes_wrong t => exists w', possible_trace w t w' end. -(** Determinism properties of [event_match]. *) - -Remark eventval_match_deterministic: - forall ev1 ev2 ty v1 v2, - eventval_match ev1 ty v1 -> eventval_match ev2 ty v2 -> - (ev1 = ev2 <-> v1 = v2). -Proof. - intros. inv H; inv H0; intuition congruence. -Qed. - -Remark eventval_list_match_deterministic: - forall ev1 ty v, eventval_list_match ev1 ty v -> - forall ev2, eventval_list_match ev2 ty v -> ev1 = ev2. -Proof. - induction 1; intros. - inv H. auto. - inv H1. decEq. - rewrite (eventval_match_deterministic _ _ _ _ _ H H6). auto. - eauto. -Qed. - (** * Deterministic semantics *) Section DETERM_SEM. (** We assume given a transition semantics that is internally deterministic: the only source of non-determinism is the return - value of external calls. *) + value of system calls. *) Variable genv: Type. Variable state: Type. @@ -184,17 +188,9 @@ Variable step: genv -> state -> trace -> state -> Prop. Variable initial_state: state -> Prop. Variable final_state: state -> int -> Prop. -Inductive internal_determinism: trace -> state -> trace -> state -> Prop := - | int_determ_0: forall s, - internal_determinism E0 s E0 s - | int_determ_1: forall s s' id arg res res', - (res = res' -> s = s') -> - internal_determinism (mkevent id arg res :: nil) s - (mkevent id arg res' :: nil) s'. - Hypothesis step_internal_deterministic: forall ge s t1 s1 t2 s2, - step ge s t1 s1 -> step ge s t2 s2 -> internal_determinism t1 s1 t2 s2. + step ge s t1 s1 -> step ge s t2 s2 -> matching_traces t1 t2 -> s1 = s2 /\ t1 = t2. Hypothesis initial_state_determ: forall s1 s2, initial_state s1 -> initial_state s2 -> s1 = s2. @@ -208,18 +204,29 @@ Hypothesis final_state_nostep: (** Consequently, the [step] relation is deterministic if restricted to traces that are possible in a deterministic world. *) +Remark matching_possible_traces: + forall w0 t1 w1, possible_trace w0 t1 w1 -> + forall t2 w2, possible_trace w0 t2 w2 -> + matching_traces t1 t2. +Proof. + induction 1; intros. + destruct t2; simpl; auto. + destruct t2; simpl. destruct ev; auto. inv H1. + inv H; inv H5; auto; intros. + subst. rewrite H in H1; inv H1. split; eauto. + eauto. + eauto. +Qed. + Lemma step_deterministic: forall ge s0 t1 s1 t2 s2 w0 w1 w2, step ge s0 t1 s1 -> step ge s0 t2 s2 -> possible_trace w0 t1 w1 -> possible_trace w0 t2 w2 -> s1 = s2 /\ t1 = t2 /\ w1 = w2. Proof. - intros. exploit step_internal_deterministic. eexact H. eexact H0. intro ID. - inv ID. - inv H1. inv H2. auto. - inv H2. inv H11. inv H1. inv H11. - rewrite H10 in H9. inv H9. - intuition. + intros. exploit step_internal_deterministic. eexact H. eexact H0. + eapply matching_possible_traces; eauto. intuition. + subst. eapply possible_trace_final_world; eauto. Qed. Ltac use_step_deterministic := @@ -378,44 +385,55 @@ Lemma forever_reactive_inv2: t1 <> E0 -> t2 <> E0 -> forever_reactive step ge s1 T1 -> possible_traceinf w1 T1 -> forever_reactive step ge s2 T2 -> possible_traceinf w2 T2 -> - exists s', exists e, exists T1', exists T2', exists w', + exists s', exists t, exists T1', exists T2', exists w', + t <> E0 /\ forever_reactive step ge s' T1' /\ possible_traceinf w' T1' /\ forever_reactive step ge s' T2' /\ possible_traceinf w' T2' /\ - t1 *** T1 = Econsinf e T1' /\ - t2 *** T2 = Econsinf e T2'. + t1 *** T1 = t *** T1' /\ + t2 *** T2 = t *** T2'. Proof. induction 1; intros. congruence. inv H3. congruence. possibleTraceInv. - assert (ID: internal_determinism t3 s5 t1 s2). eauto. - inv ID. - possibleTraceInv. eauto. - inv P. inv P1. inv H17. inv H19. rewrite H18 in H16; inv H16. - assert (s5 = s2) by auto. subst s5. - exists s2; exists (mkevent id arg res'); - exists (t2 *** T1); exists (t4 *** T2); exists w0. + use_step_deterministic. + destruct t3. + (* inductive case *) + simpl in *. inv P1; inv P. eapply IHstar; eauto. + (* base case *) + exists s5; exists (e :: t3); + exists (t2 *** T1); exists (t4 *** T2); exists w3. + split. unfold E0; congruence. split. eapply star_forever_reactive; eauto. split. eapply possible_traceinf_app; eauto. split. eapply star_forever_reactive; eauto. split. eapply possible_traceinf_app; eauto. - auto. + split; traceEq. Qed. -Lemma forever_reactive_determ: +Lemma forever_reactive_determ': forall ge s T1 T2 w, forever_reactive step ge s T1 -> possible_traceinf w T1 -> forever_reactive step ge s T2 -> possible_traceinf w T2 -> - traceinf_sim T1 T2. + traceinf_sim' T1 T2. Proof. cofix COINDHYP; intros. inv H. inv H1. possibleTraceInv. destruct (forever_reactive_inv2 _ _ _ _ H _ _ _ _ _ _ _ P H3 P1 H6 H4 H7 P0 H5 P2) - as [s' [e [T1' [T2' [w' [A [B [C [D [E G]]]]]]]]]]. - rewrite E; rewrite G. constructor. + as [s' [t' [T1' [T2' [w' [A [B [C [D [E [G K]]]]]]]]]]]. + rewrite G; rewrite K. constructor. auto. eapply COINDHYP; eauto. Qed. +Lemma forever_reactive_determ: + forall ge s T1 T2 w, + forever_reactive step ge s T1 -> possible_traceinf w T1 -> + forever_reactive step ge s T2 -> possible_traceinf w T2 -> + traceinf_sim T1 T2. +Proof. + intros. apply traceinf_sim'_sim. eapply forever_reactive_determ'; eauto. +Qed. + Lemma star_forever_reactive_inv: forall ge s t s', star step ge s t s' -> forall w w' T, possible_trace w t w' -> forever_reactive step ge s T -> diff --git a/common/Events.v b/common/Events.v index 855c013..ad1fc51 100644 --- a/common/Events.v +++ b/common/Events.v @@ -13,34 +13,44 @@ (* *) (* *********************************************************************) -(** Representation of observable events and execution traces. *) +(** Observable events, execution traces, and semantics of external calls. *) Require Import Coqlib. +Require Intv. Require Import AST. Require Import Integers. Require Import Floats. Require Import Values. +Require Import Memory. + +(** * Events and traces *) (** The observable behaviour of programs is stated in terms of - input/output events, which can also be thought of as system calls - to the operating system. An event is generated each time an - external function (see module AST) is invoked. The event records - the name of the external function, the arguments to the function - invocation provided by the program, and the return value provided by - the outside world (e.g. the operating system). Arguments and values - are either integers or floating-point numbers. We currently do not - allow pointers to be exchanged between the program and the outside - world. *) + input/output events, which represent the actions of the program + that the external world can observe. CompCert leaves much flexibility as to + the exact content of events: the only requirement is that they + do not expose pointer values nor memory states, because these + are not preserved literally during compilation. For concreteness, + we use the following type for events. Each event represents either: + +- A system call (e.g. an input/output operation), recording the + name of the system call, its int-or-float parameters, + and its int-or-float result. + +- A volatile load from a memory location, recording a label + associated with the read (e.g. a global variable name or a source code position). + +- A volatile store to a memory location, also recording a label. +*) Inductive eventval: Type := | EVint: int -> eventval | EVfloat: float -> eventval. -Record event : Type := mkevent { - ev_name: ident; - ev_args: list eventval; - ev_res: eventval -}. +Inductive event: Type := + | Event_syscall: ident -> list eventval -> eventval -> event + | Event_load: ident -> event + | Event_store: ident -> event. (** The dynamic semantics for programs collect traces of events. Traces are of two kinds: finite (type [trace]) or infinite (type [traceinf]). *) @@ -49,10 +59,6 @@ Definition trace := list event. Definition E0 : trace := nil. -Definition Eextcall - (name: ident) (args: list eventval) (res: eventval) : trace := - mkevent name args res :: nil. - Definition Eapp (t1 t2: trace) : trace := t1 ++ t2. CoInductive traceinf : Type := @@ -93,7 +99,7 @@ Qed. Hint Rewrite E0_left E0_right Eapp_assoc E0_left_inf Eappinf_assoc: trace_rewrite. -Opaque trace E0 Eextcall Eapp Eappinf. +Opaque trace E0 Eapp Eappinf. (** The following [traceEq] tactic proves equalities between traces or infinite traces. *) @@ -115,115 +121,6 @@ Ltac decomposeTraceEq := Ltac traceEq := repeat substTraceHyp; autorewrite with trace_rewrite; decomposeTraceEq. -(** The predicate [event_match ef vargs t vres] expresses that - the event [t] is generated when invoking external function [ef] - with arguments [vargs], and obtaining [vres] as a return value - from the operating system. *) - -Inductive eventval_match: eventval -> typ -> val -> Prop := - | ev_match_int: - forall i, eventval_match (EVint i) Tint (Vint i) - | ev_match_float: - forall f, eventval_match (EVfloat f) Tfloat (Vfloat f). - -Inductive eventval_list_match: list eventval -> list typ -> list val -> Prop := - | evl_match_nil: - eventval_list_match nil nil nil - | evl_match_cons: - forall ev1 evl ty1 tyl v1 vl, - eventval_match ev1 ty1 v1 -> - eventval_list_match evl tyl vl -> - eventval_list_match (ev1::evl) (ty1::tyl) (v1::vl). - -Inductive event_match: - external_function -> list val -> trace -> val -> Prop := - event_match_intro: - forall ef vargs vres eargs eres, - eventval_list_match eargs (sig_args ef.(ef_sig)) vargs -> - eventval_match eres (proj_sig_res ef.(ef_sig)) vres -> - event_match ef vargs (Eextcall ef.(ef_id) eargs eres) vres. - -(** The following section shows that [event_match] is stable under - relocation of pointer values, as performed by memory injections - (see module [Mem]). *) - -Require Import Mem. - -Section EVENT_MATCH_INJECT. - -Variable f: meminj. - -Remark eventval_match_inject: - forall ev ty v1, eventval_match ev ty v1 -> - forall v2, val_inject f v1 v2 -> - eventval_match ev ty v2. -Proof. - induction 1; intros; inversion H; constructor. -Qed. - -Remark eventval_list_match_inject: - forall evl tyl vl1, eventval_list_match evl tyl vl1 -> - forall vl2, val_list_inject f vl1 vl2 -> - eventval_list_match evl tyl vl2. -Proof. - induction 1; intros. - inversion H; constructor. - inversion H1; constructor. - eapply eventval_match_inject; eauto. - eauto. -Qed. - -Lemma event_match_inject: - forall ef args1 t res args2, - event_match ef args1 t res -> - val_list_inject f args1 args2 -> - event_match ef args2 t res /\ val_inject f res res. -Proof. - intros. inversion H; subst. - split. constructor. eapply eventval_list_match_inject; eauto. auto. - inversion H2; constructor. -Qed. - -End EVENT_MATCH_INJECT. - -(** The following section shows that [event_match] is stable under - replacement of [Vundef] values by more defined values. *) - -Section EVENT_MATCH_LESSDEF. - -Remark eventval_match_lessdef: - forall ev ty v1, eventval_match ev ty v1 -> - forall v2, Val.lessdef v1 v2 -> - eventval_match ev ty v2. -Proof. - induction 1; intros; inv H; constructor. -Qed. - -Remark eventval_list_match_moredef: - forall evl tyl vl1, eventval_list_match evl tyl vl1 -> - forall vl2, Val.lessdef_list vl1 vl2 -> - eventval_list_match evl tyl vl2. -Proof. - induction 1; intros. - inversion H; constructor. - inversion H1; constructor. - eapply eventval_match_lessdef; eauto. - eauto. -Qed. - -Lemma event_match_lessdef: - forall ef args1 t res1 args2, - event_match ef args1 t res1 -> - Val.lessdef_list args1 args2 -> - exists res2, event_match ef args2 t res2 /\ Val.lessdef res1 res2. -Proof. - intros. inversion H; subst. exists res1; split. - constructor. eapply eventval_list_match_moredef; eauto. auto. - auto. -Qed. - -End EVENT_MATCH_LESSDEF. - (** Bisimilarity between infinite traces. *) CoInductive traceinf_sim: traceinf -> traceinf -> Prop := @@ -251,6 +148,23 @@ Proof. cofix COINDHYP;intros. inv H; inv H0; constructor; eauto. Qed. +CoInductive traceinf_sim': traceinf -> traceinf -> Prop := + | traceinf_sim'_cons: forall t T1 T2, + t <> E0 -> traceinf_sim' T1 T2 -> traceinf_sim' (t *** T1) (t *** T2). + +Lemma traceinf_sim'_sim: + forall T1 T2, traceinf_sim' T1 T2 -> traceinf_sim T1 T2. +Proof. + cofix COINDHYP; intros. inv H. + destruct t. elim H0; auto. +Transparent Eappinf. +Transparent E0. + simpl. + destruct t. simpl. constructor. apply COINDHYP; auto. + constructor. apply COINDHYP. + constructor. unfold E0; congruence. auto. +Qed. + (** The "is prefix of" relation between a finite and an infinite trace. *) Inductive traceinf_prefix: trace -> traceinf -> Prop := @@ -321,3 +235,586 @@ Proof. Transparent Eappinf. simpl. f_equal. apply IHt. Qed. + +(** * Semantics of external functions *) + +(** Each external function is of one of the following kinds: *) + +Inductive extfun_kind: signature -> Type := + | EF_syscall (sg: signature) (name: ident): extfun_kind sg + (** A system call. Takes integer-or-float arguments, produces a + result that is an integer or a float, does not modify + the memory, and produces an [Event_syscall] event in the trace. *) + | EF_load (label: ident) (chunk: memory_chunk): extfun_kind (mksignature (Tint :: nil) (Some (type_of_chunk chunk))) + (** A volatile read operation. Reads and returns the given memory + chunk from the address given as first argument. + Produces an [Event_load] event containing the given label. *) + | EF_store (label: ident) (chunk: memory_chunk): extfun_kind (mksignature (Tint :: type_of_chunk chunk :: nil) None) + (** A volatile store operation. Store the value given as second + argument at the address given as first argument, using the + given memory chunk. + Produces an [Event_store] event containing the given label. *) + | EF_malloc: extfun_kind (mksignature (Tint :: nil) (Some Tint)) + (** Dynamic memory allocation. Takes the requested size in bytes + as argument; returns a pointer to a fresh block of the given size. + Produces no observable event. *) + | EF_free: extfun_kind (mksignature (Tint :: nil) None). + (** Dynamic memory deallocation. Takes a pointer to a block + allocated by an [EF_malloc] external call and frees the + corresponding block. + Produces no observable event. *) + +Parameter classify_external_function: + forall (ef: external_function), extfun_kind (ef.(ef_sig)). + +(** For each external function, its behavior is defined by a predicate relating: +- the values of the arguments passed to this function +- the memory state before the call +- the result value of the call +- the memory state after the call +- the trace generated by the call (can be empty). + +We now specify the expected properties of this predicate. +*) + +Definition mem_unchanged_on (P: block -> Z -> Prop) (m_before m_after: mem): Prop := + (forall b ofs p, + P b ofs -> Mem.perm m_before b ofs p -> Mem.perm m_after b ofs p) +/\(forall chunk b ofs v, + (forall i, ofs <= i < ofs + size_chunk chunk -> P b i) -> + Mem.load chunk m_before b ofs = Some v -> + Mem.load chunk m_after b ofs = Some v). + +Definition loc_out_of_bounds (m: mem) (b: block) (ofs: Z) : Prop := + ofs < Mem.low_bound m b \/ ofs > Mem.high_bound m b. + +Definition loc_unmapped (f: meminj) (b: block) (ofs: Z): Prop := + f b = None. + +Definition loc_out_of_reach (f: meminj) (m: mem) (b: block) (ofs: Z): Prop := + forall b0 delta, + f b0 = Some(b, delta) -> + ofs < Mem.low_bound m b0 + delta \/ ofs >= Mem.high_bound m b0 + delta. + +Definition inject_separated (f f': meminj) (m1 m2: mem): Prop := + forall b1 b2 delta, + f b1 = None -> f' b1 = Some(b2, delta) -> + ~Mem.valid_block m1 b1 /\ ~Mem.valid_block m2 b2. + +Fixpoint matching_traces (t1 t2: trace) {struct t1} : Prop := + match t1, t2 with + | Event_syscall name1 args1 res1 :: t1', Event_syscall name2 args2 res2 :: t2' => + name1 = name2 -> args1 = args2 -> res1 = res2 /\ matching_traces t1' t2' + | Event_load name1 :: t1', Event_load name2 :: t2' => + name1 = name2 -> matching_traces t1' t2' + | Event_store name1 :: t1', Event_store name2 :: t2' => + name1 = name2 -> matching_traces t1' t2' + | _, _ => + True + end. + +Record extcall_properties (sem: list val -> mem -> trace -> val -> mem -> Prop) + (sg: signature) : Prop := mk_extcall_properties { + +(** The return value of an external call must agree with its signature. *) + ec_well_typed: + forall vargs m1 t vres m2, + sem vargs m1 t vres m2 -> + Val.has_type vres (proj_sig_res sg); + +(** The number of arguments of an external call must agree with its signature. *) + ec_arity: + forall vargs m1 t vres m2, + sem vargs m1 t vres m2 -> + List.length vargs = List.length sg.(sig_args); + +(** External calls cannot invalidate memory blocks. (Remember that + freeing a block does not invalidate its block identifier.) *) + ec_valid_block: + forall vargs m1 t vres m2 b, + sem vargs m1 t vres m2 -> + Mem.valid_block m1 b -> Mem.valid_block m2 b; + +(** External calls preserve the bounds of valid blocks. *) + ec_bounds: + forall vargs m1 t vres m2 b, + sem vargs m1 t vres m2 -> + Mem.valid_block m1 b -> Mem.bounds m2 b = Mem.bounds m1 b; + +(** External calls must commute with memory extensions, in the + following sense. *) + ec_mem_extends: + forall vargs m1 t vres m2 m1' vargs', + sem vargs m1 t vres m2 -> + Mem.extends m1 m1' -> + Val.lessdef_list vargs vargs' -> + exists vres', exists m2', + sem vargs' m1' t vres' m2' + /\ Val.lessdef vres vres' + /\ Mem.extends m2 m2' + /\ mem_unchanged_on (loc_out_of_bounds m1) m1' m2'; + +(** External calls must commute with memory injections, + in the following sense. *) + ec_mem_inject: + forall vargs m1 t vres m2 f m1' vargs', + sem vargs m1 t vres m2 -> + Mem.inject f m1 m1' -> + val_list_inject f vargs vargs' -> + exists f', exists vres', exists m2', + sem vargs' m1' t vres' m2' + /\ val_inject f' vres vres' + /\ Mem.inject f' m2 m2' + /\ mem_unchanged_on (loc_unmapped f) m1 m2 + /\ mem_unchanged_on (loc_out_of_reach f m1) m1' m2' + /\ inject_incr f f' + /\ inject_separated f f' m1 m1'; + +(** External calls must be internally deterministic: + if the observable traces match, the return states must be + identical. *) + ec_determ: + forall vargs m t1 vres1 m1 t2 vres2 m2, + sem vargs m t1 vres1 m1 -> sem vargs m t2 vres2 m2 -> + matching_traces t1 t2 -> t1 = t2 /\ vres1 = vres2 /\ m1 = m2 +}. + +(** ** Semantics of volatile loads *) + +Inductive extcall_load_sem (label: ident) (chunk: memory_chunk): + list val -> mem -> trace -> val -> mem -> Prop := + | extcall_load_sem_intro: forall b ofs m vres, + Mem.load chunk m b (Int.signed ofs) = Some vres -> + extcall_load_sem label chunk (Vptr b ofs :: nil) m (Event_load label :: nil) vres m. + +Lemma extcall_load_ok: + forall label chunk, + extcall_properties (extcall_load_sem label chunk) + (mksignature (Tint :: nil) (Some (type_of_chunk chunk))). +Proof. + intros; constructor; intros. + + inv H. unfold proj_sig_res. simpl. eapply Mem.load_type; eauto. + + inv H. simpl. auto. + + inv H. auto. + + inv H. auto. + + inv H. inv H1. inv H6. inv H4. + exploit Mem.load_extends; eauto. intros [v2 [A B]]. + exists v2; exists m1'; intuition. + constructor; auto. + red. auto. + + inv H. inv H1. inv H6. + assert (Mem.loadv chunk m2 (Vptr b ofs) = Some vres). auto. + exploit Mem.loadv_inject; eauto. intros [v2 [A B]]. + inv H4. + exists f; exists v2; exists m1'; intuition. + constructor. auto. + red; auto. + red; auto. + red; intros. congruence. + + inv H; inv H0. intuition congruence. +Qed. + +(** ** Semantics of volatile stores *) + +Inductive extcall_store_sem (label: ident) (chunk: memory_chunk): + list val -> mem -> trace -> val -> mem -> Prop := + | extcall_store_sem_intro: forall b ofs v m m', + Mem.store chunk m b (Int.signed ofs) v = Some m' -> + extcall_store_sem label chunk (Vptr b ofs :: v :: nil) m (Event_store label :: nil) Vundef m'. + +Lemma extcall_store_ok: + forall label chunk, + extcall_properties (extcall_store_sem label chunk) + (mksignature (Tint :: type_of_chunk chunk :: nil) None). +Proof. + intros; constructor; intros. + + inv H. unfold proj_sig_res. simpl. auto. + + inv H. simpl. auto. + + inv H. eauto with mem. + + inv H. eapply Mem.bounds_store; eauto. + + inv H. inv H1. inv H6. inv H7. inv H4. + exploit Mem.store_within_extends; eauto. intros [m' [A B]]. + exists Vundef; exists m'; intuition. + constructor; auto. + red; split; intros. + eapply Mem.perm_store_1; eauto. + rewrite <- H1. eapply Mem.load_store_other; eauto. + destruct (eq_block b0 b); auto. subst b0; right. + exploit Mem.valid_access_in_bounds. + eapply Mem.store_valid_access_3. eexact H2. + intros [C D]. + generalize (size_chunk_pos chunk0). intro E. + generalize (size_chunk_pos chunk). intro F. + apply (Intv.range_disjoint' (ofs0, ofs0 + size_chunk chunk0) + (Int.signed ofs, Int.signed ofs + size_chunk chunk)). + red; intros. generalize (H x H4). unfold loc_out_of_bounds, Intv.In; simpl. omega. + simpl; omega. simpl; omega. + + inv H. inv H1. inv H6. inv H7. + assert (Mem.storev chunk m1 (Vptr b ofs) v = Some m2). simpl; auto. + exploit Mem.storev_mapped_inject; eauto. intros [m2' [A B]]. + inv H4. + exists f; exists Vundef; exists m2'; intuition. + constructor; auto. + split; intros. eapply Mem.perm_store_1; eauto. + rewrite <- H4. eapply Mem.load_store_other; eauto. + left. exploit (H1 ofs0). generalize (size_chunk_pos chunk0). omega. + unfold loc_unmapped. congruence. + split; intros. eapply Mem.perm_store_1; eauto. + rewrite <- H4. eapply Mem.load_store_other; eauto. + destruct (eq_block b0 b2); auto. subst b0; right. + assert (EQ: Int.signed (Int.add ofs (Int.repr delta)) = Int.signed ofs + delta). + eapply Mem.address_inject; eauto with mem. + simpl in A. rewrite EQ in A. rewrite EQ. + exploit Mem.valid_access_in_bounds. + eapply Mem.store_valid_access_3. eexact H2. + intros [C D]. + generalize (size_chunk_pos chunk0). intro E. + generalize (size_chunk_pos chunk). intro F. + apply (Intv.range_disjoint' (ofs0, ofs0 + size_chunk chunk0) + (Int.signed ofs + delta, Int.signed ofs + delta + size_chunk chunk)). + red; intros. exploit (H1 x H5). eauto. unfold Intv.In; simpl. omega. + simpl; omega. simpl; omega. + + red; intros. congruence. + + inv H; inv H0. intuition congruence. +Qed. + +(** ** Semantics of dynamic memory allocation (malloc) *) + +Inductive extcall_malloc_sem: + list val -> mem -> trace -> val -> mem -> Prop := + | extcall_malloc_sem_intro: forall n m m' b m'', + Mem.alloc m (-4) (Int.signed n) = (m', b) -> + Mem.store Mint32 m' b (-4) (Vint n) = Some m'' -> + extcall_malloc_sem (Vint n :: nil) m E0 (Vptr b Int.zero) m''. + +Lemma extcall_malloc_ok: + extcall_properties extcall_malloc_sem + (mksignature (Tint :: nil) (Some Tint)). +Proof. + assert (UNCHANGED: + forall (P: block -> Z -> Prop) m n m' b m'', + Mem.alloc m (-4) (Int.signed n) = (m', b) -> + Mem.store Mint32 m' b (-4) (Vint n) = Some m'' -> + mem_unchanged_on P m m''). + intros; split; intros. + eauto with mem. + transitivity (Mem.load chunk m' b0 ofs). + eapply Mem.load_store_other; eauto. left. + apply Mem.valid_not_valid_diff with m; eauto with mem. + eapply Mem.load_alloc_other; eauto. + + constructor; intros. + + inv H. unfold proj_sig_res; simpl. auto. + + inv H. auto. + + inv H. eauto with mem. + + inv H. transitivity (Mem.bounds m' b). + eapply Mem.bounds_store; eauto. + eapply Mem.bounds_alloc_other; eauto. + apply Mem.valid_not_valid_diff with m1; eauto with mem. + + inv H. inv H1. inv H5. inv H7. + exploit Mem.alloc_extends; eauto. apply Zle_refl. apply Zle_refl. + intros [m3' [A B]]. + exploit Mem.store_within_extends. eexact B. eauto. + instantiate (1 := Vint n). auto. + intros [m2' [C D]]. + exists (Vptr b Int.zero); exists m2'; intuition. + econstructor; eauto. + eapply UNCHANGED; eauto. + + inv H. inv H1. inv H5. inv H7. + exploit Mem.alloc_parallel_inject; eauto. apply Zle_refl. apply Zle_refl. + intros [f' [m3' [b' [ALLOC [A [B [C D]]]]]]]. + exploit Mem.store_mapped_inject. eexact A. eauto. eauto. + instantiate (1 := Vint n). auto. + intros [m2' [E F]]. + exists f'; exists (Vptr b' Int.zero); exists m2'; intuition. + econstructor; eauto. + econstructor. eauto. auto. + eapply UNCHANGED; eauto. + eapply UNCHANGED; eauto. + red; intros. destruct (eq_block b1 b). + subst b1. rewrite C in H1. inv H1. eauto with mem. + rewrite D in H1. congruence. auto. + + inv H; inv H0. intuition congruence. +Qed. + +(** ** Semantics of dynamic memory deallocation (free) *) + +Inductive extcall_free_sem: + list val -> mem -> trace -> val -> mem -> Prop := + | extcall_free_sem_intro: forall b lo sz m m', + Mem.load Mint32 m b (Int.signed lo - 4) = Some (Vint sz) -> + Int.signed sz > 0 -> + Mem.free m b (Int.signed lo - 4) (Int.signed lo + Int.signed sz) = Some m' -> + extcall_free_sem (Vptr b lo :: nil) m E0 Vundef m'. + +Lemma extcall_free_ok: + extcall_properties extcall_free_sem + (mksignature (Tint :: nil) None). +Proof. + assert (UNCHANGED: + forall (P: block -> Z -> Prop) m b lo hi m', + Mem.free m b lo hi = Some m' -> + lo < hi -> + (forall b' ofs, P b' ofs -> b' <> b \/ ofs < lo \/ hi <= ofs) -> + mem_unchanged_on P m m'). + intros; split; intros. + eapply Mem.perm_free_1; eauto. + rewrite <- H3. eapply Mem.load_free; eauto. + destruct (eq_block b0 b); auto. right. right. + apply (Intv.range_disjoint' (ofs, ofs + size_chunk chunk) (lo, hi)). + red; intros. apply Intv.notin_range. simpl. exploit H1; eauto. intuition. + simpl; generalize (size_chunk_pos chunk); omega. + simpl; omega. + + constructor; intros. + + inv H. unfold proj_sig_res. simpl. auto. + + inv H. auto. + + inv H. eauto with mem. + + inv H. eapply Mem.bounds_free; eauto. + + inv H. inv H1. inv H8. inv H6. + exploit Mem.load_extends; eauto. intros [vsz [A B]]. inv B. + exploit Mem.free_parallel_extends; eauto. intros [m2' [C D]]. + exists Vundef; exists m2'; intuition. + econstructor; eauto. + eapply UNCHANGED; eauto. omega. + intros. destruct (eq_block b' b); auto. subst b; right. + red in H. + exploit Mem.range_perm_in_bounds. + eapply Mem.free_range_perm. eexact H4. omega. omega. + + inv H. inv H1. inv H8. inv H6. + exploit Mem.load_inject; eauto. intros [vsz [A B]]. inv B. + assert (Mem.range_perm m1 b (Int.signed lo - 4) (Int.signed lo + Int.signed sz) Freeable). + eapply Mem.free_range_perm; eauto. + exploit Mem.address_inject; eauto. + apply Mem.perm_implies with Freeable; auto with mem. + apply H. instantiate (1 := lo). omega. + intro EQ. + assert (Mem.range_perm m1' b2 (Int.signed lo + delta - 4) (Int.signed lo + delta + Int.signed sz) Freeable). + red; intros. + replace ofs with ((ofs - delta) + delta) by omega. + eapply Mem.perm_inject; eauto. apply H. omega. + destruct (Mem.range_perm_free _ _ _ _ H1) as [m2' FREE]. + exists f; exists Vundef; exists m2'; intuition. + + econstructor. + rewrite EQ. replace (Int.signed lo + delta - 4) with (Int.signed lo - 4 + delta) by omega. + eauto. auto. + rewrite EQ. auto. + + assert (Mem.free_list m1 ((b, Int.signed lo - 4, Int.signed lo + Int.signed sz) :: nil) = Some m2). + simpl. rewrite H4. auto. + eapply Mem.free_inject; eauto. + intros. destruct (eq_block b b1). + subst b. assert (delta0 = delta) by congruence. subst delta0. + exists (Int.signed lo - 4); exists (Int.signed lo + Int.signed sz); split. + simpl; auto. omega. + elimtype False. + exploit Mem.inject_no_overlap. eauto. eauto. eauto. eauto. + instantiate (1 := ofs + delta0 - delta). + apply Mem.perm_implies with Freeable; auto with mem. + apply H. omega. eauto with mem. + unfold block; omega. + + eapply UNCHANGED; eauto. omega. intros. + red in H6. left. congruence. + + eapply UNCHANGED; eauto. omega. intros. + destruct (eq_block b' b2); auto. subst b'. right. + red in H6. generalize (H6 _ _ H5). intros. + exploit Mem.range_perm_in_bounds. eexact H. omega. intros. omega. + + red; intros. congruence. + + inv H; inv H0. intuition congruence. +Qed. + +(** ** Semantics of system calls. *) + +Inductive eventval_match: eventval -> typ -> val -> Prop := + | ev_match_int: + forall i, eventval_match (EVint i) Tint (Vint i) + | ev_match_float: + forall f, eventval_match (EVfloat f) Tfloat (Vfloat f). + +Inductive eventval_list_match: list eventval -> list typ -> list val -> Prop := + | evl_match_nil: + eventval_list_match nil nil nil + | evl_match_cons: + forall ev1 evl ty1 tyl v1 vl, + eventval_match ev1 ty1 v1 -> + eventval_list_match evl tyl vl -> + eventval_list_match (ev1::evl) (ty1::tyl) (v1::vl). + +Inductive extcall_io_sem (name: ident) (sg: signature): + list val -> mem -> trace -> val -> mem -> Prop := + | extcall_io_sem_intro: forall vargs m args res vres, + eventval_list_match args (sig_args sg) vargs -> + eventval_match res (proj_sig_res sg) vres -> + extcall_io_sem name sg vargs m (Event_syscall name args res :: E0) vres m. + +Remark eventval_match_lessdef: + forall ev ty v1 v2, + eventval_match ev ty v1 -> Val.lessdef v1 v2 -> eventval_match ev ty v2. +Proof. + intros. inv H; inv H0; constructor. +Qed. + +Remark eventval_list_match_lessdef: + forall evl tyl vl1, eventval_list_match evl tyl vl1 -> + forall vl2, Val.lessdef_list vl1 vl2 -> eventval_list_match evl tyl vl2. +Proof. + induction 1; intros. inv H; constructor. + inv H1. constructor. eapply eventval_match_lessdef; eauto. eauto. +Qed. + +Remark eventval_match_inject: + forall f ev ty v1 v2, + eventval_match ev ty v1 -> val_inject f v1 v2 -> eventval_match ev ty v2. +Proof. + intros. inv H; inv H0; constructor. +Qed. + +Remark eventval_match_inject_2: + forall f ev ty v, + eventval_match ev ty v -> val_inject f v v. +Proof. + induction 1; constructor. +Qed. + +Remark eventval_list_match_inject: + forall f evl tyl vl1, eventval_list_match evl tyl vl1 -> + forall vl2, val_list_inject f vl1 vl2 -> eventval_list_match evl tyl vl2. +Proof. + induction 1; intros. inv H; constructor. + inv H1. constructor. eapply eventval_match_inject; eauto. eauto. +Qed. + +Remark eventval_list_match_length: + forall evl tyl vl, eventval_list_match evl tyl vl -> List.length vl = List.length tyl. +Proof. + induction 1; simpl; eauto. +Qed. + +Remark eventval_match_determ_1: + forall ev ty v1 v2, eventval_match ev ty v1 -> eventval_match ev ty v2 -> v1 = v2. +Proof. + intros. inv H; inv H0; auto. +Qed. + +Remark eventval_match_determ_2: + forall ev1 ev2 ty v, eventval_match ev1 ty v -> eventval_match ev2 ty v -> ev1 = ev2. +Proof. + intros. inv H; inv H0; auto. +Qed. + +Remark eventval_list_match_determ_2: + forall evl1 tyl vl, eventval_list_match evl1 tyl vl -> + forall evl2, eventval_list_match evl2 tyl vl -> evl1 = evl2. +Proof. + induction 1; intros. inv H. auto. inv H1. f_equal; eauto. + eapply eventval_match_determ_2; eauto. +Qed. + +Lemma extcall_io_ok: + forall name sg, + extcall_properties (extcall_io_sem name sg) sg. +Proof. + intros; constructor; intros. + + inv H. inv H1; constructor. + + inv H. eapply eventval_list_match_length; eauto. + + inv H; auto. + + inv H; auto. + + inv H. + exists vres; exists m1'; intuition. + econstructor; eauto. eapply eventval_list_match_lessdef; eauto. + red; auto. + + inv H. + exists f; exists vres; exists m1'; intuition. + econstructor; eauto. eapply eventval_list_match_inject; eauto. + eapply eventval_match_inject_2; eauto. + red; auto. + red; auto. + red; intros; congruence. + + inv H; inv H0. simpl in H1. + assert (args = args0) by (eapply eventval_list_match_determ_2; eauto). + destruct H1; auto. subst. + intuition. eapply eventval_match_determ_1; eauto. +Qed. + +(** ** Combined semantics of external calls *) + +(** Combining the semantics given above for the various kinds of external calls, + we define the predicate [external_call] that relates: +- the external function being invoked +- the values of the arguments passed to this function +- the memory state before the call +- the result value of the call +- the memory state after the call +- the trace generated by the call (can be empty). + +This predicate is used in the semantics of all CompCert languages. *) + +Definition external_call (ef: external_function): + list val -> mem -> trace -> val -> mem -> Prop := + match classify_external_function ef with + | EF_syscall sg name => extcall_io_sem name sg + | EF_load label chunk => extcall_load_sem label chunk + | EF_store label chunk => extcall_store_sem label chunk + | EF_malloc => extcall_malloc_sem + | EF_free => extcall_free_sem + end. + +Theorem external_call_spec: + forall ef, + extcall_properties (external_call ef) (ef.(ef_sig)). +Proof. + intros. unfold external_call. destruct (classify_external_function ef). + apply extcall_io_ok. + apply extcall_load_ok. + apply extcall_store_ok. + apply extcall_malloc_ok. + apply extcall_free_ok. +Qed. + +Definition external_call_well_typed ef := ec_well_typed _ _ (external_call_spec ef). +Definition external_call_arity ef := ec_arity _ _ (external_call_spec ef). +Definition external_call_valid_block ef := ec_valid_block _ _ (external_call_spec ef). +Definition external_call_bounds ef := ec_bounds _ _ (external_call_spec ef). +Definition external_call_mem_extends ef := ec_mem_extends _ _ (external_call_spec ef). +Definition external_call_mem_inject ef := ec_mem_inject _ _ (external_call_spec ef). +Definition external_call_determ ef := ec_determ _ _ (external_call_spec ef). diff --git a/common/Globalenvs.v b/common/Globalenvs.v index 1ce7bf5..9dbf902 100644 --- a/common/Globalenvs.v +++ b/common/Globalenvs.v @@ -38,530 +38,259 @@ Require Import Errors. Require Import Maps. Require Import AST. Require Import Integers. +Require Import Floats. Require Import Values. -Require Import Mem. +Require Import Memory. -Set Implicit Arguments. +Notation "s #1" := (fst s) (at level 9, format "s '#1'") : pair_scope. +Notation "s #2" := (snd s) (at level 9, format "s '#2'") : pair_scope. -Module Type GENV. - -(** ** Types and operations *) - - Variable t: Type -> Type. - (** The type of global environments. The parameter [F] is the type - of function descriptions. *) - - Variable globalenv: forall (F V: Type), program F V -> t F. - (** Return the global environment for the given program. *) - - Variable init_mem: forall (F V: Type), program F V -> mem. - (** Return the initial memory state for the given program. *) - - Variable find_funct_ptr: forall (F: Type), t F -> block -> option F. - (** Return the function description associated with the given address, - if any. *) - - Variable find_funct: forall (F: Type), t F -> val -> option F. - (** Same as [find_funct_ptr] but the function address is given as - a value, which must be a pointer with offset 0. *) - - Variable find_symbol: forall (F: Type), t F -> ident -> option block. - (** Return the address of the given global symbol, if any. *) - -(** ** Properties of the operations. *) - - Hypothesis find_funct_inv: - forall (F: Type) (ge: t F) (v: val) (f: F), - find_funct ge v = Some f -> exists b, v = Vptr b Int.zero. - Hypothesis find_funct_find_funct_ptr: - forall (F: Type) (ge: t F) (b: block), - find_funct ge (Vptr b Int.zero) = find_funct_ptr ge b. - - Hypothesis find_symbol_exists: - forall (F V: Type) (p: program F V) - (id: ident) (init: list init_data) (v: V), - In (id, init, v) (prog_vars p) -> - exists b, find_symbol (globalenv p) id = Some b. - Hypothesis find_funct_ptr_exists: - forall (F V: Type) (p: program F V) (id: ident) (f: F), - list_norepet (prog_funct_names p) -> - list_disjoint (prog_funct_names p) (prog_var_names p) -> - In (id, f) (prog_funct p) -> - exists b, find_symbol (globalenv p) id = Some b - /\ find_funct_ptr (globalenv p) b = Some f. - - Hypothesis find_funct_ptr_inversion: - forall (F V: Type) (P: F -> Prop) (p: program F V) (b: block) (f: F), - find_funct_ptr (globalenv p) b = Some f -> - exists id, In (id, f) (prog_funct p). - Hypothesis find_funct_inversion: - forall (F V: Type) (P: F -> Prop) (p: program F V) (v: val) (f: F), - find_funct (globalenv p) v = Some f -> - exists id, In (id, f) (prog_funct p). - Hypothesis find_funct_ptr_symbol_inversion: - forall (F V: Type) (p: program F V) (id: ident) (b: block) (f: F), - find_symbol (globalenv p) id = Some b -> - find_funct_ptr (globalenv p) b = Some f -> - In (id, f) p.(prog_funct). - - Hypothesis find_funct_ptr_prop: - forall (F V: Type) (P: F -> Prop) (p: program F V) (b: block) (f: F), - (forall id f, In (id, f) (prog_funct p) -> P f) -> - find_funct_ptr (globalenv p) b = Some f -> - P f. - Hypothesis find_funct_prop: - forall (F V: Type) (P: F -> Prop) (p: program F V) (v: val) (f: F), - (forall id f, In (id, f) (prog_funct p) -> P f) -> - find_funct (globalenv p) v = Some f -> - P f. - - Hypothesis initmem_nullptr: - forall (F V: Type) (p: program F V), - let m := init_mem p in - valid_block m nullptr /\ - m.(blocks) nullptr = empty_block 0 0. - Hypothesis initmem_inject_neutral: - forall (F V: Type) (p: program F V), - mem_inject_neutral (init_mem p). - Hypothesis find_funct_ptr_negative: - forall (F V: Type) (p: program F V) (b: block) (f: F), - find_funct_ptr (globalenv p) b = Some f -> b < 0. - Hypothesis find_symbol_not_fresh: - forall (F V: Type) (p: program F V) (id: ident) (b: block), - find_symbol (globalenv p) id = Some b -> b < nextblock (init_mem p). - Hypothesis find_symbol_not_nullptr: - forall (F V: Type) (p: program F V) (id: ident) (b: block), - find_symbol (globalenv p) id = Some b -> b <> nullptr. - Hypothesis global_addresses_distinct: - forall (F V: Type) (p: program F V) id1 id2 b1 b2, - id1<>id2 -> - find_symbol (globalenv p) id1 = Some b1 -> - find_symbol (globalenv p) id2 = Some b2 -> - b1<>b2. - -(** Commutation properties between program transformations - and operations over global environments. *) - - Hypothesis find_funct_ptr_transf: - forall (A B V: Type) (transf: A -> B) (p: program A V), - forall (b: block) (f: A), - find_funct_ptr (globalenv p) b = Some f -> - find_funct_ptr (globalenv (transform_program transf p)) b = Some (transf f). - Hypothesis find_funct_transf: - forall (A B V: Type) (transf: A -> B) (p: program A V), - forall (v: val) (f: A), - find_funct (globalenv p) v = Some f -> - find_funct (globalenv (transform_program transf p)) v = Some (transf f). - Hypothesis find_symbol_transf: - forall (A B V: Type) (transf: A -> B) (p: program A V), - forall (s: ident), - find_symbol (globalenv (transform_program transf p)) s = - find_symbol (globalenv p) s. - Hypothesis init_mem_transf: - forall (A B V: Type) (transf: A -> B) (p: program A V), - init_mem (transform_program transf p) = init_mem p. - Hypothesis find_funct_ptr_rev_transf: - forall (A B V: Type) (transf: A -> B) (p: program A V), - forall (b : block) (tf : B), - find_funct_ptr (globalenv (transform_program transf p)) b = Some tf -> - exists f : A, find_funct_ptr (globalenv p) b = Some f /\ transf f = tf. - Hypothesis find_funct_rev_transf: - forall (A B V: Type) (transf: A -> B) (p: program A V), - forall (v : val) (tf : B), - find_funct (globalenv (transform_program transf p)) v = Some tf -> - exists f : A, find_funct (globalenv p) v = Some f /\ transf f = tf. - -(** Commutation properties between partial program transformations - and operations over global environments. *) - - Hypothesis find_funct_ptr_transf_partial: - forall (A B V: Type) (transf: A -> res B) (p: program A V) (p': program B V), - transform_partial_program transf p = OK p' -> - forall (b: block) (f: A), - find_funct_ptr (globalenv p) b = Some f -> - exists f', - find_funct_ptr (globalenv p') b = Some f' /\ transf f = OK f'. - Hypothesis find_funct_transf_partial: - forall (A B V: Type) (transf: A -> res B) (p: program A V) (p': program B V), - transform_partial_program transf p = OK p' -> - forall (v: val) (f: A), - find_funct (globalenv p) v = Some f -> - exists f', - find_funct (globalenv p') v = Some f' /\ transf f = OK f'. - Hypothesis find_symbol_transf_partial: - forall (A B V: Type) (transf: A -> res B) (p: program A V) (p': program B V), - transform_partial_program transf p = OK p' -> - forall (s: ident), - find_symbol (globalenv p') s = find_symbol (globalenv p) s. - Hypothesis init_mem_transf_partial: - forall (A B V: Type) (transf: A -> res B) (p: program A V) (p': program B V), - transform_partial_program transf p = OK p' -> - init_mem p' = init_mem p. - Hypothesis find_funct_ptr_rev_transf_partial: - forall (A B V: Type) (transf: A -> res B) (p: program A V) (p': program B V), - transform_partial_program transf p = OK p' -> - forall (b : block) (tf : B), - find_funct_ptr (globalenv p') b = Some tf -> - exists f : A, - find_funct_ptr (globalenv p) b = Some f /\ transf f = OK tf. - Hypothesis find_funct_rev_transf_partial: - forall (A B V: Type) (transf: A -> res B) (p: program A V) (p': program B V), - transform_partial_program transf p = OK p' -> - forall (v : val) (tf : B), - find_funct (globalenv p') v = Some tf -> - exists f : A, - find_funct (globalenv p) v = Some f /\ transf f = OK tf. - - Hypothesis find_funct_ptr_transf_partial2: - forall (A B V W: Type) (transf_fun: A -> res B) (transf_var: V -> res W) - (p: program A V) (p': program B W), - transform_partial_program2 transf_fun transf_var p = OK p' -> - forall (b: block) (f: A), - find_funct_ptr (globalenv p) b = Some f -> - exists f', - find_funct_ptr (globalenv p') b = Some f' /\ transf_fun f = OK f'. - Hypothesis find_funct_transf_partial2: - forall (A B V W: Type) (transf_fun: A -> res B) (transf_var: V -> res W) - (p: program A V) (p': program B W), - transform_partial_program2 transf_fun transf_var p = OK p' -> - forall (v: val) (f: A), - find_funct (globalenv p) v = Some f -> - exists f', - find_funct (globalenv p') v = Some f' /\ transf_fun f = OK f'. - Hypothesis find_symbol_transf_partial2: - forall (A B V W: Type) (transf_fun: A -> res B) (transf_var: V -> res W) - (p: program A V) (p': program B W), - transform_partial_program2 transf_fun transf_var p = OK p' -> - forall (s: ident), - find_symbol (globalenv p') s = find_symbol (globalenv p) s. - Hypothesis init_mem_transf_partial2: - forall (A B V W: Type) (transf_fun: A -> res B) (transf_var: V -> res W) - (p: program A V) (p': program B W), - transform_partial_program2 transf_fun transf_var p = OK p' -> - init_mem p' = init_mem p. - Hypothesis find_funct_ptr_rev_transf_partial2: - forall (A B V W: Type) (transf_fun: A -> res B) (transf_var: V -> res W) - (p: program A V) (p': program B W), - transform_partial_program2 transf_fun transf_var p = OK p' -> - forall (b : block) (tf : B), - find_funct_ptr (globalenv p') b = Some tf -> - exists f : A, - find_funct_ptr (globalenv p) b = Some f /\ transf_fun f = OK tf. - Hypothesis find_funct_rev_transf_partial2: - forall (A B V W: Type) (transf_fun: A -> res B) (transf_var: V -> res W) - (p: program A V) (p': program B W), - transform_partial_program2 transf_fun transf_var p = OK p' -> - forall (v : val) (tf : B), - find_funct (globalenv p') v = Some tf -> - exists f : A, - find_funct (globalenv p) v = Some f /\ transf_fun f = OK tf. - -(** Commutation properties between matching between programs - and operations over global environments. *) - - Hypothesis find_funct_ptr_match: - forall (A B V W: Type) (match_fun: A -> B -> Prop) - (match_var: V -> W -> Prop) (p: program A V) (p': program B W), - match_program match_fun match_var p p' -> - forall (b : block) (f : A), - find_funct_ptr (globalenv p) b = Some f -> - exists tf : B, - find_funct_ptr (globalenv p') b = Some tf /\ match_fun f tf. - Hypothesis find_funct_ptr_rev_match: - forall (A B V W: Type) (match_fun: A -> B -> Prop) - (match_var: V -> W -> Prop) (p: program A V) (p': program B W), - match_program match_fun match_var p p' -> - forall (b : block) (tf : B), - find_funct_ptr (globalenv p') b = Some tf -> - exists f : A, - find_funct_ptr (globalenv p) b = Some f /\ match_fun f tf. - Hypothesis find_funct_match: - forall (A B V W: Type) (match_fun: A -> B -> Prop) - (match_var: V -> W -> Prop) (p: program A V) (p': program B W), - match_program match_fun match_var p p' -> - forall (v : val) (f : A), - find_funct (globalenv p) v = Some f -> - exists tf : B, find_funct (globalenv p') v = Some tf /\ match_fun f tf. - Hypothesis find_funct_rev_match: - forall (A B V W: Type) (match_fun: A -> B -> Prop) - (match_var: V -> W -> Prop) (p: program A V) (p': program B W), - match_program match_fun match_var p p' -> - forall (v : val) (tf : B), - find_funct (globalenv p') v = Some tf -> - exists f : A, find_funct (globalenv p) v = Some f /\ match_fun f tf. - Hypothesis find_symbol_match: - forall (A B V W: Type) (match_fun: A -> B -> Prop) - (match_var: V -> W -> Prop) (p: program A V) (p': program B W), - match_program match_fun match_var p p' -> - forall (s : ident), - find_symbol (globalenv p') s = find_symbol (globalenv p) s. - Hypothesis init_mem_match: - forall (A B V W: Type) (match_fun: A -> B -> Prop) - (match_var: V -> W -> Prop) (p: program A V) (p': program B W), - match_program match_fun match_var p p' -> - init_mem p' = init_mem p. +Local Open Scope pair_scope. +Local Open Scope error_monad_scope. -End GENV. +Set Implicit Arguments. -(** The rest of this library is a straightforward implementation of - the module signature above. *) +Module Genv. -Module Genv: GENV. +(** * Global environments *) Section GENV. -Variable F: Type. (* The type of functions *) -Variable V: Type. (* The type of information over variables *) - -Record genv : Type := mkgenv { - functions: ZMap.t (option F); (* mapping function ptr -> function *) - nextfunction: Z; - symbols: PTree.t block (* mapping symbol -> block *) +Variable F: Type. (**r The type of function descriptions *) +Variable V: Type. (**r The type of information attached to variables *) + +(** The type of global environments. *) + +Record t: Type := mkgenv { + genv_symb: PTree.t block; (**r mapping symbol -> block *) + genv_funs: ZMap.t (option F); (**r mapping function pointer -> definition *) + genv_vars: ZMap.t (option V); (**r mapping variable pointer -> info *) + genv_nextfun: block; (**r next function pointer *) + genv_nextvar: block; (**r next variable pointer *) + genv_nextfun_neg: genv_nextfun < 0; + genv_nextvar_pos: genv_nextvar > 0; + genv_symb_range: forall id b, PTree.get id genv_symb = Some b -> b <> 0 /\ genv_nextfun < b /\ b < genv_nextvar; + genv_funs_range: forall b f, ZMap.get b genv_funs = Some f -> genv_nextfun < b < 0; + genv_vars_range: forall b v, ZMap.get b genv_vars = Some v -> 0 < b < genv_nextvar }. -Definition t := genv. +(** ** Lookup functions *) -Definition add_funct (name_fun: (ident * F)) (g: genv) : genv := - let b := g.(nextfunction) in - mkgenv (ZMap.set b (Some (snd name_fun)) g.(functions)) - (Zpred b) - (PTree.set (fst name_fun) b g.(symbols)). +(** [find_symbol ge id] returns the block associated with the given name, if any *) -Definition add_symbol (name: ident) (b: block) (g: genv) : genv := - mkgenv g.(functions) - g.(nextfunction) - (PTree.set name b g.(symbols)). +Definition find_symbol (ge: t) (id: ident) : option block := + PTree.get id ge.(genv_symb). -Definition find_funct_ptr (g: genv) (b: block) : option F := - ZMap.get b g.(functions). +(** [find_funct_ptr ge b] returns the function description associated with + the given address. *) -Definition find_funct (g: genv) (v: val) : option F := +Definition find_funct_ptr (ge: t) (b: block) : option F := + ZMap.get b ge.(genv_funs). + +(** [find_funct] is similar to [find_funct_ptr], but the function address + is given as a value, which must be a pointer with offset 0. *) + +Definition find_funct (ge: t) (v: val) : option F := match v with - | Vptr b ofs => - if Int.eq ofs Int.zero then find_funct_ptr g b else None - | _ => - None + | Vptr b ofs => if Int.eq_dec ofs Int.zero then find_funct_ptr ge b else None + | _ => None end. -Definition find_symbol (g: genv) (symb: ident) : option block := - PTree.get symb g.(symbols). +(** [find_var_info ge b] returns the information attached to the variable + at address [b]. *) + +Definition find_var_info (ge: t) (b: block) : option V := + ZMap.get b ge.(genv_vars). + +(** ** Constructing the global environment *) + +Program Definition add_function (ge: t) (idf: ident * F) : t := + @mkgenv + (PTree.set idf#1 ge.(genv_nextfun) ge.(genv_symb)) + (ZMap.set ge.(genv_nextfun) (Some idf#2) ge.(genv_funs)) + ge.(genv_vars) + (ge.(genv_nextfun) - 1) + ge.(genv_nextvar) + _ _ _ _ _. +Next Obligation. + destruct ge; simpl; omega. +Qed. +Next Obligation. + destruct ge; auto. +Qed. +Next Obligation. + destruct ge; simpl in *. + rewrite PTree.gsspec in H. destruct (peq id i). inv H. unfold block; omega. + exploit genv_symb_range0; eauto. unfold block; omega. +Qed. +Next Obligation. + destruct ge; simpl in *. rewrite ZMap.gsspec in H. + destruct (ZIndexed.eq b genv_nextfun0). subst; omega. + exploit genv_funs_range0; eauto. omega. +Qed. +Next Obligation. + destruct ge; eauto. +Qed. + +Program Definition add_variable (ge: t) (idv: ident * list init_data * V) : t := + @mkgenv + (PTree.set idv#1#1 ge.(genv_nextvar) ge.(genv_symb)) + ge.(genv_funs) + (ZMap.set ge.(genv_nextvar) (Some idv#2) ge.(genv_vars)) + ge.(genv_nextfun) + (ge.(genv_nextvar) + 1) + _ _ _ _ _. +Next Obligation. + destruct ge; auto. +Qed. +Next Obligation. + destruct ge; simpl; omega. +Qed. +Next Obligation. + destruct ge; simpl in *. + rewrite PTree.gsspec in H. destruct (peq id i). inv H. unfold block; omega. + exploit genv_symb_range0; eauto. unfold block; omega. +Qed. +Next Obligation. + destruct ge; eauto. +Qed. +Next Obligation. + destruct ge; simpl in *. rewrite ZMap.gsspec in H. + destruct (ZIndexed.eq b genv_nextvar0). subst; omega. + exploit genv_vars_range0; eauto. omega. +Qed. + +Program Definition empty_genv : t := + @mkgenv (PTree.empty block) (ZMap.init None) (ZMap.init None) (-1) 1 _ _ _ _ _. +Next Obligation. + omega. +Qed. +Next Obligation. + omega. +Qed. +Next Obligation. + rewrite PTree.gempty in H. discriminate. +Qed. +Next Obligation. + rewrite ZMap.gi in H. discriminate. +Qed. +Next Obligation. + rewrite ZMap.gi in H. discriminate. +Qed. + +Definition add_functions (ge: t) (fl: list (ident * F)) : t := + List.fold_left add_function fl ge. + +Definition add_variables (ge: t) (vl: list (ident * list init_data * V)) : t := + List.fold_left add_variable vl ge. + +Definition globalenv (p: program F V) := + add_variables (add_functions empty_genv p.(prog_funct)) p.(prog_vars). -Lemma find_funct_inv: - forall (ge: t) (v: val) (f: F), +(** ** Properties of the operations over global environments *) + +Theorem find_funct_inv: + forall ge v f, find_funct ge v = Some f -> exists b, v = Vptr b Int.zero. Proof. - intros until f. unfold find_funct. destruct v; try (intros; discriminate). - generalize (Int.eq_spec i Int.zero). case (Int.eq i Int.zero); intros. - exists b. congruence. - discriminate. -Qed. - -Lemma find_funct_find_funct_ptr: - forall (ge: t) (b: block), - find_funct ge (Vptr b Int.zero) = find_funct_ptr ge b. -Proof. - intros. simpl. - generalize (Int.eq_spec Int.zero Int.zero). - case (Int.eq Int.zero Int.zero); intros. - auto. tauto. -Qed. - -(* Construct environment and initial memory store *) - -Definition empty : genv := - mkgenv (ZMap.init None) (-1) (PTree.empty block). - -Definition add_functs (init: genv) (fns: list (ident * F)) : genv := - List.fold_right add_funct init fns. - -Definition add_globals - (init: genv * mem) (vars: list (ident * list init_data * V)) - : genv * mem := - List.fold_right - (fun (id_init: ident * list init_data * V) (g_st: genv * mem) => - match id_init, g_st with - | ((id, init), info), (g, st) => - let (st', b) := Mem.alloc_init_data st init in - (add_symbol id b g, st') - end) - init vars. - -Definition globalenv_initmem (p: program F V) : (genv * mem) := - add_globals - (add_functs empty p.(prog_funct), Mem.empty) - p.(prog_vars). - -Definition globalenv (p: program F V) : genv := - fst (globalenv_initmem p). -Definition init_mem (p: program F V) : mem := - snd (globalenv_initmem p). - -Lemma functions_globalenv: - forall (p: program F V), - functions (globalenv p) = functions (add_functs empty p.(prog_funct)). -Proof. - assert (forall init vars, - functions (fst (add_globals init vars)) = functions (fst init)). - induction vars; simpl. - reflexivity. - destruct a as [[id1 init1] info1]. destruct (add_globals init vars). - simpl. exact IHvars. - - unfold add_globals; simpl. - intros. unfold globalenv; unfold globalenv_initmem. - rewrite H. reflexivity. -Qed. - -Lemma initmem_nullptr: - forall (p: program F V), - let m := init_mem p in - valid_block m nullptr /\ - m.(blocks) nullptr = mkblock 0 0 (fun y => Undef). -Proof. - pose (P := fun m => valid_block m nullptr /\ - m.(blocks) nullptr = mkblock 0 0 (fun y => Undef)). - assert (forall init, P (snd init) -> forall vars, P (snd (add_globals init vars))). - induction vars; simpl; intros. - auto. - destruct a as [[id1 in1] inf1]. - destruct (add_globals init vars) as [g st]. - simpl in *. destruct IHvars. split. - red; simpl. red in H0. omega. - simpl. rewrite update_o. auto. unfold block. red in H0. omega. - - intro. unfold init_mem, globalenv_initmem. apply H. - red; simpl. split. compute. auto. reflexivity. -Qed. + intros until f; unfold find_funct. + destruct v; try congruence. + destruct (Int.eq_dec i Int.zero); try congruence. + intros. exists b; congruence. +Qed. -Lemma initmem_inject_neutral: - forall (p: program F V), - mem_inject_neutral (init_mem p). -Proof. - assert (forall g0 vars g1 m, - add_globals (g0, Mem.empty) vars = (g1, m) -> - mem_inject_neutral m). - Opaque alloc_init_data. - induction vars; simpl. - intros. inv H. red; intros. destruct (load_inv _ _ _ _ _ H). - simpl in H1. rewrite Mem.getN_init in H1. - replace v with Vundef. auto. destruct chunk; simpl in H1; auto. - destruct a as [[id1 init1] info1]. - caseEq (add_globals (g0, Mem.empty) vars). intros g1 m1 EQ. - caseEq (alloc_init_data m1 init1). intros m2 b ALLOC. - intros. inv H. - eapply Mem.alloc_init_data_neutral; eauto. - intros. caseEq (globalenv_initmem p). intros g m EQ. - unfold init_mem; rewrite EQ; simpl. - unfold globalenv_initmem in EQ. eauto. -Qed. - -Remark nextfunction_add_functs_neg: - forall fns, nextfunction (add_functs empty fns) < 0. -Proof. - induction fns; simpl; intros. omega. unfold Zpred. omega. +Theorem find_funct_find_funct_ptr: + forall ge b, + find_funct ge (Vptr b Int.zero) = find_funct_ptr ge b. +Proof. + intros; simpl. apply dec_eq_true. Qed. -Theorem find_funct_ptr_negative: - forall (p: program F V) (b: block) (f: F), - find_funct_ptr (globalenv p) b = Some f -> b < 0. +Theorem find_symbol_exists: + forall p id init v, + In (id, init, v) (prog_vars p) -> + exists b, find_symbol (globalenv p) id = Some b. Proof. - intros until f. - assert (forall fns, ZMap.get b (functions (add_functs empty fns)) = Some f -> b < 0). - induction fns; simpl. - rewrite ZMap.gi. congruence. - rewrite ZMap.gsspec. case (ZIndexed.eq b (nextfunction (add_functs empty fns))); intro. - intro. rewrite e. apply nextfunction_add_functs_neg. - auto. - unfold find_funct_ptr. rewrite functions_globalenv. - intros. eauto. -Qed. - -Remark find_symbol_add_functs_negative: - forall (fns: list (ident * F)) s b, - (symbols (add_functs empty fns)) ! s = Some b -> b < 0. -Proof. - induction fns; simpl; intros until b. - rewrite PTree.gempty. congruence. - rewrite PTree.gsspec. destruct a; simpl. case (peq s i); intro. - intro EQ; inversion EQ. apply nextfunction_add_functs_neg. + intros until v. + assert (forall vl ge, + (exists b, find_symbol ge id = Some b) -> + exists b, find_symbol (add_variables ge vl) id = Some b). + unfold find_symbol; induction vl; simpl; intros. auto. apply IHvl. + simpl. rewrite PTree.gsspec. fold ident. destruct (peq id a#1#1). + exists (genv_nextvar ge); auto. auto. + + assert (forall vl ge, In (id, init, v) vl -> + exists b, find_symbol (add_variables ge vl) id = Some b). + unfold find_symbol; induction vl; simpl; intros. contradiction. + destruct H0. apply H. subst; unfold find_symbol; simpl. + rewrite PTree.gss. exists (genv_nextvar ge); auto. eauto. + + intros. unfold globalenv; eauto. Qed. -Remark find_symbol_add_symbols_not_fresh: - forall fns vars g m s b, - add_globals (add_functs empty fns, Mem.empty) vars = (g, m) -> - (symbols g)!s = Some b -> - b < nextblock m. +Remark add_functions_same_symb: + forall id fl ge, + ~In id (map (@fst ident F) fl) -> + find_symbol (add_functions ge fl) id = find_symbol ge id. Proof. - induction vars; simpl; intros until b. - intros. inversion H. subst g m. simpl. - generalize (find_symbol_add_functs_negative fns s H0). omega. - Transparent alloc_init_data. - destruct a as [[id1 init1] info1]. - caseEq (add_globals (add_functs empty fns, Mem.empty) vars). - intros g1 m1 ADG EQ. inversion EQ; subst g m; clear EQ. - unfold add_symbol; simpl. rewrite PTree.gsspec. case (peq s id1); intro. - intro EQ; inversion EQ. omega. - intro. generalize (IHvars _ _ _ _ ADG H). omega. + induction fl; simpl; intros. auto. + rewrite IHfl. unfold find_symbol; simpl. apply PTree.gso. intuition. intuition. Qed. -Theorem find_symbol_not_fresh: - forall (p: program F V) (id: ident) (b: block), - find_symbol (globalenv p) id = Some b -> b < nextblock (init_mem p). +Remark add_functions_same_address: + forall b fl ge, + b > ge.(genv_nextfun) -> + find_funct_ptr (add_functions ge fl) b = find_funct_ptr ge b. Proof. - intros until b. unfold find_symbol, globalenv, init_mem, globalenv_initmem; simpl. - caseEq (add_globals (add_functs empty (prog_funct p), Mem.empty) - (prog_vars p)); intros g m EQ. - simpl; intros. eapply find_symbol_add_symbols_not_fresh; eauto. + induction fl; simpl; intros. auto. + rewrite IHfl. unfold find_funct_ptr; simpl. apply ZMap.gso. + red; intros; subst b; omegaContradiction. + simpl. omega. Qed. -Lemma find_symbol_exists: - forall (p: program F V) - (id: ident) (init: list init_data) (v: V), - In (id, init, v) (prog_vars p) -> - exists b, find_symbol (globalenv p) id = Some b. +Remark add_variables_same_symb: + forall id vl ge, + ~In id (map (fun idv => idv#1#1) vl) -> + find_symbol (add_variables ge vl) id = find_symbol ge id. Proof. - intros until v. - assert (forall initm vl, In (id, init, v) vl -> - exists b, PTree.get id (symbols (fst (add_globals initm vl))) = Some b). - induction vl; simpl; intros. - elim H. - destruct a as [[id0 init0] v0]. - caseEq (add_globals initm vl). intros g1 m1 EQ. simpl. - rewrite PTree.gsspec. destruct (peq id id0). econstructor; eauto. - elim H; intro. congruence. generalize (IHvl H0). rewrite EQ. auto. - intros. unfold globalenv, find_symbol, globalenv_initmem. auto. -Qed. - -Remark find_symbol_above_nextfunction: - forall (id: ident) (b: block) (fns: list (ident * F)), - let g := add_functs empty fns in - PTree.get id g.(symbols) = Some b -> - b > g.(nextfunction). -Proof. - induction fns; simpl. - rewrite PTree.gempty. congruence. - rewrite PTree.gsspec. case (peq id (fst a)); intro. - intro EQ. inversion EQ. unfold Zpred. omega. - intros. generalize (IHfns H). unfold Zpred; omega. -Qed. - -Remark find_symbol_add_globals: - forall (id: ident) (ge_m: t * mem) (vars: list (ident * list init_data * V)), - ~In id (map (fun x: ident * list init_data * V => fst(fst x)) vars) -> - find_symbol (fst (add_globals ge_m vars)) id = - find_symbol (fst ge_m) id. -Proof. - unfold find_symbol; induction vars; simpl; intros. - auto. - destruct a as [[id0 init0] var0]. simpl in *. - caseEq (add_globals ge_m vars); intros ge' m' EQ. - simpl. rewrite PTree.gso. rewrite EQ in IHvars. simpl in IHvars. - apply IHvars. tauto. intuition congruence. + induction vl; simpl; intros. auto. + rewrite IHvl. unfold find_symbol; simpl. apply PTree.gso. intuition. intuition. +Qed. + +Remark add_variables_same_address: + forall b vl ge, + b < ge.(genv_nextvar) -> + find_var_info (add_variables ge vl) b = find_var_info ge b. +Proof. + induction vl; simpl; intros. auto. + rewrite IHvl. unfold find_var_info; simpl. apply ZMap.gso. + red; intros; subst b; omegaContradiction. + simpl. omega. +Qed. + +Remark add_variables_same_funs: + forall b vl ge, find_funct_ptr (add_variables ge vl) b = find_funct_ptr ge b. +Proof. + induction vl; simpl; intros. auto. rewrite IHvl. auto. +Qed. + +Remark add_functions_nextvar: + forall fl ge, genv_nextvar (add_functions ge fl) = genv_nextvar ge. +Proof. + induction fl; simpl; intros. auto. rewrite IHfl. auto. +Qed. + +Remark add_variables_nextvar: + forall vl ge, genv_nextvar (add_variables ge vl) = genv_nextvar ge + Z_of_nat(List.length vl). +Proof. + induction vl; intros. + simpl. unfold block; omega. + simpl length; rewrite inj_S; simpl. rewrite IHvl. simpl. unfold block; omega. Qed. -Lemma find_funct_ptr_exists: - forall (p: program F V) (id: ident) (f: F), +Theorem find_funct_ptr_exists: + forall p id f, list_norepet (prog_funct_names p) -> list_disjoint (prog_funct_names p) (prog_var_names p) -> In (id, f) (prog_funct p) -> @@ -569,384 +298,784 @@ Lemma find_funct_ptr_exists: /\ find_funct_ptr (globalenv p) b = Some f. Proof. intros until f. - assert (forall (fns: list (ident * F)), - list_norepet (map (@fst ident F) fns) -> - In (id, f) fns -> - exists b, find_symbol (add_functs empty fns) id = Some b - /\ find_funct_ptr (add_functs empty fns) b = Some f). - unfold find_symbol, find_funct_ptr. induction fns; intros. - elim H0. - destruct a as [id0 f0]; simpl in *. inv H. - unfold add_funct; simpl. - rewrite PTree.gsspec. destruct (peq id id0). - subst id0. econstructor; split. eauto. - replace f0 with f. apply ZMap.gss. - elim H0; intro. congruence. elim H3. - change id with (@fst ident F (id, f)). apply List.in_map. auto. - exploit IHfns; eauto. elim H0; intro. congruence. auto. - intros [b [X Y]]. exists b; split. auto. rewrite ZMap.gso. auto. - generalize (find_symbol_above_nextfunction _ _ X). - unfold block; unfold ZIndexed.t; intro; omega. - - intros. exploit H; eauto. intros [b [X Y]]. - exists b; split. - unfold globalenv, globalenv_initmem. rewrite find_symbol_add_globals. - assumption. apply list_disjoint_notin with (prog_funct_names p). assumption. - unfold prog_funct_names. change id with (fst (id, f)). - apply List.in_map; auto. - unfold find_funct_ptr. rewrite functions_globalenv. - assumption. -Qed. - -Lemma find_funct_ptr_inversion: - forall (P: F -> Prop) (p: program F V) (b: block) (f: F), - find_funct_ptr (globalenv p) b = Some f -> - exists id, In (id, f) (prog_funct p). -Proof. - intros until f. - assert (forall fns: list (ident * F), - find_funct_ptr (add_functs empty fns) b = Some f -> - exists id, In (id, f) fns). - unfold find_funct_ptr. induction fns; simpl. - rewrite ZMap.gi. congruence. - destruct a as [id0 f0]; simpl. - rewrite ZMap.gsspec. destruct (ZIndexed.eq b (nextfunction (add_functs empty fns))). - intro. inv H. exists id0; auto. - intro. exploit IHfns; eauto. intros [id A]. exists id; auto. - unfold find_funct_ptr; rewrite functions_globalenv. intros; apply H; auto. -Qed. - -Lemma find_funct_ptr_prop: - forall (P: F -> Prop) (p: program F V) (b: block) (f: F), + + assert (forall fl ge, In (id, f) fl -> list_norepet (map (@fst ident F) fl) -> + exists b, find_symbol (add_functions ge fl) id = Some b + /\ find_funct_ptr (add_functions ge fl) b = Some f). + induction fl; simpl; intros. contradiction. inv H0. + destruct H. subst a. exists (genv_nextfun ge); split. + rewrite add_functions_same_symb; auto. unfold find_symbol; simpl. apply PTree.gss. + rewrite add_functions_same_address. unfold find_funct_ptr; simpl. apply ZMap.gss. + simpl; omega. + apply IHfl; auto. + + intros. exploit (H p.(prog_funct) empty_genv); eauto. intros [b [A B]]. + unfold globalenv; exists b; split. + rewrite add_variables_same_symb. auto. eapply list_disjoint_notin; eauto. + unfold prog_funct_names. change id with (fst (id, f)). apply in_map; auto. + rewrite add_variables_same_funs. auto. +Qed. + +Theorem find_funct_ptr_prop: + forall (P: F -> Prop) p b f, (forall id f, In (id, f) (prog_funct p) -> P f) -> find_funct_ptr (globalenv p) b = Some f -> P f. Proof. - intros. exploit find_funct_ptr_inversion; eauto. intros [id A]. eauto. + intros until f. intros PROP. + assert (forall fl ge, + List.incl fl (prog_funct p) -> + match find_funct_ptr ge b with None => True | Some f => P f end -> + match find_funct_ptr (add_functions ge fl) b with None => True | Some f => P f end). + induction fl; simpl; intros. auto. + apply IHfl. eauto with coqlib. unfold find_funct_ptr; simpl. + destruct a as [id' f']; simpl. + rewrite ZMap.gsspec. destruct (ZIndexed.eq b (genv_nextfun ge)). + apply PROP with id'. apply H. auto with coqlib. + assumption. + + unfold globalenv. rewrite add_variables_same_funs. intro. + exploit (H p.(prog_funct) empty_genv). auto with coqlib. + unfold find_funct_ptr; simpl. rewrite ZMap.gi. auto. + rewrite H0. auto. Qed. -Lemma find_funct_inversion: - forall (P: F -> Prop) (p: program F V) (v: val) (f: F), +Theorem find_funct_prop: + forall (P: F -> Prop) p v f, + (forall id f, In (id, f) (prog_funct p) -> P f) -> find_funct (globalenv p) v = Some f -> + P f. +Proof. + intros. exploit find_funct_inv; eauto. intros [b EQ]. subst v. + rewrite find_funct_find_funct_ptr in H0. + eapply find_funct_ptr_prop; eauto. +Qed. + +Theorem find_funct_ptr_inversion: + forall p b f, + find_funct_ptr (globalenv p) b = Some f -> exists id, In (id, f) (prog_funct p). Proof. - intros. exploit find_funct_inv; eauto. intros [b EQ]. rewrite EQ in H. - rewrite find_funct_find_funct_ptr in H. - eapply find_funct_ptr_inversion; eauto. + intros. pattern f. apply find_funct_ptr_prop with p b; auto. + intros. exists id; auto. Qed. -Lemma find_funct_prop: - forall (P: F -> Prop) (p: program F V) (v: val) (f: F), - (forall id f, In (id, f) (prog_funct p) -> P f) -> +Theorem find_funct_inversion: + forall p v f, find_funct (globalenv p) v = Some f -> - P f. + exists id, In (id, f) (prog_funct p). +Proof. + intros. pattern f. apply find_funct_prop with p v; auto. + intros. exists id; auto. +Qed. + +Theorem find_funct_ptr_negative: + forall p b f, + find_funct_ptr (globalenv p) b = Some f -> b < 0. Proof. - intros. exploit find_funct_inversion; eauto. intros [id A]. eauto. + unfold find_funct_ptr. intros. destruct (globalenv p). simpl in H. + exploit genv_funs_range0; eauto. omega. Qed. -Lemma find_funct_ptr_symbol_inversion: - forall (p: program F V) (id: ident) (b: block) (f: F), +Theorem find_var_info_positive: + forall p b v, + find_var_info (globalenv p) b = Some v -> b > 0. +Proof. + unfold find_var_info. intros. destruct (globalenv p). simpl in H. + exploit genv_vars_range0; eauto. omega. +Qed. + +Remark add_variables_symb_neg: + forall id b vl ge, + find_symbol (add_variables ge vl) id = Some b -> b < 0 -> + find_symbol ge id = Some b. +Proof. + induction vl; simpl; intros. auto. + exploit IHvl; eauto. unfold find_symbol; simpl. rewrite PTree.gsspec. + fold ident. destruct (peq id (a#1#1)); auto. intros. inv H1. + generalize (genv_nextvar_pos ge). intros. omegaContradiction. +Qed. + +Theorem find_funct_ptr_symbol_inversion: + forall p id b f, find_symbol (globalenv p) id = Some b -> find_funct_ptr (globalenv p) b = Some f -> In (id, f) p.(prog_funct). Proof. intros until f. - assert (forall fns, - let g := add_functs empty fns in - PTree.get id g.(symbols) = Some b -> - ZMap.get b g.(functions) = Some f -> - In (id, f) fns). - induction fns; simpl. - rewrite ZMap.gi. congruence. - set (g := add_functs empty fns). - rewrite PTree.gsspec. rewrite ZMap.gsspec. - case (peq id (fst a)); intro. - intro EQ. inversion EQ. unfold ZIndexed.eq. rewrite zeq_true. - intro EQ2. left. destruct a. simpl in *. congruence. - intro. unfold ZIndexed.eq. rewrite zeq_false. intro. eauto. - generalize (find_symbol_above_nextfunction _ _ H). fold g. unfold block. omega. - assert (forall g0 m0, b < 0 -> - forall vars g m, - add_globals (g0, m0) vars = (g, m) -> - PTree.get id g.(symbols) = Some b -> - PTree.get id g0.(symbols) = Some b). - induction vars; simpl. - intros. inv H1. auto. - destruct a as [[id1 init1] info1]. caseEq (add_globals (g0, m0) vars). - intros g1 m1 EQ g m EQ1. injection EQ1; simpl; clear EQ1. - unfold add_symbol; intros A B. rewrite <- B. simpl. - rewrite PTree.gsspec. case (peq id id1); intros. - assert (b > 0). inv H1. apply nextblock_pos. - omegaContradiction. - eauto. - intros. - generalize (find_funct_ptr_negative _ _ H2). intro. - pose (g := add_functs empty (prog_funct p)). - apply H. - apply H0 with Mem.empty (prog_vars p) (globalenv p) (init_mem p). - auto. unfold globalenv, init_mem. rewrite <- surjective_pairing. - reflexivity. assumption. rewrite <- functions_globalenv. assumption. + + assert (forall fl ge, + find_symbol (add_functions ge fl) id = Some b -> + find_funct_ptr (add_functions ge fl) b = Some f -> + In (id, f) fl \/ (find_symbol ge id = Some b /\ find_funct_ptr ge b = Some f)). + induction fl; simpl; intros. + auto. + exploit IHfl; eauto. intros [A | [A B]]. auto. + destruct a as [id' f']. + unfold find_symbol in A; simpl in A. + unfold find_funct_ptr in B; simpl in B. + rewrite PTree.gsspec in A. destruct (peq id id'). inv A. + rewrite ZMap.gss in B. inv B. auto. + rewrite ZMap.gso in B. right; auto. + exploit genv_symb_range; eauto. unfold block, ZIndexed.t; omega. + + intros. assert (b < 0) by (eapply find_funct_ptr_negative; eauto). + unfold globalenv in *. rewrite add_variables_same_funs in H1. + exploit (H (prog_funct p) empty_genv). + eapply add_variables_symb_neg; eauto. auto. + intuition. unfold find_symbol in H3; simpl in H3. rewrite PTree.gempty in H3. discriminate. Qed. Theorem find_symbol_not_nullptr: - forall (p: program F V) (id: ident) (b: block), - find_symbol (globalenv p) id = Some b -> b <> nullptr. -Proof. - intros until b. - assert (forall fns, - find_symbol (add_functs empty fns) id = Some b -> - b <> nullptr). - unfold find_symbol; induction fns; simpl. - rewrite PTree.gempty. congruence. - destruct a as [id1 f1]. simpl. rewrite PTree.gsspec. - destruct (peq id id1); intros. - inversion H. generalize (nextfunction_add_functs_neg fns). - unfold block, nullptr; omega. - auto. - set (g0 := add_functs empty p.(prog_funct)). - assert (forall vars g m, - add_globals (g0, Mem.empty) vars = (g, m) -> - find_symbol g id = Some b -> - b <> nullptr). - induction vars; simpl; intros until m. - intros. inversion H0. subst g. apply H with (prog_funct p). auto. - destruct a as [[id1 init1] info1]. - caseEq (add_globals (g0, Mem.empty) vars); intros g1 m1 EQ1 EQ2. - inv EQ2. unfold find_symbol, add_symbol; simpl. rewrite PTree.gsspec. - destruct (peq id id1); intros. - inv H0. generalize (nextblock_pos m1). unfold nullptr, block; omega. - eauto. - intros. eapply H0 with (vars := prog_vars p). apply surjective_pairing. auto. -Qed. + forall p id b, + find_symbol (globalenv p) id = Some b -> b <> Mem.nullptr. +Proof. + intros until b. unfold find_symbol. destruct (globalenv p); simpl. + intros. exploit genv_symb_range0; eauto. intuition. +Qed. Theorem global_addresses_distinct: - forall (p: program F V) id1 id2 b1 b2, + forall p id1 id2 b1 b2, id1<>id2 -> find_symbol (globalenv p) id1 = Some b1 -> find_symbol (globalenv p) id2 = Some b2 -> b1<>b2. Proof. + intros until b2; intro DIFF. + + set (P := fun ge => find_symbol ge id1 = Some b1 -> find_symbol ge id2 = Some b2 -> b1 <> b2). + + assert (forall fl ge, P ge -> P (add_functions ge fl)). + induction fl; intros; simpl. auto. + apply IHfl. red. unfold find_symbol; simpl. + repeat rewrite PTree.gsspec. + fold ident. destruct (peq id1 a#1); destruct (peq id2 a#1). + congruence. + intros. inversion H0. exploit genv_symb_range; eauto. unfold block; omega. + intros. inversion H1. exploit genv_symb_range; eauto. unfold block; omega. + auto. + + assert (forall vl ge, P ge -> P (add_variables ge vl)). + induction vl; intros; simpl. auto. + apply IHvl. red. unfold find_symbol; simpl. + repeat rewrite PTree.gsspec. + fold ident. destruct (peq id1 a#1#1); destruct (peq id2 a#1#1). + congruence. + intros. inversion H1. exploit genv_symb_range; eauto. unfold block; omega. + intros. inversion H2. exploit genv_symb_range; eauto. unfold block; omega. + auto. + + change (P (globalenv p)). unfold globalenv. apply H0. apply H. + red; unfold find_symbol; simpl; intros. rewrite PTree.gempty in H1. congruence. +Qed. + +(** * Construction of the initial memory state *) + +Section INITMEM. + +Variable ge: t. + +Definition init_data_size (i: init_data) : Z := + match i with + | Init_int8 _ => 1 + | Init_int16 _ => 2 + | Init_int32 _ => 4 + | Init_float32 _ => 4 + | Init_float64 _ => 8 + | Init_addrof _ _ => 4 + | Init_space n => Zmax n 0 + end. + +Lemma init_data_size_pos: + forall i, init_data_size i >= 0. +Proof. + destruct i; simpl; try omega. generalize (Zle_max_r z 0). omega. +Qed. + +Definition store_init_data (m: mem) (b: block) (p: Z) (id: init_data) : option mem := + match id with + | Init_int8 n => Mem.store Mint8unsigned m b p (Vint n) + | Init_int16 n => Mem.store Mint16unsigned m b p (Vint n) + | Init_int32 n => Mem.store Mint32 m b p (Vint n) + | Init_float32 n => Mem.store Mfloat32 m b p (Vfloat n) + | Init_float64 n => Mem.store Mfloat64 m b p (Vfloat n) + | Init_addrof symb ofs => + match find_symbol ge symb with + | None => None + | Some b' => Mem.store Mint32 m b p (Vptr b' ofs) + end + | Init_space n => Some m + end. + +Fixpoint store_init_data_list (m: mem) (b: block) (p: Z) (idl: list init_data) + {struct idl}: option mem := + match idl with + | nil => Some m + | id :: idl' => + match store_init_data m b p id with + | None => None + | Some m' => store_init_data_list m' b (p + init_data_size id) idl' + end + end. + +Fixpoint init_data_list_size (il: list init_data) {struct il} : Z := + match il with + | nil => 0 + | i :: il' => init_data_size i + init_data_list_size il' + end. + +Definition alloc_variable (m: mem) (idv: ident * list init_data * V) : option mem := + let (m', b) := Mem.alloc m 0 (init_data_list_size idv#1#2) in + store_init_data_list m' b 0 idv#1#2. + +Fixpoint alloc_variables (m: mem) (vl: list (ident * list init_data * V)) + {struct vl} : option mem := + match vl with + | nil => Some m + | v :: vl' => + match alloc_variable m v with + | None => None + | Some m' => alloc_variables m' vl' + end + end. + +Remark store_init_data_list_nextblock: + forall idl b m p m', + store_init_data_list m b p idl = Some m' -> + Mem.nextblock m' = Mem.nextblock m. +Proof. + induction idl; simpl; intros until m'. + intros. congruence. + caseEq (store_init_data m b p a); try congruence. intros. + transitivity (Mem.nextblock m0). eauto. + destruct a; simpl in H; try (eapply Mem.nextblock_store; eauto; fail). + congruence. + destruct (find_symbol ge i); try congruence. eapply Mem.nextblock_store; eauto. +Qed. + +Remark alloc_variables_nextblock: + forall vl m m', + alloc_variables m vl = Some m' -> + Mem.nextblock m' = Mem.nextblock m + Z_of_nat(List.length vl). +Proof. + induction vl. + simpl; intros. inv H; unfold block; omega. + simpl length; rewrite inj_S; simpl. intros m m'. + unfold alloc_variable. + caseEq (Mem.alloc m 0 (init_data_list_size (a#1)#2)). intros m1 b ALLOC. + caseEq (store_init_data_list m1 b 0 a#1#2); try congruence. intros m2 STORE REC. + rewrite (IHvl _ _ REC). + rewrite (store_init_data_list_nextblock _ _ _ _ STORE). + rewrite (Mem.nextblock_alloc _ _ _ _ _ ALLOC). + unfold block in *; omega. +Qed. + +Remark store_init_data_list_perm: + forall prm b' q idl b m p m', + store_init_data_list m b p idl = Some m' -> + Mem.perm m b' q prm -> Mem.perm m' b' q prm. +Proof. + induction idl; simpl; intros until m'. + intros. congruence. + caseEq (store_init_data m b p a); try congruence. intros. + eapply IHidl; eauto. + destruct a; simpl in H; eauto with mem. + congruence. + destruct (find_symbol ge i); try congruence. eauto with mem. +Qed. + +Remark alloc_variables_perm: + forall prm b' q vl m m', + alloc_variables m vl = Some m' -> + Mem.perm m b' q prm -> Mem.perm m' b' q prm. +Proof. + induction vl. + simpl; intros. congruence. + intros until m'. simpl. unfold alloc_variable. + caseEq (Mem.alloc m 0 (init_data_list_size (a#1)#2)). intros m1 b ALLOC. + caseEq (store_init_data_list m1 b 0 a#1#2); try congruence. intros m2 STORE REC PERM. + eapply IHvl; eauto. + eapply store_init_data_list_perm; eauto. + eauto with mem. +Qed. + +Remark store_init_data_list_outside: + forall b il m p m', + store_init_data_list m b p il = Some m' -> + forall chunk b' q, + b' <> b \/ q + size_chunk chunk <= p -> + Mem.load chunk m' b' q = Mem.load chunk m b' q. +Proof. + induction il; simpl. + intros; congruence. + intros until m'. caseEq (store_init_data m b p a); try congruence. + intros m1 A B chunk b' q C. transitivity (Mem.load chunk m1 b' q). + eapply IHil; eauto. generalize (init_data_size_pos a). intuition omega. + destruct a; simpl in A; + try (eapply Mem.load_store_other; eauto; intuition; fail). + congruence. + destruct (find_symbol ge i); try congruence. + eapply Mem.load_store_other; eauto; intuition. +Qed. + +(* +Remark alloc_variables_nextblock: + forall vl g m m', + alloc_variables m vl = Some m' -> + Mem.nextblock m = genv_nextvar g -> + Mem.nextblock m' = genv_nextvar (add_variables g vl). +Proof. + induction vl; simpl; intros until m'. + intros. congruence. + unfold alloc_variable. + caseEq (Mem.alloc m 0 (init_data_list_size (a#1)#2)). intros m1 b ALLOC. + caseEq (store_init_data_list m1 b 0 a#1#2); try congruence. intros m2 STORE REC EQ. + eapply IHvl; eauto. + rewrite (store_init_data_list_nextblock _ _ _ _ STORE). + rewrite (Mem.nextblock_alloc _ _ _ _ _ ALLOC). + simpl. unfold block in *; omega. +Qed. +*) +Fixpoint load_store_init_data (m: mem) (b: block) (p: Z) (il: list init_data) {struct il} : Prop := + match il with + | nil => True + | Init_int8 n :: il' => + Mem.load Mint8unsigned m b p = Some(Vint(Int.zero_ext 8 n)) + /\ load_store_init_data m b (p + 1) il' + | Init_int16 n :: il' => + Mem.load Mint16unsigned m b p = Some(Vint(Int.zero_ext 16 n)) + /\ load_store_init_data m b (p + 2) il' + | Init_int32 n :: il' => + Mem.load Mint32 m b p = Some(Vint n) + /\ load_store_init_data m b (p + 4) il' + | Init_float32 n :: il' => + Mem.load Mfloat32 m b p = Some(Vfloat(Float.singleoffloat n)) + /\ load_store_init_data m b (p + 4) il' + | Init_float64 n :: il' => + Mem.load Mfloat64 m b p = Some(Vfloat n) + /\ load_store_init_data m b (p + 8) il' + | Init_addrof symb ofs :: il' => + (exists b', find_symbol ge symb = Some b' /\ Mem.load Mint32 m b p = Some(Vptr b' ofs)) + /\ load_store_init_data m b (p + 4) il' + | Init_space n :: il' => + load_store_init_data m b (p + Zmax n 0) il' + end. + +Lemma store_init_data_list_charact: + forall b il m p m', + store_init_data_list m b p il = Some m' -> + load_store_init_data m' b p il. +Proof. + assert (A: forall chunk v m b p m1 il m', + Mem.store chunk m b p v = Some m1 -> + store_init_data_list m1 b (p + size_chunk chunk) il = Some m' -> + Val.has_type v (type_of_chunk chunk) -> + Mem.load chunk m' b p = Some(Val.load_result chunk v)). + intros. transitivity (Mem.load chunk m1 b p). + eapply store_init_data_list_outside; eauto. right. omega. + eapply Mem.load_store_same; eauto. + + induction il; simpl. + auto. + intros until m'. caseEq (store_init_data m b p a); try congruence. + intros m1 B C. + exploit IHil; eauto. intro D. + destruct a; simpl in B; intuition. + eapply (A Mint8unsigned (Vint i)); eauto. simpl; auto. + eapply (A Mint16unsigned (Vint i)); eauto. simpl; auto. + eapply (A Mint32 (Vint i)); eauto. simpl; auto. + eapply (A Mfloat32 (Vfloat f)); eauto. simpl; auto. + eapply (A Mfloat64 (Vfloat f)); eauto. simpl; auto. + destruct (find_symbol ge i); try congruence. exists b0; split; auto. + eapply (A Mint32 (Vptr b0 i0)); eauto. simpl; auto. +Qed. + +Remark load_alloc_variables: + forall chunk b p vl m m', + alloc_variables m vl = Some m' -> + Mem.valid_block m b -> + Mem.load chunk m' b p = Mem.load chunk m b p. +Proof. + induction vl; simpl; intros until m'. + congruence. + unfold alloc_variable. + caseEq (Mem.alloc m 0 (init_data_list_size a#1#2)); intros m1 b1 ALLOC. + caseEq (store_init_data_list m1 b1 0 a#1#2); try congruence. intros m2 STO REC VAL. + transitivity (Mem.load chunk m2 b p). + apply IHvl; auto. red. rewrite (store_init_data_list_nextblock _ _ _ _ STO). + change (Mem.valid_block m1 b). eauto with mem. + transitivity (Mem.load chunk m1 b p). + eapply store_init_data_list_outside; eauto. left. + apply Mem.valid_not_valid_diff with m; eauto with mem. + eapply Mem.load_alloc_unchanged; eauto. +Qed. + +Remark load_store_init_data_invariant: + forall m m' b, + (forall chunk ofs, Mem.load chunk m' b ofs = Mem.load chunk m b ofs) -> + forall il p, + load_store_init_data m b p il -> load_store_init_data m' b p il. +Proof. + induction il; intro p; simpl. + auto. + repeat rewrite H. destruct a; intuition. +Qed. + +Lemma alloc_variables_charact: + forall id init v vl g m m', + genv_nextvar g = Mem.nextblock m -> + alloc_variables m vl = Some m' -> + list_norepet (map (fun v => v#1#1) vl) -> + In (id, init, v) vl -> + exists b, find_symbol (add_variables g vl) id = Some b + /\ find_var_info (add_variables g vl) b = Some v + /\ Mem.range_perm m' b 0 (init_data_list_size init) Writable + /\ load_store_init_data m' b 0 init. +Proof. + induction vl; simpl. + contradiction. + intros until m'; intro NEXT. + unfold alloc_variable. destruct a as [[id' init'] v']. simpl. + caseEq (Mem.alloc m 0 (init_data_list_size init')); try congruence. + intros m1 b ALLOC. + caseEq (store_init_data_list m1 b 0 init'); try congruence. + intros m2 STORE REC NOREPET IN. inv NOREPET. + exploit Mem.alloc_result; eauto. intro BEQ. + destruct IN. inv H. + exists (Mem.nextblock m); split. + rewrite add_variables_same_symb; auto. unfold find_symbol; simpl. + rewrite PTree.gss. congruence. + split. rewrite add_variables_same_address. unfold find_var_info; simpl. + rewrite NEXT. apply ZMap.gss. + simpl. rewrite <- NEXT; omega. + split. red; intros. eapply alloc_variables_perm; eauto. + eapply store_init_data_list_perm; eauto. + apply Mem.perm_implies with Freeable; eauto with mem. + apply load_store_init_data_invariant with m2. + intros. eapply load_alloc_variables; eauto. + red. rewrite (store_init_data_list_nextblock _ _ _ _ STORE). + change (Mem.valid_block m1 (Mem.nextblock m)). eauto with mem. + eapply store_init_data_list_charact; eauto. + + apply IHvl with m2; auto. + simpl. rewrite (store_init_data_list_nextblock _ _ _ _ STORE). + rewrite (Mem.nextblock_alloc _ _ _ _ _ ALLOC). unfold block in *; omega. +Qed. + +End INITMEM. + +Definition init_mem (p: program F V) := + alloc_variables (globalenv p) Mem.empty p.(prog_vars). + +Theorem find_symbol_not_fresh: + forall p id b m, + init_mem p = Some m -> + find_symbol (globalenv p) id = Some b -> Mem.valid_block m b. +Proof. + unfold init_mem; intros. + exploit alloc_variables_nextblock; eauto. rewrite Mem.nextblock_empty. intro. + exploit genv_symb_range; eauto. intros. + generalize (add_variables_nextvar (prog_vars p) (add_functions empty_genv (prog_funct p))). + rewrite add_functions_nextvar. simpl genv_nextvar. intro. + red. rewrite H1. rewrite <- H3. intuition. +Qed. + +Theorem find_var_exists: + forall p id init v m, + list_norepet (prog_var_names p) -> + In (id, init, v) (prog_vars p) -> + init_mem p = Some m -> + exists b, find_symbol (globalenv p) id = Some b + /\ find_var_info (globalenv p) b = Some v + /\ Mem.range_perm m b 0 (init_data_list_size init) Writable + /\ load_store_init_data (globalenv p) m b 0 init. +Proof. + intros. exploit alloc_variables_charact; eauto. + instantiate (1 := Mem.empty). rewrite add_functions_nextvar. rewrite Mem.nextblock_empty; auto. + assumption. +Qed. + +(** ** Compatibility with memory injections *) + +Section INITMEM_INJ. + +Variable ge: t. +Variable thr: block. +Hypothesis symb_inject: forall id b, find_symbol ge id = Some b -> b < thr. + +Lemma store_init_data_neutral: + forall m b p id m', + Mem.inject_neutral thr m -> + b < thr -> + store_init_data ge m b p id = Some m' -> + Mem.inject_neutral thr m'. +Proof. intros. - assert (forall fns, - find_symbol (add_functs empty fns) id1 = Some b1 -> - find_symbol (add_functs empty fns) id2 = Some b2 -> - b1 <> b2). - unfold find_symbol. induction fns; simpl; intros. - rewrite PTree.gempty in H2. discriminate. - destruct a as [id f]; simpl in *. - rewrite PTree.gsspec in H2. - destruct (peq id1 id). subst id. inv H2. - rewrite PTree.gso in H3; auto. - generalize (find_symbol_above_nextfunction _ _ H3). unfold block. omega. - rewrite PTree.gsspec in H3. - destruct (peq id2 id). subst id. inv H3. - generalize (find_symbol_above_nextfunction _ _ H2). unfold block. omega. - eauto. - set (ge0 := add_functs empty p.(prog_funct)). - assert (forall (vars: list (ident * list init_data * V)) ge m, - add_globals (ge0, Mem.empty) vars = (ge, m) -> - find_symbol ge id1 = Some b1 -> - find_symbol ge id2 = Some b2 -> - b1 <> b2). - unfold find_symbol. induction vars; simpl. - intros. inv H3. subst ge. apply H2 with (p.(prog_funct)); auto. - intros ge m. destruct a as [[id init] info]. - caseEq (add_globals (ge0, Mem.empty) vars). intros ge1 m1 A B. inv B. - unfold add_symbol. simpl. intros. - rewrite PTree.gsspec in H3; destruct (peq id1 id). subst id. inv H3. - rewrite PTree.gso in H4; auto. - generalize (find_symbol_add_symbols_not_fresh _ _ _ A H4). unfold block; omega. - rewrite PTree.gsspec in H4; destruct (peq id2 id). subst id. inv H4. - generalize (find_symbol_add_symbols_not_fresh _ _ _ A H3). unfold block; omega. + destruct id; simpl in H1; try (eapply Mem.store_inject_neutral; eauto; fail). + inv H1; auto. + revert H1. caseEq (find_symbol ge i); try congruence. intros b' FS ST. + eapply Mem.store_inject_neutral; eauto. + econstructor. unfold Mem.flat_inj. apply zlt_true; eauto. + rewrite Int.add_zero. auto. +Qed. + +Lemma store_init_data_list_neutral: + forall b idl m p m', + Mem.inject_neutral thr m -> + b < thr -> + store_init_data_list ge m b p idl = Some m' -> + Mem.inject_neutral thr m'. +Proof. + induction idl; simpl. + intros; congruence. + intros until m'; intros INJ FB. + caseEq (store_init_data ge m b p a); try congruence. intros. + eapply IHidl. eapply store_init_data_neutral; eauto. auto. eauto. +Qed. + +Lemma alloc_variable_neutral: + forall id m m', + alloc_variable ge m id = Some m' -> + Mem.inject_neutral thr m -> + Mem.nextblock m < thr -> + Mem.inject_neutral thr m'. +Proof. + intros until m'. unfold alloc_variable. + caseEq (Mem.alloc m 0 (init_data_list_size (id#1)#2)); intros m1 b; intros. + eapply store_init_data_list_neutral with (b := b). + eapply Mem.alloc_inject_neutral; eauto. + rewrite (Mem.alloc_result _ _ _ _ _ H). auto. eauto. - set (ge_m := add_globals (ge0, Mem.empty) p.(prog_vars)). - apply H3 with (p.(prog_vars)) (fst ge_m) (snd ge_m). - fold ge_m. apply surjective_pairing. auto. auto. +Qed. + +Lemma alloc_variables_neutral: + forall idl m m', + alloc_variables ge m idl = Some m' -> + Mem.inject_neutral thr m -> + Mem.nextblock m' <= thr -> + Mem.inject_neutral thr m'. +Proof. + induction idl; simpl. + intros. congruence. + intros until m'. caseEq (alloc_variable ge m a); try congruence. intros. + assert (Mem.nextblock m' = Mem.nextblock m + Z_of_nat(length (a :: idl))). + eapply alloc_variables_nextblock with ge. simpl. rewrite H. auto. + simpl length in H3. rewrite inj_S in H3. + exploit alloc_variable_neutral; eauto. unfold block in *; omega. +Qed. + +End INITMEM_INJ. + +Theorem initmem_inject: + forall p m, + init_mem p = Some m -> + Mem.inject (Mem.flat_inj (Mem.nextblock m)) m m. +Proof. + unfold init_mem; intros. + apply Mem.neutral_inject. + eapply alloc_variables_neutral; eauto. + intros. exploit find_symbol_not_fresh; eauto. + apply Mem.empty_inject_neutral. + omega. Qed. End GENV. -(* Global environments and program transformations. *) +(** * Commutation with program transformations *) -Section MATCH_PROGRAM. +(** ** Commutation with matching between programs. *) -Variable A B V W: Type. +Section MATCH_PROGRAMS. + +Variables A B V W: Type. Variable match_fun: A -> B -> Prop. Variable match_var: V -> W -> Prop. -Variable p: program A V. -Variable p': program B W. -Hypothesis match_prog: - match_program match_fun match_var p p'. - -Lemma add_functs_match: - forall (fns: list (ident * A)) (tfns: list (ident * B)), - list_forall2 (match_funct_entry match_fun) fns tfns -> - let r := add_functs (empty A) fns in - let tr := add_functs (empty B) tfns in - nextfunction tr = nextfunction r /\ - symbols tr = symbols r /\ - forall (b: block) (f: A), - ZMap.get b (functions r) = Some f -> - exists tf, ZMap.get b (functions tr) = Some tf /\ match_fun f tf. -Proof. - induction 1; simpl. - - split. reflexivity. split. reflexivity. - intros b f; repeat (rewrite ZMap.gi). intros; discriminate. - - destruct a1 as [id1 fn1]. destruct b1 as [id2 fn2]. - simpl. red in H. destruct H. - destruct IHlist_forall2 as [X [Y Z]]. - rewrite X. rewrite Y. - split. auto. - split. congruence. - intros b f. - repeat (rewrite ZMap.gsspec). - destruct (ZIndexed.eq b (nextfunction (add_functs (empty A) al))). - intro EQ; inv EQ. exists fn2; auto. + +Record match_genvs (ge1: t A V) (ge2: t B W): Prop := { + mge_nextfun: genv_nextfun ge1 = genv_nextfun ge2; + mge_nextvar: genv_nextvar ge1 = genv_nextvar ge2; + mge_symb: genv_symb ge1 = genv_symb ge2; + mge_funs: + forall b f, ZMap.get b (genv_funs ge1) = Some f -> + exists tf, ZMap.get b (genv_funs ge2) = Some tf /\ match_fun f tf; + mge_rev_funs: + forall b tf, ZMap.get b (genv_funs ge2) = Some tf -> + exists f, ZMap.get b (genv_funs ge1) = Some f /\ match_fun f tf; + mge_vars: + forall b v, ZMap.get b (genv_vars ge1) = Some v -> + exists tv, ZMap.get b (genv_vars ge2) = Some tv /\ match_var v tv; + mge_rev_vars: + forall b tv, ZMap.get b (genv_vars ge2) = Some tv -> + exists v, ZMap.get b (genv_vars ge1) = Some v /\ match_var v tv +}. + +Lemma add_function_match: + forall ge1 ge2 id f1 f2, + match_genvs ge1 ge2 -> + match_fun f1 f2 -> + match_genvs (add_function ge1 (id, f1)) (add_function ge2 (id, f2)). +Proof. + intros. destruct H. constructor; simpl. + congruence. congruence. congruence. + rewrite mge_nextfun0. intros. rewrite ZMap.gsspec in H. rewrite ZMap.gsspec. + destruct (ZIndexed.eq b (genv_nextfun ge2)). + exists f2; split; congruence. + eauto. + rewrite mge_nextfun0. intros. rewrite ZMap.gsspec in H. rewrite ZMap.gsspec. + destruct (ZIndexed.eq b (genv_nextfun ge2)). + exists f1; split; congruence. + eauto. + auto. auto. Qed. -Lemma add_functs_rev_match: - forall (fns: list (ident * A)) (tfns: list (ident * B)), - list_forall2 (match_funct_entry match_fun) fns tfns -> - let r := add_functs (empty A) fns in - let tr := add_functs (empty B) tfns in - nextfunction tr = nextfunction r /\ - symbols tr = symbols r /\ - forall (b: block) (tf: B), - ZMap.get b (functions tr) = Some tf -> - exists f, ZMap.get b (functions r) = Some f /\ match_fun f tf. -Proof. - induction 1; simpl. - - split. reflexivity. split. reflexivity. - intros b f; repeat (rewrite ZMap.gi). intros; discriminate. - - destruct a1 as [id1 fn1]. destruct b1 as [id2 fn2]. - simpl. red in H. destruct H. - destruct IHlist_forall2 as [X [Y Z]]. - rewrite X. rewrite Y. - split. auto. - split. congruence. - intros b f. - repeat (rewrite ZMap.gsspec). - destruct (ZIndexed.eq b (nextfunction (add_functs (empty A) al))). - intro EQ; inv EQ. exists fn1; auto. +Lemma add_functions_match: + forall fl1 fl2, list_forall2 (match_funct_entry match_fun) fl1 fl2 -> + forall ge1 ge2, match_genvs ge1 ge2 -> + match_genvs (add_functions ge1 fl1) (add_functions ge2 fl2). +Proof. + induction 1; intros; simpl. auto. + destruct a1 as [id1 f1]; destruct b1 as [id2 f2]. + destruct H. subst. apply IHlist_forall2. apply add_function_match; auto. Qed. -Lemma mem_add_globals_match: - forall (g1: genv A) (g2: genv B) (m: mem) - (vars: list (ident * list init_data * V)) - (tvars: list (ident * list init_data * W)), - list_forall2 (match_var_entry match_var) vars tvars -> - snd (add_globals (g1, m) vars) = snd (add_globals (g2, m) tvars). +Lemma add_variable_match: + forall ge1 ge2 id idl v1 v2, + match_genvs ge1 ge2 -> + match_var v1 v2 -> + match_genvs (add_variable ge1 (id, idl, v1)) (add_variable ge2 (id, idl, v2)). Proof. - induction 1; simpl. + intros. destruct H. constructor; simpl. + congruence. congruence. congruence. auto. - destruct a1 as [[id1 init1] info1]. - destruct b1 as [[id2 init2] info2]. - red in H. destruct H as [X [Y Z]]. subst id2 init2. - generalize IHlist_forall2. - destruct (add_globals (g1, m) al). - destruct (add_globals (g2, m) bl). - simpl. intro. subst m1. auto. -Qed. - -Lemma symbols_add_globals_match: - forall (g1: genv A) (g2: genv B) (m: mem), - symbols g1 = symbols g2 -> - forall (vars: list (ident * list init_data * V)) - (tvars: list (ident * list init_data * W)), - list_forall2 (match_var_entry match_var) vars tvars -> - symbols (fst (add_globals (g1, m) vars)) = - symbols (fst (add_globals (g2, m) tvars)). -Proof. - induction 2; simpl. auto. - destruct a1 as [[id1 init1] info1]. - destruct b1 as [[id2 init2] info2]. - red in H0. destruct H0 as [X [Y Z]]. subst id2 init2. - generalize IHlist_forall2. - generalize (mem_add_globals_match g1 g2 m H1). - destruct (add_globals (g1, m) al). - destruct (add_globals (g2, m) bl). - simpl. intros. congruence. + rewrite mge_nextvar0. intros. rewrite ZMap.gsspec in H. rewrite ZMap.gsspec. + destruct (ZIndexed.eq b (genv_nextvar ge2)). + exists v2; split; congruence. + eauto. + rewrite mge_nextvar0. intros. rewrite ZMap.gsspec in H. rewrite ZMap.gsspec. + destruct (ZIndexed.eq b (genv_nextvar ge2)). + exists v1; split; congruence. + eauto. Qed. -Theorem find_funct_ptr_match: - forall (b: block) (f: A), - find_funct_ptr (globalenv p) b = Some f -> - exists tf, find_funct_ptr (globalenv p') b = Some tf /\ match_fun f tf. +Lemma add_variables_match: + forall vl1 vl2, list_forall2 (match_var_entry match_var) vl1 vl2 -> + forall ge1 ge2, match_genvs ge1 ge2 -> + match_genvs (add_variables ge1 vl1) (add_variables ge2 vl2). Proof. - intros until f. destruct match_prog as [X [Y Z]]. - destruct (add_functs_match X) as [P [Q R]]. - unfold find_funct_ptr. repeat rewrite functions_globalenv. + induction 1; intros; simpl. auto. + destruct a1 as [[id1 init1] f1]; destruct b1 as [[id2 init2] f2]. + destruct H. destruct H2. subst. apply IHlist_forall2. apply add_variable_match; auto. Qed. -Theorem find_funct_ptr_rev_match: - forall (b: block) (tf: B), - find_funct_ptr (globalenv p') b = Some tf -> - exists f, find_funct_ptr (globalenv p) b = Some f /\ match_fun f tf. +Variable p: program A V. +Variable p': program B W. +Hypothesis progmatch: match_program match_fun match_var p p'. + +Lemma globalenvs_match: + match_genvs (globalenv p) (globalenv p'). Proof. - intros until tf. destruct match_prog as [X [Y Z]]. - destruct (add_functs_rev_match X) as [P [Q R]]. - unfold find_funct_ptr. repeat rewrite functions_globalenv. - auto. + unfold globalenv. destruct progmatch. destruct H0. + apply add_variables_match; auto. apply add_functions_match; auto. + constructor; simpl; auto; intros; rewrite ZMap.gi in H2; congruence. Qed. +Theorem find_funct_ptr_match: + forall (b : block) (f : A), + find_funct_ptr (globalenv p) b = Some f -> + exists tf : B, + find_funct_ptr (globalenv p') b = Some tf /\ match_fun f tf. +Proof (mge_funs globalenvs_match). + +Theorem find_funct_ptr_rev_match: + forall (b : block) (tf : B), + find_funct_ptr (globalenv p') b = Some tf -> + exists f : A, + find_funct_ptr (globalenv p) b = Some f /\ match_fun f tf. +Proof (mge_rev_funs globalenvs_match). + Theorem find_funct_match: - forall (v: val) (f: A), + forall (v : val) (f : A), find_funct (globalenv p) v = Some f -> - exists tf, find_funct (globalenv p') v = Some tf /\ match_fun f tf. + exists tf : B, find_funct (globalenv p') v = Some tf /\ match_fun f tf. Proof. - intros until f. unfold find_funct. - case v; try (intros; discriminate). - intros b ofs. - case (Int.eq ofs Int.zero); try (intros; discriminate). - apply find_funct_ptr_match. + intros. exploit find_funct_inv; eauto. intros [b EQ]. subst v. + rewrite find_funct_find_funct_ptr in H. + rewrite find_funct_find_funct_ptr. + apply find_funct_ptr_match. auto. Qed. Theorem find_funct_rev_match: - forall (v: val) (tf: B), + forall (v : val) (tf : B), find_funct (globalenv p') v = Some tf -> - exists f, find_funct (globalenv p) v = Some f /\ match_fun f tf. + exists f : A, find_funct (globalenv p) v = Some f /\ match_fun f tf. Proof. - intros until tf. unfold find_funct. - case v; try (intros; discriminate). - intros b ofs. - case (Int.eq ofs Int.zero); try (intros; discriminate). - apply find_funct_ptr_rev_match. + intros. exploit find_funct_inv; eauto. intros [b EQ]. subst v. + rewrite find_funct_find_funct_ptr in H. + rewrite find_funct_find_funct_ptr. + apply find_funct_ptr_rev_match. auto. Qed. -Lemma symbols_init_match: - symbols (globalenv p') = symbols (globalenv p). -Proof. - unfold globalenv. unfold globalenv_initmem. - destruct match_prog as [X [Y Z]]. - destruct (add_functs_match X) as [P [Q R]]. - simpl. symmetry. apply symbols_add_globals_match. auto. auto. -Qed. +Theorem find_var_info_match: + forall (b : block) (v : V), + find_var_info (globalenv p) b = Some v -> + exists tv, + find_var_info (globalenv p') b = Some tv /\ match_var v tv. +Proof (mge_vars globalenvs_match). + +Theorem find_var_info_rev_match: + forall (b : block) (tv : W), + find_var_info (globalenv p') b = Some tv -> + exists v, + find_var_info (globalenv p) b = Some v /\ match_var v tv. +Proof (mge_rev_vars globalenvs_match). Theorem find_symbol_match: - forall (s: ident), + forall (s : ident), find_symbol (globalenv p') s = find_symbol (globalenv p) s. Proof. - intros. unfold find_symbol. - rewrite symbols_init_match. auto. + intros. destruct globalenvs_match. unfold find_symbol. congruence. +Qed. + +Lemma store_init_data_list_match: + forall idl m b ofs, + store_init_data_list (globalenv p') m b ofs idl = + store_init_data_list (globalenv p) m b ofs idl. +Proof. + induction idl; simpl; intros. + auto. + assert (store_init_data (globalenv p') m b ofs a = + store_init_data (globalenv p) m b ofs a). + destruct a; simpl; auto. rewrite find_symbol_match. auto. + rewrite H. destruct (store_init_data (globalenv p) m b ofs a); auto. +Qed. + +Lemma alloc_variables_match: + forall vl1 vl2, list_forall2 (match_var_entry match_var) vl1 vl2 -> + forall m, + alloc_variables (globalenv p') m vl2 = alloc_variables (globalenv p) m vl1. +Proof. + induction 1; intros; simpl. + auto. + destruct a1 as [[id1 init1] v1]; destruct b1 as [[id2 init2] v2]. + destruct H. destruct H1. subst. + unfold alloc_variable; simpl. + destruct (Mem.alloc m 0 (init_data_list_size init2)). + rewrite store_init_data_list_match. + destruct (store_init_data_list (globalenv p) m0 b 0 init2); auto. Qed. Theorem init_mem_match: - init_mem p' = init_mem p. + forall m, init_mem p = Some m -> init_mem p' = Some m. Proof. - unfold init_mem. unfold globalenv_initmem. - destruct match_prog as [X [Y Z]]. - symmetry. apply mem_add_globals_match. auto. + intros. rewrite <- H. unfold init_mem. destruct progmatch. destruct H1. + apply alloc_variables_match; auto. Qed. -End MATCH_PROGRAM. +End MATCH_PROGRAMS. Section TRANSF_PROGRAM_PARTIAL2. @@ -1007,6 +1136,28 @@ Proof. exploit find_funct_rev_match. eexact prog_match. eauto. auto. Qed. +Theorem find_var_info_transf_partial2: + forall (b: block) (v: V), + find_var_info (globalenv p) b = Some v -> + exists v', + find_var_info (globalenv p') b = Some v' /\ transf_var v = OK v'. +Proof. + intros. + exploit find_var_info_match. eexact prog_match. eauto. + intros [tv [X Y]]. exists tv; auto. +Qed. + +Theorem find_var_info_rev_transf_partial2: + forall (b: block) (v': W), + find_var_info (globalenv p') b = Some v' -> + exists v, + find_var_info (globalenv p) b = Some v /\ transf_var v = OK v'. +Proof. + intros. + exploit find_var_info_rev_match. eexact prog_match. eauto. + intros [v [X Y]]. exists v; auto. +Qed. + Theorem find_symbol_transf_partial2: forall (s: ident), find_symbol (globalenv p') s = find_symbol (globalenv p) s. @@ -1015,9 +1166,9 @@ Proof. Qed. Theorem init_mem_transf_partial2: - init_mem p' = init_mem p. + forall m, init_mem p = Some m -> init_mem p' = Some m. Proof. - intros. eapply init_mem_match. eexact prog_match. + intros. eapply init_mem_match. eexact prog_match. auto. Qed. End TRANSF_PROGRAM_PARTIAL2. @@ -1080,7 +1231,7 @@ Proof. Qed. Theorem init_mem_transf_partial: - init_mem p' = init_mem p. + forall m, init_mem p = Some m -> init_mem p' = Some m. Proof. exact (@init_mem_transf_partial2 _ _ _ _ _ _ _ _ transf2_OK). Qed. @@ -1147,7 +1298,7 @@ Proof. Qed. Theorem init_mem_transf: - init_mem tp = init_mem p. + forall m, init_mem p = Some m -> init_mem tp = Some m. Proof. exact (@init_mem_transf_partial _ _ _ _ _ _ transf_OK). Qed. diff --git a/common/Mem.v b/common/Mem.v deleted file mode 100644 index 252ee29..0000000 --- a/common/Mem.v +++ /dev/null @@ -1,2887 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* Sandrine Blazy, ENSIIE and INRIA Paris-Rocquencourt *) -(* *) -(* 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 file develops the memory model that is used in the dynamic - semantics of all the languages used in the compiler. - It defines a type [mem] of memory states, the following 4 basic - operations over memory states, and their properties: -- [load]: read a memory chunk at a given address; -- [store]: store a memory chunk at a given address; -- [alloc]: allocate a fresh memory block; -- [free]: invalidate a memory block. -*) - -Require Import Coqlib. -Require Import Maps. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Values. - -Definition update (A: Type) (x: Z) (v: A) (f: Z -> A) : Z -> A := - fun y => if zeq y x then v else f y. - -Implicit Arguments update [A]. - -Lemma update_s: - forall (A: Type) (x: Z) (v: A) (f: Z -> A), - update x v f x = v. -Proof. - intros; unfold update. apply zeq_true. -Qed. - -Lemma update_o: - forall (A: Type) (x: Z) (v: A) (f: Z -> A) (y: Z), - x <> y -> update x v f y = f y. -Proof. - intros; unfold update. apply zeq_false; auto. -Qed. - -(** * Structure of memory states *) - -(** A memory state is organized in several disjoint blocks. Each block - has a low and a high bound that defines its size. Each block map - byte offsets to the contents of this byte. *) - -(** The possible contents of a byte-sized memory cell. To give intuitions, - a 4-byte value [v] stored at offset [d] will be represented by - the content [Datum(4, v)] at offset [d] and [Cont] at offsets [d+1], - [d+2] and [d+3]. The [Cont] contents enable detecting future writes - that would partially overlap the 4-byte value. *) - -Inductive content : Type := - | Undef: content (**r undefined contents *) - | Datum: nat -> val -> content (**r first byte of a value *) - | Cont: content. (**r continuation bytes for a multi-byte value *) - -Definition contentmap : Type := Z -> content. - -(** A memory block comprises the dimensions of the block (low and high bounds) - plus a mapping from byte offsets to contents. *) - -Record block_contents : Type := mkblock { - low: Z; - high: Z; - contents: contentmap -}. - -(** A memory state is a mapping from block addresses (represented by [Z] - integers) to blocks. We also maintain the address of the next - unallocated block, and a proof that this address is positive. *) - -Record mem : Type := mkmem { - blocks: Z -> block_contents; - nextblock: block; - nextblock_pos: nextblock > 0 -}. - -(** * Operations on memory stores *) - -(** Memory reads and writes are performed by quantities called memory chunks, - encoding the type, size and signedness of the chunk being addressed. - The following functions extract the size information from a chunk. *) - -Definition size_chunk (chunk: memory_chunk) : Z := - match chunk with - | Mint8signed => 1 - | Mint8unsigned => 1 - | Mint16signed => 2 - | Mint16unsigned => 2 - | Mint32 => 4 - | Mfloat32 => 4 - | Mfloat64 => 8 - end. - -Definition pred_size_chunk (chunk: memory_chunk) : nat := - match chunk with - | Mint8signed => 0%nat - | Mint8unsigned => 0%nat - | Mint16signed => 1%nat - | Mint16unsigned => 1%nat - | Mint32 => 3%nat - | Mfloat32 => 3%nat - | Mfloat64 => 7%nat - end. - -Lemma size_chunk_pred: - forall chunk, size_chunk chunk = 1 + Z_of_nat (pred_size_chunk chunk). -Proof. - destruct chunk; auto. -Qed. - -Lemma size_chunk_pos: - forall chunk, size_chunk chunk > 0. -Proof. - intros. rewrite size_chunk_pred. omega. -Qed. - -(** Memory reads and writes must respect alignment constraints: - the byte offset of the location being addressed should be an exact - multiple of the natural alignment for the chunk being addressed. - This natural alignment is defined by the following - [align_chunk] function. Some target architectures - (e.g. the PowerPC) have no alignment constraints, which we could - reflect by taking [align_chunk chunk = 1]. However, other architectures - have stronger alignment requirements. The following definition is - appropriate for PowerPC and ARM. *) - -Definition align_chunk (chunk: memory_chunk) : Z := - match chunk with - | Mint8signed => 1 - | Mint8unsigned => 1 - | Mint16signed => 2 - | Mint16unsigned => 2 - | _ => 4 - end. - -Lemma align_chunk_pos: - forall chunk, align_chunk chunk > 0. -Proof. - intro. destruct chunk; simpl; omega. -Qed. - -Lemma align_size_chunk_divides: - forall chunk, (align_chunk chunk | size_chunk chunk). -Proof. - intros. destruct chunk; simpl; try apply Zdivide_refl. exists 2; auto. -Qed. - -Lemma align_chunk_compat: - forall chunk1 chunk2, - size_chunk chunk1 = size_chunk chunk2 -> align_chunk chunk1 = align_chunk chunk2. -Proof. - intros chunk1 chunk2. - destruct chunk1; destruct chunk2; simpl; congruence. -Qed. - -(** The initial store. *) - -Remark one_pos: 1 > 0. -Proof. omega. Qed. - -Definition empty_block (lo hi: Z) : block_contents := - mkblock lo hi (fun y => Undef). - -Definition empty: mem := - mkmem (fun x => empty_block 0 0) 1 one_pos. - -Definition nullptr: block := 0. - -(** Allocation of a fresh block with the given bounds. Return an updated - memory state and the address of the fresh block, which initially contains - undefined cells. Note that allocation never fails: we model an - infinite memory. *) - -Remark succ_nextblock_pos: - forall m, Zsucc m.(nextblock) > 0. -Proof. intro. generalize (nextblock_pos m). omega. Qed. - -Definition alloc (m: mem) (lo hi: Z) := - (mkmem (update m.(nextblock) - (empty_block lo hi) - m.(blocks)) - (Zsucc m.(nextblock)) - (succ_nextblock_pos m), - m.(nextblock)). - -(** Freeing a block. Return the updated memory state where the given - block address has been invalidated: future reads and writes to this - address will fail. Note that we make no attempt to return the block - to an allocation pool: the given block address will never be allocated - later. *) - -Definition free (m: mem) (b: block) := - mkmem (update b - (empty_block 0 0) - m.(blocks)) - m.(nextblock) - m.(nextblock_pos). - -(** Freeing of a list of blocks. *) - -Definition free_list (m:mem) (l:list block) := - List.fold_right (fun b m => free m b) m l. - -(** Return the low and high bounds for the given block address. - Those bounds are 0 for freed or not yet allocated address. *) - -Definition low_bound (m: mem) (b: block) := - low (m.(blocks) b). -Definition high_bound (m: mem) (b: block) := - high (m.(blocks) b). - -(** A block address is valid if it was previously allocated. It remains valid - even after being freed. *) - -Definition valid_block (m: mem) (b: block) := - b < m.(nextblock). - -(** Reading and writing [N] adjacent locations in a [contentmap]. - - We define two functions and prove some of their properties: - - [getN n ofs m] returns the datum at offset [ofs] in block contents [m] - after checking that the contents of offsets [ofs+1] to [ofs+n+1] - are [Cont]. - - [setN n ofs v m] updates the block contents [m], storing the content [v] - at offset [ofs] and the content [Cont] at offsets [ofs+1] to [ofs+n+1]. - *) - -Fixpoint check_cont (n: nat) (p: Z) (m: contentmap) {struct n} : bool := - match n with - | O => true - | S n1 => - match m p with - | Cont => check_cont n1 (p + 1) m - | _ => false - end - end. - -Definition eq_nat: forall (p q: nat), {p=q} + {p<>q}. -Proof. decide equality. Defined. - -Definition getN (n: nat) (p: Z) (m: contentmap) : val := - match m p with - | Datum n' v => - if eq_nat n n' && check_cont n (p + 1) m then v else Vundef - | _ => - Vundef - end. - -Fixpoint set_cont (n: nat) (p: Z) (m: contentmap) {struct n} : contentmap := - match n with - | O => m - | S n1 => update p Cont (set_cont n1 (p + 1) m) - end. - -Definition setN (n: nat) (p: Z) (v: val) (m: contentmap) : contentmap := - update p (Datum n v) (set_cont n (p + 1) m). - -Lemma check_cont_spec: - forall n m p, - if check_cont n p m - then (forall q, p <= q < p + Z_of_nat n -> m q = Cont) - else (exists q, p <= q < p + Z_of_nat n /\ m q <> Cont). -Proof. - induction n; intros. - simpl. intros; omegaContradiction. - simpl check_cont. repeat rewrite inj_S. caseEq (m p); intros. - exists p; split. omega. congruence. - exists p; split. omega. congruence. - generalize (IHn m (p + 1)). case (check_cont n (p + 1) m). - intros. assert (p = q \/ p + 1 <= q < p + Zsucc (Z_of_nat n)) by omega. - elim H2; intro. congruence. apply H0; omega. - intros [q [A B]]. exists q; split. omega. auto. -Qed. - -Lemma check_cont_true: - forall n m p, - (forall q, p <= q < p + Z_of_nat n -> m q = Cont) -> - check_cont n p m = true. -Proof. - intros. generalize (check_cont_spec n m p). - destruct (check_cont n p m). auto. - intros [q [A B]]. elim B; auto. -Qed. - -Lemma check_cont_false: - forall n m p q, - p <= q < p + Z_of_nat n -> m q <> Cont -> - check_cont n p m = false. -Proof. - intros. generalize (check_cont_spec n m p). - destruct (check_cont n p m). - intros. elim H0; auto. - auto. -Qed. - -Lemma set_cont_inside: - forall n p m q, - p <= q < p + Z_of_nat n -> - (set_cont n p m) q = Cont. -Proof. - induction n; intros. - unfold Z_of_nat in H. omegaContradiction. - simpl. - assert (p = q \/ p + 1 <= q < (p + 1) + Z_of_nat n). - rewrite inj_S in H. omega. - elim H0; intro. - subst q. apply update_s. - rewrite update_o. apply IHn. auto. - red; intro; subst q. omega. -Qed. - -Lemma set_cont_outside: - forall n p m q, - q < p \/ p + Z_of_nat n <= q -> - (set_cont n p m) q = m q. -Proof. - induction n; intros. - simpl. auto. - simpl. rewrite inj_S in H. - rewrite update_o. apply IHn. omega. omega. -Qed. - -Lemma getN_setN_same: - forall n p v m, - getN n p (setN n p v m) = v. -Proof. - intros. unfold getN, setN. rewrite update_s. - rewrite check_cont_true. unfold proj_sumbool. - rewrite dec_eq_true. auto. - intros. rewrite update_o. apply set_cont_inside. auto. - omega. -Qed. - -Lemma getN_setN_other: - forall n1 n2 p1 p2 v m, - p1 + Z_of_nat n1 < p2 \/ p2 + Z_of_nat n2 < p1 -> - getN n2 p2 (setN n1 p1 v m) = getN n2 p2 m. -Proof. - intros. unfold getN, setN. - generalize (check_cont_spec n2 m (p2 + 1)); - destruct (check_cont n2 (p2 + 1) m); intros. - rewrite check_cont_true. - rewrite update_o. rewrite set_cont_outside. auto. - omega. omega. - intros. rewrite update_o. rewrite set_cont_outside. auto. - omega. omega. - destruct H0 as [q [A B]]. - rewrite (check_cont_false n2 (update p1 (Datum n1 v) (set_cont n1 (p1 + 1) m)) (p2 + 1) q). - rewrite update_o. rewrite set_cont_outside. auto. - omega. omega. omega. - rewrite update_o. rewrite set_cont_outside. auto. - omega. omega. -Qed. - -Lemma getN_setN_overlap: - forall n1 n2 p1 p2 v m, - p1 <> p2 -> - p1 + Z_of_nat n1 >= p2 -> p2 + Z_of_nat n2 >= p1 -> - getN n2 p2 (setN n1 p1 v m) = Vundef. -Proof. - intros. unfold getN, setN. - rewrite update_o; auto. - destruct (zlt p2 p1). - (* [p1] belongs to [[p2, p2 + n2 - 1]], - therefore [check_cont n2 (p2 + 1) ...] is false. *) - rewrite (check_cont_false n2 (update p1 (Datum n1 v) (set_cont n1 (p1 + 1) m)) (p2 + 1) p1). - destruct (set_cont n1 (p1 + 1) m p2); auto. - destruct (eq_nat n2 n); auto. - omega. - rewrite update_s. congruence. - (* [p2] belongs to [[p1 + 1, p1 + n1 - 1]], - therefore [set_cont n1 (p1 + 1) m p2] is [Cont]. *) - rewrite set_cont_inside. auto. omega. -Qed. - -Lemma getN_setN_mismatch: - forall n1 n2 p v m, - n1 <> n2 -> - getN n2 p (setN n1 p v m) = Vundef. -Proof. - intros. unfold getN, setN. rewrite update_s. - unfold proj_sumbool; rewrite dec_eq_false; simpl. auto. auto. -Qed. - -Lemma getN_setN_characterization: - forall m v n1 p1 n2 p2, - getN n2 p2 (setN n1 p1 v m) = v - \/ getN n2 p2 (setN n1 p1 v m) = getN n2 p2 m - \/ getN n2 p2 (setN n1 p1 v m) = Vundef. -Proof. - intros. destruct (zeq p1 p2). subst p2. - destruct (eq_nat n1 n2). subst n2. - left; apply getN_setN_same. - right; right; apply getN_setN_mismatch; auto. - destruct (zlt (p1 + Z_of_nat n1) p2). - right; left; apply getN_setN_other; auto. - destruct (zlt (p2 + Z_of_nat n2) p1). - right; left; apply getN_setN_other; auto. - right; right; apply getN_setN_overlap; omega. -Qed. - -Lemma getN_init: - forall n p, - getN n p (fun y => Undef) = Vundef. -Proof. - intros. auto. -Qed. - -(** [valid_access m chunk b ofs] holds if a memory access (load or store) - of the given chunk is possible in [m] at address [b, ofs]. - This means: -- The block [b] is valid. -- The range of bytes accessed is within the bounds of [b]. -- The offset [ofs] is aligned. -*) - -Inductive valid_access (m: mem) (chunk: memory_chunk) (b: block) (ofs: Z) : Prop := - | valid_access_intro: - valid_block m b -> - low_bound m b <= ofs -> - ofs + size_chunk chunk <= high_bound m b -> - (align_chunk chunk | ofs) -> - valid_access m chunk b ofs. - -(** The following function checks whether accessing the given memory chunk - at the given offset in the given block respects the bounds of the block. *) - -Definition in_bounds (m: mem) (chunk: memory_chunk) (b: block) (ofs: Z) : - {valid_access m chunk b ofs} + {~valid_access m chunk b ofs}. -Proof. - intros. - destruct (zlt b m.(nextblock)). - destruct (zle (low_bound m b) ofs). - destruct (zle (ofs + size_chunk chunk) (high_bound m b)). - destruct (Zdivide_dec (align_chunk chunk) ofs (align_chunk_pos chunk)). - left; constructor; auto. - right; red; intro V; inv V; contradiction. - right; red; intro V; inv V; omega. - right; red; intro V; inv V; omega. - right; red; intro V; inv V; contradiction. -Defined. - -Lemma in_bounds_true: - forall m chunk b ofs (A: Type) (a1 a2: A), - valid_access m chunk b ofs -> - (if in_bounds m chunk b ofs then a1 else a2) = a1. -Proof. - intros. destruct (in_bounds m chunk b ofs). auto. contradiction. -Qed. - -(** [valid_pointer] holds if the given block address is valid and the - given offset falls within the bounds of the corresponding block. *) - -Definition valid_pointer (m: mem) (b: block) (ofs: Z) : bool := - zlt b m.(nextblock) && - zle (low_bound m b) ofs && - zlt ofs (high_bound m b). - -(** [load chunk m b ofs] perform a read in memory state [m], at address - [b] and offset [ofs]. [None] is returned if the address is invalid - or the memory access is out of bounds. *) - -Definition load (chunk: memory_chunk) (m: mem) (b: block) (ofs: Z) - : option val := - if in_bounds m chunk b ofs then - Some (Val.load_result chunk - (getN (pred_size_chunk chunk) ofs (contents (blocks m b)))) - else - None. - -Lemma load_inv: - forall chunk m b ofs v, - load chunk m b ofs = Some v -> - valid_access m chunk b ofs /\ - v = Val.load_result chunk - (getN (pred_size_chunk chunk) ofs (contents (blocks m b))). -Proof. - intros until v; unfold load. - destruct (in_bounds m chunk b ofs); intros. - split. auto. congruence. - congruence. -Qed. - -(** [loadv chunk m addr] is similar, but the address and offset are given - as a single value [addr], which must be a pointer value. *) - -Definition loadv (chunk: memory_chunk) (m: mem) (addr: val) : option val := - match addr with - | Vptr b ofs => load chunk m b (Int.signed ofs) - | _ => None - end. - -(* The memory state [m] after a store of value [v] at offset [ofs] - in block [b]. *) - -Definition unchecked_store - (chunk: memory_chunk) (m: mem) (b: block) - (ofs: Z) (v: val) : mem := - let c := m.(blocks) b in - mkmem - (update b - (mkblock c.(low) c.(high) - (setN (pred_size_chunk chunk) ofs v c.(contents))) - m.(blocks)) - m.(nextblock) - m.(nextblock_pos). - -(** [store chunk m b ofs v] perform a write in memory state [m]. - Value [v] is stored at address [b] and offset [ofs]. - Return the updated memory store, or [None] if the address is invalid - or the memory access is out of bounds. *) - -Definition store (chunk: memory_chunk) (m: mem) (b: block) - (ofs: Z) (v: val) : option mem := - if in_bounds m chunk b ofs - then Some(unchecked_store chunk m b ofs v) - else None. - -Lemma store_inv: - forall chunk m b ofs v m', - store chunk m b ofs v = Some m' -> - valid_access m chunk b ofs /\ - m' = unchecked_store chunk m b ofs v. -Proof. - intros until m'; unfold store. - destruct (in_bounds m chunk b ofs); intros. - split. auto. congruence. - congruence. -Qed. - -(** [storev chunk m addr v] is similar, but the address and offset are given - as a single value [addr], which must be a pointer value. *) - -Definition storev (chunk: memory_chunk) (m: mem) (addr v: val) : option mem := - match addr with - | Vptr b ofs => store chunk m b (Int.signed ofs) v - | _ => None - end. - -(** Build a block filled with the given initialization data. *) - -Fixpoint contents_init_data (pos: Z) (id: list init_data) {struct id}: contentmap := - match id with - | nil => (fun y => Undef) - | Init_int8 n :: id' => - setN 0%nat pos (Vint n) (contents_init_data (pos + 1) id') - | Init_int16 n :: id' => - setN 1%nat pos (Vint n) (contents_init_data (pos + 1) id') - | Init_int32 n :: id' => - setN 3%nat pos (Vint n) (contents_init_data (pos + 1) id') - | Init_float32 f :: id' => - setN 3%nat pos (Vfloat f) (contents_init_data (pos + 1) id') - | Init_float64 f :: id' => - setN 7%nat pos (Vfloat f) (contents_init_data (pos + 1) id') - | Init_space n :: id' => - contents_init_data (pos + Zmax n 0) id' - | Init_addrof s n :: id' => - (* Not handled properly yet *) - contents_init_data (pos + 4) id' - end. - -Definition size_init_data (id: init_data) : Z := - match id with - | Init_int8 _ => 1 - | Init_int16 _ => 2 - | Init_int32 _ => 4 - | Init_float32 _ => 4 - | Init_float64 _ => 8 - | Init_space n => Zmax n 0 - | Init_addrof _ _ => 4 - end. - -Definition size_init_data_list (id: list init_data): Z := - List.fold_right (fun id sz => size_init_data id + sz) 0 id. - -Remark size_init_data_list_pos: - forall id, size_init_data_list id >= 0. -Proof. - induction id; simpl. - omega. - assert (size_init_data a >= 0). destruct a; simpl; try omega. - generalize (Zmax2 z 0). omega. omega. -Qed. - -Definition block_init_data (id: list init_data) : block_contents := - mkblock 0 (size_init_data_list id) (contents_init_data 0 id). - -Definition alloc_init_data (m: mem) (id: list init_data) : mem * block := - (mkmem (update m.(nextblock) - (block_init_data id) - m.(blocks)) - (Zsucc m.(nextblock)) - (succ_nextblock_pos m), - m.(nextblock)). - -Remark block_init_data_empty: - block_init_data nil = empty_block 0 0. -Proof. - auto. -Qed. - -(** * Properties of the memory operations *) - -(** ** Properties related to block validity *) - -Lemma valid_not_valid_diff: - forall m b b', valid_block m b -> ~(valid_block m b') -> b <> b'. -Proof. - intros; red; intros. subst b'. contradiction. -Qed. - -Lemma valid_access_valid_block: - forall m chunk b ofs, - valid_access m chunk b ofs -> valid_block m b. -Proof. - intros. inv H; auto. -Qed. - -Lemma valid_access_aligned: - forall m chunk b ofs, - valid_access m chunk b ofs -> (align_chunk chunk | ofs). -Proof. - intros. inv H; auto. -Qed. - -Lemma valid_access_compat: - forall m chunk1 chunk2 b ofs, - size_chunk chunk1 = size_chunk chunk2 -> - valid_access m chunk1 b ofs -> - valid_access m chunk2 b ofs. -Proof. - intros. inv H0. rewrite H in H3. constructor; auto. - rewrite <- (align_chunk_compat _ _ H). auto. -Qed. - -Hint Resolve valid_not_valid_diff valid_access_valid_block valid_access_aligned: mem. - -(** ** Properties related to [load] *) - -Theorem valid_access_load: - forall m chunk b ofs, - valid_access m chunk b ofs -> - exists v, load chunk m b ofs = Some v. -Proof. - intros. econstructor. unfold load. rewrite in_bounds_true; auto. -Qed. - -Theorem load_valid_access: - forall m chunk b ofs v, - load chunk m b ofs = Some v -> - valid_access m chunk b ofs. -Proof. - intros. generalize (load_inv _ _ _ _ _ H). tauto. -Qed. - -Hint Resolve load_valid_access valid_access_load. - -(** ** Properties related to [store] *) - -Lemma valid_access_store: - forall m1 chunk b ofs v, - valid_access m1 chunk b ofs -> - exists m2, store chunk m1 b ofs v = Some m2. -Proof. - intros. econstructor. unfold store. rewrite in_bounds_true; auto. -Qed. - -Hint Resolve valid_access_store: mem. - -Section STORE. -Variable chunk: memory_chunk. -Variable m1: mem. -Variable b: block. -Variable ofs: Z. -Variable v: val. -Variable m2: mem. -Hypothesis STORE: store chunk m1 b ofs v = Some m2. - -Lemma low_bound_store: - forall b', low_bound m2 b' = low_bound m1 b'. -Proof. - intro. elim (store_inv _ _ _ _ _ _ STORE); intros. - subst m2. unfold low_bound, unchecked_store; simpl. - unfold update. destruct (zeq b' b); auto. subst b'; auto. -Qed. - -Lemma high_bound_store: - forall b', high_bound m2 b' = high_bound m1 b'. -Proof. - intro. elim (store_inv _ _ _ _ _ _ STORE); intros. - subst m2. unfold high_bound, unchecked_store; simpl. - unfold update. destruct (zeq b' b); auto. subst b'; auto. -Qed. - -Lemma nextblock_store: - nextblock m2 = nextblock m1. -Proof. - intros. elim (store_inv _ _ _ _ _ _ STORE); intros. - subst m2; reflexivity. -Qed. - -Lemma store_valid_block_1: - forall b', valid_block m1 b' -> valid_block m2 b'. -Proof. - unfold valid_block; intros. rewrite nextblock_store; auto. -Qed. - -Lemma store_valid_block_2: - forall b', valid_block m2 b' -> valid_block m1 b'. -Proof. - unfold valid_block; intros. rewrite nextblock_store in H; auto. -Qed. - -Hint Resolve store_valid_block_1 store_valid_block_2: mem. - -Lemma store_valid_access_1: - forall chunk' b' ofs', - valid_access m1 chunk' b' ofs' -> valid_access m2 chunk' b' ofs'. -Proof. - intros. inv H. constructor; auto with mem. - rewrite low_bound_store; auto. - rewrite high_bound_store; auto. -Qed. - -Lemma store_valid_access_2: - forall chunk' b' ofs', - valid_access m2 chunk' b' ofs' -> valid_access m1 chunk' b' ofs'. -Proof. - intros. inv H. constructor; auto with mem. - rewrite low_bound_store in H1; auto. - rewrite high_bound_store in H2; auto. -Qed. - -Lemma store_valid_access_3: - valid_access m1 chunk b ofs. -Proof. - elim (store_inv _ _ _ _ _ _ STORE); intros. auto. -Qed. - -Hint Resolve store_valid_access_1 store_valid_access_2 - store_valid_access_3: mem. - -Theorem load_store_similar: - forall chunk', - size_chunk chunk' = size_chunk chunk -> - load chunk' m2 b ofs = Some (Val.load_result chunk' v). -Proof. - intros. destruct (store_inv _ _ _ _ _ _ STORE). - unfold load. rewrite in_bounds_true. - decEq. decEq. rewrite H1. unfold unchecked_store; simpl. - rewrite update_s. simpl. - replace (pred_size_chunk chunk) with (pred_size_chunk chunk'). - apply getN_setN_same. - repeat rewrite size_chunk_pred in H. omega. - apply store_valid_access_1. - inv H0. constructor; auto. congruence. - rewrite (align_chunk_compat _ _ H). auto. -Qed. - -Theorem load_store_same: - load chunk m2 b ofs = Some (Val.load_result chunk v). -Proof. - eapply load_store_similar; eauto. -Qed. - -Theorem load_store_other: - forall chunk' b' ofs', - b' <> b - \/ ofs' + size_chunk chunk' <= ofs - \/ ofs + size_chunk chunk <= ofs' -> - load chunk' m2 b' ofs' = load chunk' m1 b' ofs'. -Proof. - intros. destruct (store_inv _ _ _ _ _ _ STORE). - unfold load. destruct (in_bounds m1 chunk' b' ofs'). - rewrite in_bounds_true. decEq. decEq. - rewrite H1; unfold unchecked_store; simpl. - unfold update. destruct (zeq b' b). subst b'. - simpl. repeat rewrite size_chunk_pred in H. - apply getN_setN_other. elim H; intro. congruence. omega. - auto. - eauto with mem. - destruct (in_bounds m2 chunk' b' ofs'); auto. - elim n. eauto with mem. -Qed. - -Theorem load_store_overlap: - forall chunk' ofs' v', - load chunk' m2 b ofs' = Some v' -> - ofs' <> ofs -> - ofs' + size_chunk chunk' > ofs -> - ofs + size_chunk chunk > ofs' -> - v' = Vundef. -Proof. - intros. destruct (store_inv _ _ _ _ _ _ STORE). - destruct (load_inv _ _ _ _ _ H). rewrite H6. - rewrite H4. unfold unchecked_store. simpl. rewrite update_s. - simpl. rewrite getN_setN_overlap. - destruct chunk'; reflexivity. - auto. rewrite size_chunk_pred in H2. omega. - rewrite size_chunk_pred in H1. omega. -Qed. - -Theorem load_store_overlap': - forall chunk' ofs', - valid_access m1 chunk' b ofs' -> - ofs' <> ofs -> - ofs' + size_chunk chunk' > ofs -> - ofs + size_chunk chunk > ofs' -> - load chunk' m2 b ofs' = Some Vundef. -Proof. - intros. - assert (exists v', load chunk' m2 b ofs' = Some v'). - eauto with mem. - destruct H3 as [v' LOAD]. rewrite LOAD. decEq. - eapply load_store_overlap; eauto. -Qed. - -Theorem load_store_mismatch: - forall chunk' v', - load chunk' m2 b ofs = Some v' -> - size_chunk chunk' <> size_chunk chunk -> - v' = Vundef. -Proof. - intros. destruct (store_inv _ _ _ _ _ _ STORE). - destruct (load_inv _ _ _ _ _ H). rewrite H4. - rewrite H2. unfold unchecked_store. simpl. rewrite update_s. - simpl. rewrite getN_setN_mismatch. - destruct chunk'; reflexivity. - repeat rewrite size_chunk_pred in H0; omega. -Qed. - -Theorem load_store_mismatch': - forall chunk', - valid_access m1 chunk' b ofs -> - size_chunk chunk' <> size_chunk chunk -> - load chunk' m2 b ofs = Some Vundef. -Proof. - intros. - assert (exists v', load chunk' m2 b ofs = Some v'). - eauto with mem. - destruct H1 as [v' LOAD]. rewrite LOAD. decEq. - eapply load_store_mismatch; eauto. -Qed. - -Inductive load_store_cases - (chunk1: memory_chunk) (b1: block) (ofs1: Z) - (chunk2: memory_chunk) (b2: block) (ofs2: Z) : Type := - | lsc_similar: - b1 = b2 -> ofs1 = ofs2 -> size_chunk chunk1 = size_chunk chunk2 -> - load_store_cases chunk1 b1 ofs1 chunk2 b2 ofs2 - | lsc_other: - b1 <> b2 \/ ofs2 + size_chunk chunk2 <= ofs1 \/ ofs1 + size_chunk chunk1 <= ofs2 -> - load_store_cases chunk1 b1 ofs1 chunk2 b2 ofs2 - | lsc_overlap: - b1 = b2 -> ofs1 <> ofs2 -> ofs2 + size_chunk chunk2 > ofs1 -> ofs1 + size_chunk chunk1 > ofs2 -> - load_store_cases chunk1 b1 ofs1 chunk2 b2 ofs2 - | lsc_mismatch: - b1 = b2 -> ofs1 = ofs2 -> size_chunk chunk1 <> size_chunk chunk2 -> - load_store_cases chunk1 b1 ofs1 chunk2 b2 ofs2. - -Definition load_store_classification: - forall (chunk1: memory_chunk) (b1: block) (ofs1: Z) - (chunk2: memory_chunk) (b2: block) (ofs2: Z), - load_store_cases chunk1 b1 ofs1 chunk2 b2 ofs2. -Proof. - intros. destruct (eq_block b1 b2). - destruct (zeq ofs1 ofs2). - destruct (zeq (size_chunk chunk1) (size_chunk chunk2)). - apply lsc_similar; auto. - apply lsc_mismatch; auto. - destruct (zle (ofs2 + size_chunk chunk2) ofs1). - apply lsc_other. tauto. - destruct (zle (ofs1 + size_chunk chunk1) ofs2). - apply lsc_other. tauto. - apply lsc_overlap; auto. - apply lsc_other; tauto. -Qed. - -Theorem load_store_characterization: - forall chunk' b' ofs', - valid_access m1 chunk' b' ofs' -> - load chunk' m2 b' ofs' = - match load_store_classification chunk b ofs chunk' b' ofs' with - | lsc_similar _ _ _ => Some (Val.load_result chunk' v) - | lsc_other _ => load chunk' m1 b' ofs' - | lsc_overlap _ _ _ _ => Some Vundef - | lsc_mismatch _ _ _ => Some Vundef - end. -Proof. - intros. - assert (exists v', load chunk' m2 b' ofs' = Some v') by eauto with mem. - destruct H0 as [v' LOAD]. - destruct (load_store_classification chunk b ofs chunk' b' ofs'). - subst b' ofs'. apply load_store_similar; auto. - apply load_store_other; intuition. - subst b'. rewrite LOAD. decEq. - eapply load_store_overlap; eauto. - subst b' ofs'. rewrite LOAD. decEq. - eapply load_store_mismatch; eauto. -Qed. - -End STORE. - -Hint Resolve store_valid_block_1 store_valid_block_2: mem. -Hint Resolve store_valid_access_1 store_valid_access_2 - store_valid_access_3: mem. - -(** ** Properties related to [alloc]. *) - -Section ALLOC. - -Variable m1: mem. -Variables lo hi: Z. -Variable m2: mem. -Variable b: block. -Hypothesis ALLOC: alloc m1 lo hi = (m2, b). - -Lemma nextblock_alloc: - nextblock m2 = Zsucc (nextblock m1). -Proof. - injection ALLOC; intros. rewrite <- H0; auto. -Qed. - -Lemma alloc_result: - b = nextblock m1. -Proof. - injection ALLOC; auto. -Qed. - -Lemma valid_block_alloc: - forall b', valid_block m1 b' -> valid_block m2 b'. -Proof. - unfold valid_block; intros. rewrite nextblock_alloc. omega. -Qed. - -Lemma fresh_block_alloc: - ~(valid_block m1 b). -Proof. - unfold valid_block. rewrite alloc_result. omega. -Qed. - -Lemma valid_new_block: - valid_block m2 b. -Proof. - unfold valid_block. rewrite alloc_result. rewrite nextblock_alloc. omega. -Qed. - -Hint Resolve valid_block_alloc fresh_block_alloc valid_new_block: mem. - -Lemma valid_block_alloc_inv: - forall b', valid_block m2 b' -> b' = b \/ valid_block m1 b'. -Proof. - unfold valid_block; intros. - rewrite nextblock_alloc in H. rewrite alloc_result. - unfold block; omega. -Qed. - -Lemma low_bound_alloc: - forall b', low_bound m2 b' = if zeq b' b then lo else low_bound m1 b'. -Proof. - intros. injection ALLOC; intros. rewrite <- H0; unfold low_bound; simpl. - unfold update. rewrite H. destruct (zeq b' b); auto. -Qed. - -Lemma low_bound_alloc_same: - low_bound m2 b = lo. -Proof. - rewrite low_bound_alloc. apply zeq_true. -Qed. - -Lemma low_bound_alloc_other: - forall b', valid_block m1 b' -> low_bound m2 b' = low_bound m1 b'. -Proof. - intros; rewrite low_bound_alloc. - apply zeq_false. eauto with mem. -Qed. - -Lemma high_bound_alloc: - forall b', high_bound m2 b' = if zeq b' b then hi else high_bound m1 b'. -Proof. - intros. injection ALLOC; intros. rewrite <- H0; unfold high_bound; simpl. - unfold update. rewrite H. destruct (zeq b' b); auto. -Qed. - -Lemma high_bound_alloc_same: - high_bound m2 b = hi. -Proof. - rewrite high_bound_alloc. apply zeq_true. -Qed. - -Lemma high_bound_alloc_other: - forall b', valid_block m1 b' -> high_bound m2 b' = high_bound m1 b'. -Proof. - intros; rewrite high_bound_alloc. - apply zeq_false. eauto with mem. -Qed. - -Lemma valid_access_alloc_other: - forall chunk b' ofs, - valid_access m1 chunk b' ofs -> - valid_access m2 chunk b' ofs. -Proof. - intros. inv H. constructor; auto with mem. - rewrite low_bound_alloc_other; auto. - rewrite high_bound_alloc_other; auto. -Qed. - -Lemma valid_access_alloc_same: - forall chunk ofs, - lo <= ofs -> ofs + size_chunk chunk <= hi -> (align_chunk chunk | ofs) -> - valid_access m2 chunk b ofs. -Proof. - intros. constructor; auto with mem. - rewrite low_bound_alloc_same; auto. - rewrite high_bound_alloc_same; auto. -Qed. - -Hint Resolve valid_access_alloc_other valid_access_alloc_same: mem. - -Lemma valid_access_alloc_inv: - forall chunk b' ofs, - valid_access m2 chunk b' ofs -> - valid_access m1 chunk b' ofs \/ - (b' = b /\ lo <= ofs /\ ofs + size_chunk chunk <= hi /\ (align_chunk chunk | ofs)). -Proof. - intros. inv H. - elim (valid_block_alloc_inv _ H0); intro. - subst b'. rewrite low_bound_alloc_same in H1. - rewrite high_bound_alloc_same in H2. - right. tauto. - left. constructor; auto. - rewrite low_bound_alloc_other in H1; auto. - rewrite high_bound_alloc_other in H2; auto. -Qed. - -Theorem load_alloc_unchanged: - forall chunk b' ofs, - valid_block m1 b' -> - load chunk m2 b' ofs = load chunk m1 b' ofs. -Proof. - intros. unfold load. - destruct (in_bounds m2 chunk b' ofs). - elim (valid_access_alloc_inv _ _ _ v). intro. - rewrite in_bounds_true; auto. - injection ALLOC; intros. rewrite <- H2; simpl. - rewrite update_o. auto. rewrite H1. apply sym_not_equal. eauto with mem. - intros [A [B C]]. subst b'. elimtype False. eauto with mem. - destruct (in_bounds m1 chunk b' ofs). - elim n; eauto with mem. - auto. -Qed. - -Theorem load_alloc_other: - forall chunk b' ofs v, - load chunk m1 b' ofs = Some v -> - load chunk m2 b' ofs = Some v. -Proof. - intros. rewrite <- H. apply load_alloc_unchanged. eauto with mem. -Qed. - -Theorem load_alloc_same: - forall chunk ofs v, - load chunk m2 b ofs = Some v -> - v = Vundef. -Proof. - intros. destruct (load_inv _ _ _ _ _ H). rewrite H1. - injection ALLOC; intros. rewrite <- H3; simpl. - rewrite <- H2. rewrite update_s. - simpl. rewrite getN_init. destruct chunk; auto. -Qed. - -Theorem load_alloc_same': - forall chunk ofs, - lo <= ofs -> ofs + size_chunk chunk <= hi -> (align_chunk chunk | ofs) -> - load chunk m2 b ofs = Some Vundef. -Proof. - intros. assert (exists v, load chunk m2 b ofs = Some v). - apply valid_access_load. constructor; eauto with mem. - rewrite low_bound_alloc_same. auto. - rewrite high_bound_alloc_same. auto. - destruct H2 as [v LOAD]. rewrite LOAD. decEq. - eapply load_alloc_same; eauto. -Qed. - -End ALLOC. - -Hint Resolve valid_block_alloc fresh_block_alloc valid_new_block: mem. -Hint Resolve valid_access_alloc_other valid_access_alloc_same: mem. -Hint Resolve load_alloc_unchanged: mem. - -(** ** Properties related to [free]. *) - -Section FREE. - -Variable m: mem. -Variable bf: block. - -Lemma valid_block_free_1: - forall b, valid_block m b -> valid_block (free m bf) b. -Proof. - unfold valid_block, free; intros; simpl; auto. -Qed. - -Lemma valid_block_free_2: - forall b, valid_block (free m bf) b -> valid_block m b. -Proof. - unfold valid_block, free; intros; simpl in *; auto. -Qed. - -Hint Resolve valid_block_free_1 valid_block_free_2: mem. - -Lemma low_bound_free: - forall b, b <> bf -> low_bound (free m bf) b = low_bound m b. -Proof. - intros. unfold low_bound, free; simpl. - rewrite update_o; auto. -Qed. - -Lemma high_bound_free: - forall b, b <> bf -> high_bound (free m bf) b = high_bound m b. -Proof. - intros. unfold high_bound, free; simpl. - rewrite update_o; auto. -Qed. - -Lemma low_bound_free_same: - forall m b, low_bound (free m b) b = 0. -Proof. - intros. unfold low_bound; simpl. rewrite update_s. simpl; omega. -Qed. - -Lemma high_bound_free_same: - forall m b, high_bound (free m b) b = 0. -Proof. - intros. unfold high_bound; simpl. rewrite update_s. simpl; omega. -Qed. - -Lemma valid_access_free_1: - forall chunk b ofs, - valid_access m chunk b ofs -> b <> bf -> - valid_access (free m bf) chunk b ofs. -Proof. - intros. inv H. constructor; auto with mem. - rewrite low_bound_free; auto. rewrite high_bound_free; auto. -Qed. - -Lemma valid_access_free_2: - forall chunk ofs, ~(valid_access (free m bf) chunk bf ofs). -Proof. - intros; red; intros. inv H. - unfold free, low_bound in H1; simpl in H1. rewrite update_s in H1. simpl in H1. - unfold free, high_bound in H2; simpl in H2. rewrite update_s in H2. simpl in H2. - generalize (size_chunk_pos chunk). omega. -Qed. - -Hint Resolve valid_access_free_1 valid_access_free_2: mem. - -Lemma valid_access_free_inv: - forall chunk b ofs, - valid_access (free m bf) chunk b ofs -> - valid_access m chunk b ofs /\ b <> bf. -Proof. - intros. destruct (eq_block b bf). subst b. - elim (valid_access_free_2 _ _ H). - inv H. rewrite low_bound_free in H1; auto. - rewrite high_bound_free in H2; auto. - split; auto. constructor; auto with mem. -Qed. - -Theorem load_free: - forall chunk b ofs, - b <> bf -> - load chunk (free m bf) b ofs = load chunk m b ofs. -Proof. - intros. unfold load. - destruct (in_bounds m chunk b ofs). - rewrite in_bounds_true; auto with mem. - unfold free; simpl. rewrite update_o; auto. - destruct (in_bounds (free m bf) chunk b ofs); auto. - elim n. elim (valid_access_free_inv _ _ _ v); auto. -Qed. - -End FREE. - -(** ** Properties related to [free_list] *) - -Lemma valid_block_free_list_1: - forall bl m b, valid_block m b -> valid_block (free_list m bl) b. -Proof. - induction bl; simpl; intros. auto. - apply valid_block_free_1; auto. -Qed. - -Lemma valid_block_free_list_2: - forall bl m b, valid_block (free_list m bl) b -> valid_block m b. -Proof. - induction bl; simpl; intros. auto. - apply IHbl. apply valid_block_free_2 with a; auto. -Qed. - -Lemma valid_access_free_list: - forall chunk b ofs m bl, - valid_access m chunk b ofs -> ~In b bl -> - valid_access (free_list m bl) chunk b ofs. -Proof. - induction bl; simpl; intros. auto. - apply valid_access_free_1. apply IHbl. auto. intuition. intuition congruence. -Qed. - -Lemma valid_access_free_list_inv: - forall chunk b ofs m bl, - valid_access (free_list m bl) chunk b ofs -> - ~In b bl /\ valid_access m chunk b ofs. -Proof. - induction bl; simpl; intros. - tauto. - elim (valid_access_free_inv _ _ _ _ _ H); intros. - elim (IHbl H0); intros. - intuition congruence. -Qed. - -(** ** Properties related to pointer validity *) - -Lemma valid_pointer_valid_access: - forall m b ofs, - valid_pointer m b ofs = true <-> valid_access m Mint8unsigned b ofs. -Proof. - unfold valid_pointer; intros; split; intros. - destruct (andb_prop _ _ H). destruct (andb_prop _ _ H0). - constructor. red. eapply proj_sumbool_true; eauto. - eapply proj_sumbool_true; eauto. - change (size_chunk Mint8unsigned) with 1. - generalize (proj_sumbool_true _ H1). omega. - simpl. apply Zone_divide. - inv H. unfold proj_sumbool. - rewrite zlt_true; auto. rewrite zle_true; auto. - change (size_chunk Mint8unsigned) with 1 in H2. - rewrite zlt_true. auto. omega. -Qed. - -Theorem valid_pointer_alloc: - forall (m1 m2: mem) (lo hi: Z) (b b': block) (ofs: Z), - alloc m1 lo hi = (m2, b') -> - valid_pointer m1 b ofs = true -> - valid_pointer m2 b ofs = true. -Proof. - intros. rewrite valid_pointer_valid_access in H0. - rewrite valid_pointer_valid_access. - eauto with mem. -Qed. - -Theorem valid_pointer_store: - forall (chunk: memory_chunk) (m1 m2: mem) (b b': block) (ofs ofs': Z) (v: val), - store chunk m1 b' ofs' v = Some m2 -> - valid_pointer m1 b ofs = true -> valid_pointer m2 b ofs = true. -Proof. - intros. rewrite valid_pointer_valid_access in H0. - rewrite valid_pointer_valid_access. - eauto with mem. -Qed. - -(** * Generic injections between memory states. *) - -Section GENERIC_INJECT. - -Definition meminj : Type := block -> option (block * Z). - -Variable val_inj: meminj -> val -> val -> Prop. - -Hypothesis val_inj_undef: - forall mi, val_inj mi Vundef Vundef. - -Definition mem_inj (mi: meminj) (m1 m2: mem) := - forall chunk b1 ofs v1 b2 delta, - mi b1 = Some(b2, delta) -> - load chunk m1 b1 ofs = Some v1 -> - exists v2, load chunk m2 b2 (ofs + delta) = Some v2 /\ val_inj mi v1 v2. - -Lemma valid_access_inj: - forall mi m1 m2 chunk b1 ofs b2 delta, - mi b1 = Some(b2, delta) -> - mem_inj mi m1 m2 -> - valid_access m1 chunk b1 ofs -> - valid_access m2 chunk b2 (ofs + delta). -Proof. - intros. - assert (exists v1, load chunk m1 b1 ofs = Some v1) by eauto with mem. - destruct H2 as [v1 LOAD1]. - destruct (H0 _ _ _ _ _ _ H LOAD1) as [v2 [LOAD2 VCP]]. - eauto with mem. -Qed. - -Hint Resolve valid_access_inj: mem. - -Lemma store_unmapped_inj: - forall mi m1 m2 b ofs v chunk m1', - mem_inj mi m1 m2 -> - mi b = None -> - store chunk m1 b ofs v = Some m1' -> - mem_inj mi m1' m2. -Proof. - intros; red; intros. - assert (load chunk0 m1 b1 ofs0 = Some v1). - rewrite <- H3; symmetry. eapply load_store_other; eauto. - left. congruence. - eapply H; eauto. -Qed. - -Lemma store_outside_inj: - forall mi m1 m2 chunk b ofs v m2', - mem_inj mi m1 m2 -> - (forall b' delta, - mi b' = Some(b, delta) -> - high_bound m1 b' + delta <= ofs - \/ ofs + size_chunk chunk <= low_bound m1 b' + delta) -> - store chunk m2 b ofs v = Some m2' -> - mem_inj mi m1 m2'. -Proof. - intros; red; intros. - exploit H; eauto. intros [v2 [LOAD2 VINJ]]. - exists v2; split; auto. - rewrite <- LOAD2. eapply load_store_other; eauto. - destruct (eq_block b2 b). subst b2. - right. generalize (H0 _ _ H2); intro. - assert (valid_access m1 chunk0 b1 ofs0) by eauto with mem. - inv H5. omega. auto. -Qed. - -Definition meminj_no_overlap (mi: meminj) (m: mem) : Prop := - forall b1 b1' delta1 b2 b2' delta2, - b1 <> b2 -> - mi b1 = Some (b1', delta1) -> - mi b2 = Some (b2', delta2) -> - b1' <> b2' - \/ low_bound m b1 >= high_bound m b1 - \/ low_bound m b2 >= high_bound m b2 - \/ high_bound m b1 + delta1 <= low_bound m b2 + delta2 - \/ high_bound m b2 + delta2 <= low_bound m b1 + delta1. - -Lemma store_mapped_inj: - forall mi m1 m2 b1 ofs b2 delta v1 v2 chunk m1', - mem_inj mi m1 m2 -> - meminj_no_overlap mi m1 -> - mi b1 = Some(b2, delta) -> - store chunk m1 b1 ofs v1 = Some m1' -> - (forall chunk', size_chunk chunk' = size_chunk chunk -> - val_inj mi (Val.load_result chunk' v1) (Val.load_result chunk' v2)) -> - exists m2', - store chunk m2 b2 (ofs + delta) v2 = Some m2' /\ mem_inj mi m1' m2'. -Proof. - intros. - assert (exists m2', store chunk m2 b2 (ofs + delta) v2 = Some m2') by eauto with mem. - destruct H4 as [m2' STORE2]. - exists m2'; split. auto. - red. intros chunk' b1' ofs' v b2' delta' CP LOAD1. - assert (valid_access m1 chunk' b1' ofs') by eauto with mem. - generalize (load_store_characterization _ _ _ _ _ _ H2 _ _ _ H4). - destruct (load_store_classification chunk b1 ofs chunk' b1' ofs'); - intro. - (* similar *) - subst b1' ofs'. - rewrite CP in H1. inv H1. - rewrite LOAD1 in H5. inv H5. - exists (Val.load_result chunk' v2). split. - eapply load_store_similar; eauto. - auto. - (* disjoint *) - rewrite LOAD1 in H5. - destruct (H _ _ _ _ _ _ CP (sym_equal H5)) as [v2' [LOAD2 VCP]]. - exists v2'. split; auto. - rewrite <- LOAD2. eapply load_store_other; eauto. - destruct (eq_block b1 b1'). subst b1'. - rewrite CP in H1; inv H1. - right. elim o; [congruence | omega]. - assert (valid_access m1 chunk b1 ofs) by eauto with mem. - generalize (H0 _ _ _ _ _ _ n H1 CP). intros [A | [A | [A | A]]]. - auto. - inv H6. generalize (size_chunk_pos chunk). intro. omegaContradiction. - inv H4. generalize (size_chunk_pos chunk'). intro. omegaContradiction. - right. inv H4. inv H6. omega. - (* overlapping *) - subst b1'. rewrite CP in H1; inv H1. - assert (exists v2', load chunk' m2' b2 (ofs' + delta) = Some v2') by eauto with mem. - destruct H1 as [v2' LOAD2']. - assert (v2' = Vundef). eapply load_store_overlap; eauto. - omega. omega. omega. - exists v2'; split. auto. - replace v with Vundef by congruence. subst v2'. apply val_inj_undef. - (* mismatch *) - subst b1' ofs'. rewrite CP in H1; inv H1. - assert (exists v2', load chunk' m2' b2 (ofs + delta) = Some v2') by eauto with mem. - destruct H1 as [v2' LOAD2']. - assert (v2' = Vundef). eapply load_store_mismatch; eauto. - exists v2'; split. auto. - replace v with Vundef by congruence. subst v2'. apply val_inj_undef. -Qed. - -Definition inj_offset_aligned (delta: Z) (size: Z) : Prop := - forall chunk, size_chunk chunk <= size -> (align_chunk chunk | delta). - -Lemma alloc_parallel_inj: - forall mi m1 m2 lo1 hi1 m1' b1 lo2 hi2 m2' b2 delta, - mem_inj mi m1 m2 -> - alloc m1 lo1 hi1 = (m1', b1) -> - alloc m2 lo2 hi2 = (m2', b2) -> - mi b1 = Some(b2, delta) -> - lo2 <= lo1 + delta -> hi1 + delta <= hi2 -> - inj_offset_aligned delta (hi1 - lo1) -> - mem_inj mi m1' m2'. -Proof. - intros; red; intros. - exploit (valid_access_alloc_inv m1); eauto with mem. - intros [A | [A [B [C D]]]]. - assert (load chunk m1 b0 ofs = Some v1). - rewrite <- H7. symmetry. eapply load_alloc_unchanged; eauto with mem. - exploit H; eauto. intros [v2 [LOAD2 VINJ]]. - exists v2; split. - rewrite <- LOAD2. eapply load_alloc_unchanged; eauto with mem. - auto. - subst b0. rewrite H2 in H6. inversion H6. subst b3 delta0. - assert (v1 = Vundef). eapply load_alloc_same with (m1 := m1); eauto. - subst v1. - assert (exists v2, load chunk m2' b2 (ofs + delta) = Some v2). - apply valid_access_load. - eapply valid_access_alloc_same; eauto. omega. omega. - apply Zdivide_plus_r; auto. apply H5. omega. - destruct H8 as [v2 LOAD2]. - assert (v2 = Vundef). eapply load_alloc_same with (m1 := m2); eauto. - subst v2. - exists Vundef; split. auto. apply val_inj_undef. -Qed. - -Lemma alloc_right_inj: - forall mi m1 m2 lo hi b2 m2', - mem_inj mi m1 m2 -> - alloc m2 lo hi = (m2', b2) -> - mem_inj mi m1 m2'. -Proof. - intros; red; intros. - exploit H; eauto. intros [v2 [LOAD2 VINJ]]. - exists v2; split; auto. - assert (valid_block m2 b0). - apply valid_access_valid_block with chunk (ofs + delta). - eauto with mem. - rewrite <- LOAD2. eapply load_alloc_unchanged; eauto. -Qed. - -Hypothesis val_inj_undef_any: - forall mi v, val_inj mi Vundef v. - -Lemma alloc_left_unmapped_inj: - forall mi m1 m2 lo hi b1 m1', - mem_inj mi m1 m2 -> - alloc m1 lo hi = (m1', b1) -> - mi b1 = None -> - mem_inj mi m1' m2. -Proof. - intros; red; intros. - exploit (valid_access_alloc_inv m1); eauto with mem. - intros [A | [A [B C]]]. - eapply H; eauto. - rewrite <- H3. symmetry. eapply load_alloc_unchanged; eauto with mem. - subst b0. congruence. -Qed. - -Lemma alloc_left_mapped_inj: - forall mi m1 m2 lo hi b1 m1' b2 delta, - mem_inj mi m1 m2 -> - alloc m1 lo hi = (m1', b1) -> - mi b1 = Some(b2, delta) -> - valid_block m2 b2 -> - low_bound m2 b2 <= lo + delta -> hi + delta <= high_bound m2 b2 -> - inj_offset_aligned delta (hi - lo) -> - mem_inj mi m1' m2. -Proof. - intros; red; intros. - exploit (valid_access_alloc_inv m1); eauto with mem. - intros [A | [A [B [C D]]]]. - eapply H; eauto. - rewrite <- H7. symmetry. eapply load_alloc_unchanged; eauto with mem. - subst b0. rewrite H1 in H6. inversion H6. subst b3 delta0. - assert (v1 = Vundef). eapply load_alloc_same with (m1 := m1); eauto. - subst v1. - assert (exists v2, load chunk m2 b2 (ofs + delta) = Some v2). - apply valid_access_load. constructor. auto. omega. omega. - apply Zdivide_plus_r; auto. apply H5. omega. - destruct H8 as [v2 LOAD2]. exists v2; split. auto. - apply val_inj_undef_any. -Qed. - -Lemma free_parallel_inj: - forall mi m1 m2 b1 b2 delta, - mem_inj mi m1 m2 -> - mi b1 = Some(b2, delta) -> - (forall b delta', mi b = Some(b2, delta') -> b = b1) -> - mem_inj mi (free m1 b1) (free m2 b2). -Proof. - intros; red; intros. - exploit valid_access_free_inv; eauto with mem. intros [A B]. - assert (load chunk m1 b0 ofs = Some v1). - rewrite <- H3. symmetry. apply load_free. auto. - exploit H; eauto. intros [v2 [LOAD2 INJ]]. - exists v2; split. - rewrite <- LOAD2. apply load_free. - red; intro; subst b3. elim B. eauto. - auto. -Qed. - -Lemma free_left_inj: - forall mi m1 m2 b1, - mem_inj mi m1 m2 -> - mem_inj mi (free m1 b1) m2. -Proof. - intros; red; intros. - exploit valid_access_free_inv; eauto with mem. intros [A B]. - eapply H; eauto with mem. - rewrite <- H1; symmetry; eapply load_free; eauto. -Qed. - -Lemma free_list_left_inj: - forall mi bl m1 m2, - mem_inj mi m1 m2 -> - mem_inj mi (free_list m1 bl) m2. -Proof. - induction bl; intros; simpl. - auto. - apply free_left_inj. auto. -Qed. - -Lemma free_right_inj: - forall mi m1 m2 b2, - mem_inj mi m1 m2 -> - (forall b1 delta chunk ofs, - mi b1 = Some(b2, delta) -> ~(valid_access m1 chunk b1 ofs)) -> - mem_inj mi m1 (free m2 b2). -Proof. - intros; red; intros. - assert (b0 <> b2). - red; intro; subst b0. elim (H0 b1 delta chunk ofs H1). - eauto with mem. - exploit H; eauto. intros [v2 [LOAD2 INJ]]. - exists v2; split; auto. - rewrite <- LOAD2. apply load_free. auto. -Qed. - -Lemma valid_pointer_inj: - forall mi m1 m2 b1 ofs b2 delta, - mi b1 = Some(b2, delta) -> - mem_inj mi m1 m2 -> - valid_pointer m1 b1 ofs = true -> - valid_pointer m2 b2 (ofs + delta) = true. -Proof. - intros. rewrite valid_pointer_valid_access in H1. - rewrite valid_pointer_valid_access. eauto with mem. -Qed. - -End GENERIC_INJECT. - -(** ** Store extensions *) - -(** A store [m2] extends a store [m1] if [m2] can be obtained from [m1] - by increasing the sizes of the memory blocks of [m1] (decreasing - the low bounds, increasing the high bounds), while still keeping the - same contents for block offsets that are valid in [m1]. *) - -Definition inject_id : meminj := fun b => Some(b, 0). - -Definition val_inj_id (mi: meminj) (v1 v2: val) : Prop := v1 = v2. - -Definition extends (m1 m2: mem) := - nextblock m1 = nextblock m2 /\ mem_inj val_inj_id inject_id m1 m2. - -Theorem extends_refl: - forall (m: mem), extends m m. -Proof. - intros; split. auto. - red; unfold inject_id; intros. inv H. - exists v1; split. replace (ofs + 0) with ofs by omega. auto. - unfold val_inj_id; auto. -Qed. - -Theorem alloc_extends: - forall (m1 m2 m1' m2': mem) (lo1 hi1 lo2 hi2: Z) (b1 b2: block), - extends m1 m2 -> - lo2 <= lo1 -> hi1 <= hi2 -> - alloc m1 lo1 hi1 = (m1', b1) -> - alloc m2 lo2 hi2 = (m2', b2) -> - b1 = b2 /\ extends m1' m2'. -Proof. - intros. destruct H. - assert (b1 = b2). - transitivity (nextblock m1). eapply alloc_result; eauto. - symmetry. rewrite H. eapply alloc_result; eauto. - subst b2. split. auto. split. - rewrite (nextblock_alloc _ _ _ _ _ H2). - rewrite (nextblock_alloc _ _ _ _ _ H3). - congruence. - eapply alloc_parallel_inj; eauto. - unfold val_inj_id; auto. - unfold inject_id; eauto. - omega. omega. - red; intros. apply Zdivide_0. -Qed. - -Theorem free_extends: - forall (m1 m2: mem) (b: block), - extends m1 m2 -> - extends (free m1 b) (free m2 b). -Proof. - intros. destruct H. split. - simpl; auto. - eapply free_parallel_inj; eauto. - unfold inject_id. eauto. - unfold inject_id; intros. congruence. -Qed. - -Theorem load_extends: - forall (chunk: memory_chunk) (m1 m2: mem) (b: block) (ofs: Z) (v: val), - extends m1 m2 -> - load chunk m1 b ofs = Some v -> - load chunk m2 b ofs = Some v. -Proof. - intros. destruct H. - exploit H1; eauto. unfold inject_id. eauto. - unfold val_inj_id. intros [v2 [LOAD EQ]]. - replace (ofs + 0) with ofs in LOAD by omega. congruence. -Qed. - -Theorem store_within_extends: - forall (chunk: memory_chunk) (m1 m2 m1': mem) (b: block) (ofs: Z) (v: val), - extends m1 m2 -> - store chunk m1 b ofs v = Some m1' -> - exists m2', store chunk m2 b ofs v = Some m2' /\ extends m1' m2'. -Proof. - intros. destruct H. - exploit store_mapped_inj; eauto. - unfold val_inj_id; eauto. - unfold meminj_no_overlap, inject_id; intros. - inv H3. inv H4. auto. - unfold inject_id; eauto. - unfold val_inj_id; intros. eauto. - intros [m2' [STORE MINJ]]. - exists m2'; split. - replace (ofs + 0) with ofs in STORE by omega. auto. - split. - rewrite (nextblock_store _ _ _ _ _ _ H0). - rewrite (nextblock_store _ _ _ _ _ _ STORE). - auto. - auto. -Qed. - -Theorem store_outside_extends: - forall (chunk: memory_chunk) (m1 m2 m2': mem) (b: block) (ofs: Z) (v: val), - extends m1 m2 -> - ofs + size_chunk chunk <= low_bound m1 b \/ high_bound m1 b <= ofs -> - store chunk m2 b ofs v = Some m2' -> - extends m1 m2'. -Proof. - intros. destruct H. split. - rewrite (nextblock_store _ _ _ _ _ _ H1). auto. - eapply store_outside_inj; eauto. - unfold inject_id; intros. inv H3. omega. -Qed. - -Theorem valid_pointer_extends: - forall m1 m2 b ofs, - extends m1 m2 -> valid_pointer m1 b ofs = true -> - valid_pointer m2 b ofs = true. -Proof. - intros. destruct H. - replace ofs with (ofs + 0) by omega. - apply valid_pointer_inj with val_inj_id inject_id m1 b; auto. -Qed. - -(** * The ``less defined than'' relation over memory states *) - -(** A memory state [m1] is less defined than [m2] if, for all addresses, - the value [v1] read in [m1] at this address is less defined than - the value [v2] read in [m2], that is, either [v1 = v2] or [v1 = Vundef]. *) - -Definition val_inj_lessdef (mi: meminj) (v1 v2: val) : Prop := - Val.lessdef v1 v2. - -Definition lessdef (m1 m2: mem) : Prop := - nextblock m1 = nextblock m2 /\ - mem_inj val_inj_lessdef inject_id m1 m2. - -Lemma lessdef_refl: - forall m, lessdef m m. -Proof. - intros; split. auto. - red; intros. unfold inject_id in H. inv H. - exists v1; split. replace (ofs + 0) with ofs by omega. auto. - red. constructor. -Qed. - -Lemma load_lessdef: - forall m1 m2 chunk b ofs v1, - lessdef m1 m2 -> load chunk m1 b ofs = Some v1 -> - exists v2, load chunk m2 b ofs = Some v2 /\ Val.lessdef v1 v2. -Proof. - intros. destruct H. - exploit H1; eauto. unfold inject_id. eauto. - intros [v2 [LOAD INJ]]. exists v2; split. - replace ofs with (ofs + 0) by omega. auto. - auto. -Qed. - -Lemma loadv_lessdef: - forall m1 m2 chunk addr1 addr2 v1, - lessdef m1 m2 -> Val.lessdef addr1 addr2 -> - loadv chunk m1 addr1 = Some v1 -> - exists v2, loadv chunk m2 addr2 = Some v2 /\ Val.lessdef v1 v2. -Proof. - intros. inv H0. - destruct addr2; simpl in *; try discriminate. - eapply load_lessdef; eauto. - simpl in H1; discriminate. -Qed. - -Lemma store_lessdef: - forall m1 m2 chunk b ofs v1 v2 m1', - lessdef m1 m2 -> Val.lessdef v1 v2 -> - store chunk m1 b ofs v1 = Some m1' -> - exists m2', store chunk m2 b ofs v2 = Some m2' /\ lessdef m1' m2'. -Proof. - intros. destruct H. - exploit store_mapped_inj; eauto. - unfold val_inj_lessdef; intros; constructor. - red; unfold inject_id; intros. inv H4. inv H5. auto. - unfold inject_id; eauto. - unfold val_inj_lessdef; intros. - apply Val.load_result_lessdef. eexact H0. - intros [m2' [STORE MINJ]]. - exists m2'; split. replace ofs with (ofs + 0) by omega. auto. - split. - rewrite (nextblock_store _ _ _ _ _ _ H1). - rewrite (nextblock_store _ _ _ _ _ _ STORE). - auto. - auto. -Qed. - -Lemma storev_lessdef: - forall m1 m2 chunk addr1 v1 addr2 v2 m1', - lessdef m1 m2 -> Val.lessdef addr1 addr2 -> Val.lessdef v1 v2 -> - storev chunk m1 addr1 v1 = Some m1' -> - exists m2', storev chunk m2 addr2 v2 = Some m2' /\ lessdef m1' m2'. -Proof. - intros. inv H0. - destruct addr2; simpl in H2; try discriminate. - simpl. eapply store_lessdef; eauto. - discriminate. -Qed. - -Lemma alloc_lessdef: - forall m1 m2 lo hi b1 m1' b2 m2', - lessdef m1 m2 -> alloc m1 lo hi = (m1', b1) -> alloc m2 lo hi = (m2', b2) -> - b1 = b2 /\ lessdef m1' m2'. -Proof. - intros. destruct H. - assert (b1 = b2). - transitivity (nextblock m1). eapply alloc_result; eauto. - symmetry. rewrite H. eapply alloc_result; eauto. - subst b2. split. auto. split. - rewrite (nextblock_alloc _ _ _ _ _ H0). - rewrite (nextblock_alloc _ _ _ _ _ H1). - congruence. - eapply alloc_parallel_inj; eauto. - unfold val_inj_lessdef; auto. - unfold inject_id; eauto. - omega. omega. - red; intros. apply Zdivide_0. -Qed. - -Lemma free_lessdef: - forall m1 m2 b, lessdef m1 m2 -> lessdef (free m1 b) (free m2 b). -Proof. - intros. destruct H. split. - simpl; auto. - eapply free_parallel_inj; eauto. - unfold inject_id. eauto. - unfold inject_id; intros. congruence. -Qed. - -Lemma free_left_lessdef: - forall m1 m2 b, - lessdef m1 m2 -> lessdef (free m1 b) m2. -Proof. - intros. destruct H. split. - rewrite <- H. auto. - apply free_left_inj; auto. -Qed. - -Lemma free_right_lessdef: - forall m1 m2 b, - lessdef m1 m2 -> low_bound m1 b >= high_bound m1 b -> - lessdef m1 (free m2 b). -Proof. - intros. destruct H. unfold lessdef. split. - rewrite H. auto. - apply free_right_inj; auto. intros. unfold inject_id in H2. inv H2. - red; intro. inv H2. generalize (size_chunk_pos chunk); intro. omega. -Qed. - -Lemma valid_block_lessdef: - forall m1 m2 b, lessdef m1 m2 -> valid_block m1 b -> valid_block m2 b. -Proof. - unfold valid_block. intros. destruct H. rewrite <- H; auto. -Qed. - -Lemma valid_pointer_lessdef: - forall m1 m2 b ofs, - lessdef m1 m2 -> valid_pointer m1 b ofs = true -> valid_pointer m2 b ofs = true. -Proof. - intros. destruct H. - replace ofs with (ofs + 0) by omega. - apply valid_pointer_inj with val_inj_lessdef inject_id m1 b; auto. -Qed. - -(** ** Memory injections *) - -(** A memory injection [f] is a function from addresses to either [None] - or [Some] of an address and an offset. It defines a correspondence - between the blocks of two memory states [m1] and [m2]: -- if [f b = None], the block [b] of [m1] has no equivalent in [m2]; -- if [f b = Some(b', ofs)], the block [b] of [m2] corresponds to - a sub-block at offset [ofs] of the block [b'] in [m2]. -*) - -(** A memory injection defines a relation between values that is the - identity relation, except for pointer values which are shifted - as prescribed by the memory injection. *) - -Inductive val_inject (mi: meminj): val -> val -> Prop := - | val_inject_int: - forall i, val_inject mi (Vint i) (Vint i) - | val_inject_float: - forall f, val_inject mi (Vfloat f) (Vfloat f) - | val_inject_ptr: - forall b1 ofs1 b2 ofs2 x, - mi b1 = Some (b2, x) -> - ofs2 = Int.add ofs1 (Int.repr x) -> - val_inject mi (Vptr b1 ofs1) (Vptr b2 ofs2) - | val_inject_undef: forall v, - val_inject mi Vundef v. - -Hint Resolve val_inject_int val_inject_float val_inject_ptr - val_inject_undef. - -Inductive val_list_inject (mi: meminj): list val -> list val-> Prop:= - | val_nil_inject : - val_list_inject mi nil nil - | val_cons_inject : forall v v' vl vl' , - val_inject mi v v' -> val_list_inject mi vl vl'-> - val_list_inject mi (v :: vl) (v' :: vl'). - -Hint Resolve val_nil_inject val_cons_inject. - -(** A memory state [m1] injects into another memory state [m2] via the - memory injection [f] if the following conditions hold: -- loads in [m1] must have matching loads in [m2] in the sense - of the [mem_inj] predicate; -- unallocated blocks in [m1] must be mapped to [None] by [f]; -- if [f b = Some(b', delta)], [b'] must be valid in [m2]; -- distinct blocks in [m1] are mapped to non-overlapping sub-blocks in [m2]; -- the sizes of [m2]'s blocks are representable with signed machine integers; -- the offsets [delta] are representable with signed machine integers. -*) - -Record mem_inject (f: meminj) (m1 m2: mem) : Prop := - mk_mem_inject { - mi_inj: - mem_inj val_inject f m1 m2; - mi_freeblocks: - forall b, ~(valid_block m1 b) -> f b = None; - mi_mappedblocks: - forall b b' delta, f b = Some(b', delta) -> valid_block m2 b'; - mi_no_overlap: - meminj_no_overlap f m1; - mi_range_1: - forall b b' delta, - f b = Some(b', delta) -> - Int.min_signed <= delta <= Int.max_signed; - mi_range_2: - forall b b' delta, - f b = Some(b', delta) -> - delta = 0 \/ (Int.min_signed <= low_bound m2 b' /\ high_bound m2 b' <= Int.max_signed) - }. - - -(** The following lemmas establish the absence of machine integer overflow - during address computations. *) - -Lemma address_inject: - forall f m1 m2 chunk b1 ofs1 b2 delta, - mem_inject f m1 m2 -> - valid_access m1 chunk b1 (Int.signed ofs1) -> - f b1 = Some (b2, delta) -> - Int.signed (Int.add ofs1 (Int.repr delta)) = Int.signed ofs1 + delta. -Proof. - intros. inversion H. - elim (mi_range_4 _ _ _ H1); intro. - (* delta = 0 *) - subst delta. change (Int.repr 0) with Int.zero. - rewrite Int.add_zero. omega. - (* delta <> 0 *) - rewrite Int.add_signed. - repeat rewrite Int.signed_repr. auto. - eauto. - assert (valid_access m2 chunk b2 (Int.signed ofs1 + delta)). - eapply valid_access_inj; eauto. - inv H3. generalize (size_chunk_pos chunk); omega. - eauto. -Qed. - -Lemma valid_pointer_inject_no_overflow: - forall f m1 m2 b ofs b' x, - mem_inject f m1 m2 -> - valid_pointer m1 b (Int.signed ofs) = true -> - f b = Some(b', x) -> - Int.min_signed <= Int.signed ofs + Int.signed (Int.repr x) <= Int.max_signed. -Proof. - intros. inv H. rewrite valid_pointer_valid_access in H0. - assert (valid_access m2 Mint8unsigned b' (Int.signed ofs + x)). - eapply valid_access_inj; eauto. - inv H. change (size_chunk Mint8unsigned) with 1 in H4. - rewrite Int.signed_repr; eauto. - exploit mi_range_4; eauto. intros [A | [A B]]. - subst x. rewrite Zplus_0_r. apply Int.signed_range. - omega. -Qed. - -Lemma valid_pointer_inject: - forall f m1 m2 b ofs b' ofs', - mem_inject f m1 m2 -> - valid_pointer m1 b (Int.signed ofs) = true -> - val_inject f (Vptr b ofs) (Vptr b' ofs') -> - valid_pointer m2 b' (Int.signed ofs') = true. -Proof. - intros. inv H1. - exploit valid_pointer_inject_no_overflow; eauto. intro NOOV. - inv H. rewrite Int.add_signed. rewrite Int.signed_repr; auto. - rewrite Int.signed_repr; eauto. - eapply valid_pointer_inj; eauto. -Qed. - -Lemma different_pointers_inject: - forall f m m' b1 ofs1 b2 ofs2 b1' delta1 b2' delta2, - mem_inject f m m' -> - b1 <> b2 -> - valid_pointer m b1 (Int.signed ofs1) = true -> - valid_pointer m b2 (Int.signed ofs2) = true -> - f b1 = Some (b1', delta1) -> - f b2 = Some (b2', delta2) -> - b1' <> b2' \/ - Int.signed (Int.add ofs1 (Int.repr delta1)) <> - Int.signed (Int.add ofs2 (Int.repr delta2)). -Proof. - intros. - rewrite valid_pointer_valid_access in H1. - rewrite valid_pointer_valid_access in H2. - rewrite (address_inject _ _ _ _ _ _ _ _ H H1 H3). - rewrite (address_inject _ _ _ _ _ _ _ _ H H2 H4). - inv H1. simpl in H7. inv H2. simpl in H10. - exploit (mi_no_overlap _ _ _ H); eauto. - intros [A | [A | [A | [A | A]]]]. - auto. omegaContradiction. omegaContradiction. - right. omega. right. omega. -Qed. - -(** Relation between injections and loads. *) - -Lemma load_inject: - forall f m1 m2 chunk b1 ofs b2 delta v1, - mem_inject f m1 m2 -> - load chunk m1 b1 ofs = Some v1 -> - f b1 = Some (b2, delta) -> - exists v2, load chunk m2 b2 (ofs + delta) = Some v2 /\ val_inject f v1 v2. -Proof. - intros. inversion H. - eapply mi_inj0; eauto. -Qed. - -Lemma loadv_inject: - forall f m1 m2 chunk a1 a2 v1, - mem_inject f m1 m2 -> - loadv chunk m1 a1 = Some v1 -> - val_inject f a1 a2 -> - exists v2, loadv chunk m2 a2 = Some v2 /\ val_inject f v1 v2. -Proof. - intros. inv H1; simpl in H0; try discriminate. - exploit load_inject; eauto. intros [v2 [LOAD INJ]]. - exists v2; split; auto. simpl. - replace (Int.signed (Int.add ofs1 (Int.repr x))) - with (Int.signed ofs1 + x). - auto. symmetry. eapply address_inject; eauto with mem. -Qed. - -(** Relation between injections and stores. *) - -Inductive val_content_inject (f: meminj): memory_chunk -> val -> val -> Prop := - | val_content_inject_base: - forall chunk v1 v2, - val_inject f v1 v2 -> - val_content_inject f chunk v1 v2 - | val_content_inject_8: - forall chunk n1 n2, - chunk = Mint8unsigned \/ chunk = Mint8signed -> - Int.zero_ext 8 n1 = Int.zero_ext 8 n2 -> - val_content_inject f chunk (Vint n1) (Vint n2) - | val_content_inject_16: - forall chunk n1 n2, - chunk = Mint16unsigned \/ chunk = Mint16signed -> - Int.zero_ext 16 n1 = Int.zero_ext 16 n2 -> - val_content_inject f chunk (Vint n1) (Vint n2) - | val_content_inject_32: - forall f1 f2, - Float.singleoffloat f1 = Float.singleoffloat f2 -> - val_content_inject f Mfloat32 (Vfloat f1) (Vfloat f2). - -Hint Resolve val_content_inject_base. - -Lemma load_result_inject: - forall f chunk v1 v2 chunk', - val_content_inject f chunk v1 v2 -> - size_chunk chunk = size_chunk chunk' -> - val_inject f (Val.load_result chunk' v1) (Val.load_result chunk' v2). -Proof. - intros. inv H; simpl. - inv H1; destruct chunk'; simpl; econstructor; eauto. - - elim H1; intro; subst chunk; - destruct chunk'; simpl in H0; try discriminate; simpl. - replace (Int.sign_ext 8 n1) with (Int.sign_ext 8 n2). - constructor. apply Int.sign_ext_equal_if_zero_equal; auto. compute; auto. - rewrite H2. constructor. - replace (Int.sign_ext 8 n1) with (Int.sign_ext 8 n2). - constructor. apply Int.sign_ext_equal_if_zero_equal; auto. compute; auto. - rewrite H2. constructor. - - elim H1; intro; subst chunk; - destruct chunk'; simpl in H0; try discriminate; simpl. - replace (Int.sign_ext 16 n1) with (Int.sign_ext 16 n2). - constructor. apply Int.sign_ext_equal_if_zero_equal; auto. compute; auto. - rewrite H2. constructor. - replace (Int.sign_ext 16 n1) with (Int.sign_ext 16 n2). - constructor. apply Int.sign_ext_equal_if_zero_equal; auto. compute; auto. - rewrite H2. constructor. - - destruct chunk'; simpl in H0; try discriminate; simpl. - constructor. rewrite H1; constructor. -Qed. - -Lemma store_mapped_inject_1 : - forall f chunk m1 b1 ofs v1 n1 m2 b2 delta v2, - mem_inject f m1 m2 -> - store chunk m1 b1 ofs v1 = Some n1 -> - f b1 = Some (b2, delta) -> - val_content_inject f chunk v1 v2 -> - exists n2, - store chunk m2 b2 (ofs + delta) v2 = Some n2 - /\ mem_inject f n1 n2. -Proof. - intros. inversion H. - exploit store_mapped_inj; eauto. - intros; constructor. - intros. apply load_result_inject with chunk; eauto. - intros [n2 [STORE MINJ]]. - exists n2; split. auto. constructor. - (* inj *) - auto. - (* freeblocks *) - intros. apply mi_freeblocks0. red; intro. elim H3. eauto with mem. - (* mappedblocks *) - intros. eauto with mem. - (* no_overlap *) - red; intros. - repeat rewrite (low_bound_store _ _ _ _ _ _ H0). - repeat rewrite (high_bound_store _ _ _ _ _ _ H0). - eapply mi_no_overlap0; eauto. - (* range *) - auto. - intros. - repeat rewrite (low_bound_store _ _ _ _ _ _ STORE). - repeat rewrite (high_bound_store _ _ _ _ _ _ STORE). - eapply mi_range_4; eauto. -Qed. - -Lemma store_mapped_inject: - forall f chunk m1 b1 ofs v1 n1 m2 b2 delta v2, - mem_inject f m1 m2 -> - store chunk m1 b1 ofs v1 = Some n1 -> - f b1 = Some (b2, delta) -> - val_inject f v1 v2 -> - exists n2, - store chunk m2 b2 (ofs + delta) v2 = Some n2 - /\ mem_inject f n1 n2. -Proof. - intros. eapply store_mapped_inject_1; eauto. -Qed. - -Lemma store_unmapped_inject: - forall f chunk m1 b1 ofs v1 n1 m2, - mem_inject f m1 m2 -> - store chunk m1 b1 ofs v1 = Some n1 -> - f b1 = None -> - mem_inject f n1 m2. -Proof. - intros. inversion H. - constructor. - (* inj *) - eapply store_unmapped_inj; eauto. - (* freeblocks *) - intros. apply mi_freeblocks0. red; intros; elim H2; eauto with mem. - (* mappedblocks *) - intros. eapply mi_mappedblocks0; eauto with mem. - (* no_overlap *) - red; intros. - repeat rewrite (low_bound_store _ _ _ _ _ _ H0). - repeat rewrite (high_bound_store _ _ _ _ _ _ H0). - eapply mi_no_overlap0; eauto. - (* range *) - auto. auto. -Qed. - -Lemma storev_mapped_inject_1: - forall f chunk m1 a1 v1 n1 m2 a2 v2, - mem_inject f m1 m2 -> - storev chunk m1 a1 v1 = Some n1 -> - val_inject f a1 a2 -> - val_content_inject f chunk v1 v2 -> - exists n2, - storev chunk m2 a2 v2 = Some n2 /\ mem_inject f n1 n2. -Proof. - intros. inv H1; simpl in H0; try discriminate. - simpl. replace (Int.signed (Int.add ofs1 (Int.repr x))) - with (Int.signed ofs1 + x). - eapply store_mapped_inject_1; eauto. - symmetry. eapply address_inject; eauto with mem. -Qed. - -Lemma storev_mapped_inject: - forall f chunk m1 a1 v1 n1 m2 a2 v2, - mem_inject f m1 m2 -> - storev chunk m1 a1 v1 = Some n1 -> - val_inject f a1 a2 -> - val_inject f v1 v2 -> - exists n2, - storev chunk m2 a2 v2 = Some n2 /\ mem_inject f n1 n2. -Proof. - intros. eapply storev_mapped_inject_1; eauto. -Qed. - -(** Relation between injections and [free] *) - -Lemma meminj_no_overlap_free: - forall mi m b, - meminj_no_overlap mi m -> - meminj_no_overlap mi (free m b). -Proof. - intros; red; intros. - assert (low_bound (free m b) b >= high_bound (free m b) b). - rewrite low_bound_free_same; rewrite high_bound_free_same; auto. - omega. - destruct (eq_block b1 b); destruct (eq_block b2 b); subst; auto. - repeat (rewrite low_bound_free; auto). - repeat (rewrite high_bound_free; auto). -Qed. - -Lemma meminj_no_overlap_free_list: - forall mi m bl, - meminj_no_overlap mi m -> - meminj_no_overlap mi (free_list m bl). -Proof. - induction bl; simpl; intros. auto. - apply meminj_no_overlap_free. auto. -Qed. - -Lemma free_inject: - forall f m1 m2 l b, - (forall b1 delta, f b1 = Some(b, delta) -> In b1 l) -> - mem_inject f m1 m2 -> - mem_inject f (free_list m1 l) (free m2 b). -Proof. - intros. inversion H0. constructor. - (* inj *) - apply free_right_inj. apply free_list_left_inj. auto. - intros; red; intros. - elim (valid_access_free_list_inv _ _ _ _ _ H2); intros. - elim H3; eauto. - (* freeblocks *) - intros. apply mi_freeblocks0. red; intro; elim H1. - apply valid_block_free_list_1; auto. - (* mappedblocks *) - intros. apply valid_block_free_1. eauto. - (* overlap *) - apply meminj_no_overlap_free_list; auto. - (* range *) - auto. - intros. destruct (eq_block b' b). subst b'. - rewrite low_bound_free_same; rewrite high_bound_free_same. - right; compute; intuition congruence. - rewrite low_bound_free; auto. rewrite high_bound_free; auto. - eauto. -Qed. - -(** Monotonicity properties of memory injections. *) - -Definition inject_incr (f1 f2: meminj) : Prop := - forall b, f1 b = f2 b \/ f1 b = None. - -Lemma inject_incr_refl : - forall f , inject_incr f f . -Proof. unfold inject_incr . intros. left . auto . Qed. - -Lemma inject_incr_trans : - forall f1 f2 f3, - inject_incr f1 f2 -> inject_incr f2 f3 -> inject_incr f1 f3 . -Proof . - unfold inject_incr; intros. - generalize (H b); generalize (H0 b); intuition congruence. -Qed. - -Lemma val_inject_incr: - forall f1 f2 v v', - inject_incr f1 f2 -> - val_inject f1 v v' -> - val_inject f2 v v'. -Proof. - intros. inversion H0. - constructor. - constructor. - elim (H b1); intro. - apply val_inject_ptr with x. congruence. auto. - congruence. - constructor. -Qed. - -Lemma val_list_inject_incr: - forall f1 f2 vl vl' , - inject_incr f1 f2 -> val_list_inject f1 vl vl' -> - val_list_inject f2 vl vl'. -Proof. - induction vl; intros; inv H0. auto. - constructor. eapply val_inject_incr; eauto. auto. -Qed. - -Hint Resolve inject_incr_refl val_inject_incr val_list_inject_incr. - -(** Properties of injections and allocations. *) - -Definition extend_inject - (b: block) (x: option (block * Z)) (f: meminj) : meminj := - fun (b': block) => if zeq b' b then x else f b'. - -Lemma extend_inject_incr: - forall f b x, - f b = None -> - inject_incr f (extend_inject b x f). -Proof. - intros; red; intros. unfold extend_inject. - destruct (zeq b0 b). subst b0; auto. auto. -Qed. - -Lemma alloc_right_inject: - forall f m1 m2 lo hi m2' b, - mem_inject f m1 m2 -> - alloc m2 lo hi = (m2', b) -> - mem_inject f m1 m2'. -Proof. - intros. inversion H. constructor. - eapply alloc_right_inj; eauto. - auto. - intros. eauto with mem. - auto. - auto. - intros. replace (low_bound m2' b') with (low_bound m2 b'). - replace (high_bound m2' b') with (high_bound m2 b'). - eauto. - symmetry. eapply high_bound_alloc_other; eauto. - symmetry. eapply low_bound_alloc_other; eauto. -Qed. - -Lemma alloc_unmapped_inject: - forall f m1 m2 lo hi m1' b, - mem_inject f m1 m2 -> - alloc m1 lo hi = (m1', b) -> - mem_inject (extend_inject b None f) m1' m2 /\ - inject_incr f (extend_inject b None f). -Proof. - intros. inversion H. - assert (inject_incr f (extend_inject b None f)). - apply extend_inject_incr. apply mi_freeblocks0. eauto with mem. - split; auto. constructor. - (* inj *) - eapply alloc_left_unmapped_inj; eauto. - red; intros. unfold extend_inject in H2. - destruct (zeq b1 b). congruence. - exploit mi_inj0; eauto. intros [v2 [LOAD VINJ]]. - exists v2; split. auto. - apply val_inject_incr with f; auto. - unfold extend_inject. apply zeq_true. - (* freeblocks *) - intros. unfold extend_inject. destruct (zeq b0 b). auto. - apply mi_freeblocks0; red; intro. elim H2. eauto with mem. - (* mappedblocks *) - intros. unfold extend_inject in H2. destruct (zeq b0 b). - discriminate. eauto. - (* overlap *) - red; unfold extend_inject, update; intros. - repeat rewrite (low_bound_alloc _ _ _ _ _ H0). - repeat rewrite (high_bound_alloc _ _ _ _ _ H0). - destruct (zeq b1 b); try discriminate. - destruct (zeq b2 b); try discriminate. - eauto. - (* range *) - unfold extend_inject; intros. - destruct (zeq b0 b). discriminate. eauto. - unfold extend_inject; intros. - destruct (zeq b0 b). discriminate. eauto. -Qed. - -Lemma alloc_mapped_inject: - forall f m1 m2 lo hi m1' b b' ofs, - mem_inject f m1 m2 -> - alloc m1 lo hi = (m1', b) -> - valid_block m2 b' -> - Int.min_signed <= ofs <= Int.max_signed -> - Int.min_signed <= low_bound m2 b' -> - high_bound m2 b' <= Int.max_signed -> - low_bound m2 b' <= lo + ofs -> - hi + ofs <= high_bound m2 b' -> - inj_offset_aligned ofs (hi-lo) -> - (forall b0 ofs0, - f b0 = Some (b', ofs0) -> - high_bound m1 b0 + ofs0 <= lo + ofs \/ - hi + ofs <= low_bound m1 b0 + ofs0) -> - mem_inject (extend_inject b (Some (b', ofs)) f) m1' m2 /\ - inject_incr f (extend_inject b (Some (b', ofs)) f). -Proof. - intros. inversion H. - assert (inject_incr f (extend_inject b (Some (b', ofs)) f)). - apply extend_inject_incr. apply mi_freeblocks0. eauto with mem. - split; auto. - constructor. - (* inj *) - eapply alloc_left_mapped_inj; eauto. - red; intros. unfold extend_inject in H10. - rewrite zeq_false in H10. - exploit mi_inj0; eauto. intros [v2 [LOAD VINJ]]. - exists v2; split. auto. eapply val_inject_incr; eauto. - eauto with mem. - unfold extend_inject. apply zeq_true. - (* freeblocks *) - intros. unfold extend_inject. rewrite zeq_false. - apply mi_freeblocks0. red; intro. elim H10; eauto with mem. - apply sym_not_equal; eauto with mem. - (* mappedblocks *) - unfold extend_inject; intros. - destruct (zeq b0 b). inv H10. auto. eauto. - (* overlap *) - red; unfold extend_inject, update; intros. - repeat rewrite (low_bound_alloc _ _ _ _ _ H0). - repeat rewrite (high_bound_alloc _ _ _ _ _ H0). - destruct (zeq b1 b); [inv H11|idtac]; - (destruct (zeq b2 b); [inv H12|idtac]). - congruence. - destruct (zeq b1' b2'). subst b2'. generalize (H8 _ _ H12). tauto. auto. - destruct (zeq b1' b2'). subst b2'. generalize (H8 _ _ H11). tauto. auto. - eauto. - (* range *) - unfold extend_inject; intros. - destruct (zeq b0 b). inv H10. auto. eauto. - unfold extend_inject; intros. - destruct (zeq b0 b). inv H10. auto. eauto. -Qed. - -Lemma alloc_parallel_inject: - forall f m1 m2 lo hi m1' m2' b1 b2, - mem_inject f m1 m2 -> - alloc m1 lo hi = (m1', b1) -> - alloc m2 lo hi = (m2', b2) -> - Int.min_signed <= lo -> hi <= Int.max_signed -> - mem_inject (extend_inject b1 (Some(b2, 0)) f) m1' m2' /\ - inject_incr f (extend_inject b1 (Some(b2, 0)) f). -Proof. - intros. - eapply alloc_mapped_inject; eauto. - eapply alloc_right_inject; eauto. - eauto with mem. - compute; intuition congruence. - rewrite (low_bound_alloc_same _ _ _ _ _ H1). auto. - rewrite (high_bound_alloc_same _ _ _ _ _ H1). auto. - rewrite (low_bound_alloc_same _ _ _ _ _ H1). omega. - rewrite (high_bound_alloc_same _ _ _ _ _ H1). omega. - red; intros. apply Zdivide_0. - intros. elimtype False. inv H. - exploit mi_mappedblocks0; eauto. - change (~ valid_block m2 b2). eauto with mem. -Qed. - -Definition meminj_init (m: mem) : meminj := - fun (b: block) => if zlt b m.(nextblock) then Some(b, 0) else None. - -Definition mem_inject_neutral (m: mem) : Prop := - forall f chunk b ofs v, - load chunk m b ofs = Some v -> val_inject f v v. - -Lemma init_inject: - forall m, - mem_inject_neutral m -> - mem_inject (meminj_init m) m m. -Proof. - intros; constructor. - (* inj *) - red; intros. unfold meminj_init in H0. - destruct (zlt b1 (nextblock m)); inversion H0. - subst b2 delta. exists v1; split. - rewrite Zplus_0_r. auto. eapply H; eauto. - (* free blocks *) - unfold valid_block, meminj_init; intros. - apply zlt_false. omega. - (* mapped blocks *) - unfold valid_block, meminj_init; intros. - destruct (zlt b (nextblock m)); inversion H0. subst b'; auto. - (* overlap *) - red; unfold meminj_init; intros. - destruct (zlt b1 (nextblock m)); inversion H1. - destruct (zlt b2 (nextblock m)); inversion H2. - left; congruence. - (* range *) - unfold meminj_init; intros. - destruct (zlt b (nextblock m)); inversion H0. subst delta. - compute; intuition congruence. - unfold meminj_init; intros. - destruct (zlt b (nextblock m)); inversion H0. subst delta. - auto. -Qed. - -Remark getN_setN_inject: - forall f m v n1 p1 n2 p2, - val_inject f (getN n2 p2 m) (getN n2 p2 m) -> - val_inject f v v -> - val_inject f (getN n2 p2 (setN n1 p1 v m)) - (getN n2 p2 (setN n1 p1 v m)). -Proof. - intros. - destruct (getN_setN_characterization m v n1 p1 n2 p2) - as [A | [A | A]]; rewrite A; auto. -Qed. - -Remark getN_contents_init_data_inject: - forall f n ofs id pos, - val_inject f (getN n ofs (contents_init_data pos id)) - (getN n ofs (contents_init_data pos id)). -Proof. - induction id; simpl; intros. - repeat rewrite getN_init. constructor. - destruct a; auto; apply getN_setN_inject; auto. -Qed. - -Lemma alloc_init_data_neutral: - forall m id m' b, - mem_inject_neutral m -> - alloc_init_data m id = (m', b) -> - mem_inject_neutral m'. -Proof. - intros. injection H0; intros A B. - red; intros. - exploit load_inv; eauto. intros [C D]. - rewrite <- B in D; simpl in D. rewrite A in D. - unfold update in D. destruct (zeq b0 b). - subst b0. rewrite D. simpl. - apply load_result_inject with chunk. constructor. - apply getN_contents_init_data_inject. auto. - apply H with chunk b0 ofs. unfold load. - rewrite in_bounds_true. congruence. - inversion C. constructor. - generalize H2. unfold valid_block. rewrite <- B; simpl. - rewrite A. unfold block in n; intros. omega. - replace (low_bound m b0) with (low_bound m' b0). auto. - unfold low_bound; rewrite <- B; simpl; rewrite A. rewrite update_o; auto. - replace (high_bound m b0) with (high_bound m' b0). auto. - unfold high_bound; rewrite <- B; simpl; rewrite A. rewrite update_o; auto. - auto. -Qed. - -(** ** Memory shifting *) - -(** A special case of memory injection where blocks are not coalesced: - each source block injects in a distinct target block. *) - -Definition memshift := block -> option Z. - -Definition meminj_of_shift (mi: memshift) : meminj := - fun b => match mi b with None => None | Some x => Some (b, x) end. - -Definition val_shift (mi: memshift) (v1 v2: val): Prop := - val_inject (meminj_of_shift mi) v1 v2. - -Record mem_shift (f: memshift) (m1 m2: mem) : Prop := - mk_mem_shift { - ms_inj: - mem_inj val_inject (meminj_of_shift f) m1 m2; - ms_samedomain: - nextblock m1 = nextblock m2; - ms_domain: - forall b, match f b with Some _ => b < nextblock m1 | None => b >= nextblock m1 end; - ms_range_1: - forall b delta, - f b = Some delta -> - Int.min_signed <= delta <= Int.max_signed; - ms_range_2: - forall b delta, - f b = Some delta -> - Int.min_signed <= low_bound m2 b /\ high_bound m2 b <= Int.max_signed - }. - -(** The following lemmas establish the absence of machine integer overflow - during address computations. *) - -Lemma address_shift: - forall f m1 m2 chunk b ofs1 delta, - mem_shift f m1 m2 -> - valid_access m1 chunk b (Int.signed ofs1) -> - f b = Some delta -> - Int.signed (Int.add ofs1 (Int.repr delta)) = Int.signed ofs1 + delta. -Proof. - intros. inversion H. - elim (ms_range_4 _ _ H1); intros. - rewrite Int.add_signed. - repeat rewrite Int.signed_repr. auto. - eauto. - assert (valid_access m2 chunk b (Int.signed ofs1 + delta)). - eapply valid_access_inj with (mi := meminj_of_shift f); eauto. - unfold meminj_of_shift. rewrite H1; auto. - inv H4. generalize (size_chunk_pos chunk); omega. - eauto. -Qed. - -Lemma valid_pointer_shift_no_overflow: - forall f m1 m2 b ofs x, - mem_shift f m1 m2 -> - valid_pointer m1 b (Int.signed ofs) = true -> - f b = Some x -> - Int.min_signed <= Int.signed ofs + Int.signed (Int.repr x) <= Int.max_signed. -Proof. - intros. inv H. rewrite valid_pointer_valid_access in H0. - assert (valid_access m2 Mint8unsigned b (Int.signed ofs + x)). - eapply valid_access_inj with (mi := meminj_of_shift f); eauto. - unfold meminj_of_shift. rewrite H1; auto. - inv H. change (size_chunk Mint8unsigned) with 1 in H4. - rewrite Int.signed_repr; eauto. - exploit ms_range_4; eauto. intros [A B]. omega. -Qed. - -Lemma valid_pointer_shift: - forall f m1 m2 b ofs b' ofs', - mem_shift f m1 m2 -> - valid_pointer m1 b (Int.signed ofs) = true -> - val_shift f (Vptr b ofs) (Vptr b' ofs') -> - valid_pointer m2 b' (Int.signed ofs') = true. -Proof. - intros. unfold val_shift in H1. inv H1. - assert (f b = Some x). - unfold meminj_of_shift in H5. destruct (f b); congruence. - exploit valid_pointer_shift_no_overflow; eauto. intro NOOV. - inv H. rewrite Int.add_signed. rewrite Int.signed_repr; auto. - rewrite Int.signed_repr; eauto. - eapply valid_pointer_inj; eauto. -Qed. - -(** Relation between shifts and loads. *) - -Lemma load_shift: - forall f m1 m2 chunk b ofs delta v1, - mem_shift f m1 m2 -> - load chunk m1 b ofs = Some v1 -> - f b = Some delta -> - exists v2, load chunk m2 b (ofs + delta) = Some v2 /\ val_shift f v1 v2. -Proof. - intros. inversion H. - unfold val_shift. eapply ms_inj0; eauto. - unfold meminj_of_shift; rewrite H1; auto. -Qed. - -Lemma loadv_shift: - forall f m1 m2 chunk a1 a2 v1, - mem_shift f m1 m2 -> - loadv chunk m1 a1 = Some v1 -> - val_shift f a1 a2 -> - exists v2, loadv chunk m2 a2 = Some v2 /\ val_shift f v1 v2. -Proof. - intros. unfold val_shift in H1. inv H1; simpl in H0; try discriminate. - generalize H2. unfold meminj_of_shift. caseEq (f b1); intros; inv H3. - exploit load_shift; eauto. intros [v2 [LOAD INJ]]. - exists v2; split; auto. simpl. - replace (Int.signed (Int.add ofs1 (Int.repr x))) - with (Int.signed ofs1 + x). - auto. symmetry. eapply address_shift; eauto with mem. -Qed. - -(** Relation between shifts and stores. *) - -Lemma store_within_shift: - forall f chunk m1 b ofs v1 n1 m2 delta v2, - mem_shift f m1 m2 -> - store chunk m1 b ofs v1 = Some n1 -> - f b = Some delta -> - val_shift f v1 v2 -> - exists n2, - store chunk m2 b (ofs + delta) v2 = Some n2 - /\ mem_shift f n1 n2. -Proof. - intros. inversion H. - exploit store_mapped_inj; eauto. - intros; constructor. - red. intros until delta2. unfold meminj_of_shift. - destruct (f b1). destruct (f b2). intros. inv H4. inv H5. auto. - congruence. congruence. - unfold meminj_of_shift. rewrite H1. auto. - intros. apply load_result_inject with chunk; eauto. - unfold val_shift in H2. eauto. - intros [n2 [STORE MINJ]]. - exists n2; split. auto. constructor. - (* inj *) - auto. - (* samedomain *) - rewrite (nextblock_store _ _ _ _ _ _ H0). - rewrite (nextblock_store _ _ _ _ _ _ STORE). - auto. - (* domain *) - rewrite (nextblock_store _ _ _ _ _ _ H0). auto. - (* range *) - auto. - intros. - repeat rewrite (low_bound_store _ _ _ _ _ _ STORE). - repeat rewrite (high_bound_store _ _ _ _ _ _ STORE). - eapply ms_range_4; eauto. -Qed. - -Lemma store_outside_shift: - forall f chunk m1 b ofs m2 v m2' delta, - mem_shift f m1 m2 -> - f b = Some delta -> - high_bound m1 b + delta <= ofs - \/ ofs + size_chunk chunk <= low_bound m1 b + delta -> - store chunk m2 b ofs v = Some m2' -> - mem_shift f m1 m2'. -Proof. - intros. inversion H. constructor. - (* inj *) - eapply store_outside_inj; eauto. - unfold meminj_of_shift. intros b' d'. caseEq (f b'); intros; inv H4. - congruence. - (* samedomain *) - rewrite (nextblock_store _ _ _ _ _ _ H2). - auto. - (* domain *) - auto. - (* range *) - auto. - intros. - repeat rewrite (low_bound_store _ _ _ _ _ _ H2). - repeat rewrite (high_bound_store _ _ _ _ _ _ H2). - eapply ms_range_4; eauto. -Qed. - -Lemma storev_shift: - forall f chunk m1 a1 v1 n1 m2 a2 v2, - mem_shift f m1 m2 -> - storev chunk m1 a1 v1 = Some n1 -> - val_shift f a1 a2 -> - val_shift f v1 v2 -> - exists n2, - storev chunk m2 a2 v2 = Some n2 /\ mem_shift f n1 n2. -Proof. - intros. unfold val_shift in H1. inv H1; simpl in H0; try discriminate. - generalize H3. unfold meminj_of_shift. caseEq (f b1); intros; inv H4. - exploit store_within_shift; eauto. intros [n2 [A B]]. - exists n2; split; auto. - unfold storev. - replace (Int.signed (Int.add ofs1 (Int.repr x))) - with (Int.signed ofs1 + x). - auto. symmetry. eapply address_shift; eauto with mem. -Qed. - -(** Relation between shifts and [free]. *) - -Lemma free_shift: - forall f m1 m2 b, - mem_shift f m1 m2 -> - mem_shift f (free m1 b) (free m2 b). -Proof. - intros. inv H. constructor. - (* inj *) - apply free_right_inj. apply free_left_inj; auto. - intros until ofs. unfold meminj_of_shift. caseEq (f b1); intros; inv H0. - apply valid_access_free_2. - (* samedomain *) - simpl. auto. - (* domain *) - simpl. auto. - (* range *) - auto. - intros. destruct (eq_block b0 b). - subst b0. rewrite low_bound_free_same. rewrite high_bound_free_same. - vm_compute; intuition congruence. - rewrite low_bound_free; auto. rewrite high_bound_free; auto. eauto. -Qed. - -(** Relation between shifts and allocation. *) - -Definition shift_incr (f1 f2: memshift) : Prop := - forall b, f1 b = f2 b \/ f1 b = None. - -Remark shift_incr_inject_incr: - forall f1 f2, - shift_incr f1 f2 -> inject_incr (meminj_of_shift f1) (meminj_of_shift f2). -Proof. - intros. unfold meminj_of_shift. red. intros. - elim (H b); intro. rewrite H0. auto. rewrite H0. auto. -Qed. - -Lemma val_shift_incr: - forall f1 f2 v1 v2, - shift_incr f1 f2 -> val_shift f1 v1 v2 -> val_shift f2 v1 v2. -Proof. - unfold val_shift; intros. - apply val_inject_incr with (meminj_of_shift f1). - apply shift_incr_inject_incr. auto. auto. -Qed. - -(*** -Remark mem_inj_incr: - forall f1 f2 m1 m2, - inject_incr f1 f2 -> mem_inj val_inject f1 m1 m2 -> mem_inj val_inject f2 m1 m2. -Proof. - intros; red; intros. - destruct (H b1). rewrite <- H3 in H1. - exploit H0; eauto. intros [v2 [A B]]. - exists v2; split. auto. apply val_inject_incr with f1; auto. - congruence. -***) - -Lemma alloc_shift: - forall f m1 m2 lo1 hi1 m1' b delta lo2 hi2, - mem_shift f m1 m2 -> - alloc m1 lo1 hi1 = (m1', b) -> - lo2 <= lo1 + delta -> hi1 + delta <= hi2 -> - Int.min_signed <= delta <= Int.max_signed -> - Int.min_signed <= lo2 -> hi2 <= Int.max_signed -> - inj_offset_aligned delta (hi1-lo1) -> - exists f', exists m2', - alloc m2 lo2 hi2 = (m2', b) - /\ mem_shift f' m1' m2' - /\ shift_incr f f' - /\ f' b = Some delta. -Proof. - intros. inv H. caseEq (alloc m2 lo2 hi2). intros m2' b' ALLOC2. - assert (b' = b). - rewrite (alloc_result _ _ _ _ _ H0). - rewrite (alloc_result _ _ _ _ _ ALLOC2). - auto. - subst b'. - assert (f b = None). - generalize (ms_domain0 b). - rewrite (alloc_result _ _ _ _ _ H0). - destruct (f (nextblock m1)). - intros. omegaContradiction. - auto. - set (f' := fun (b': block) => if zeq b' b then Some delta else f b'). - assert (shift_incr f f'). - red; unfold f'; intros. - destruct (zeq b0 b); auto. - subst b0. auto. - exists f'; exists m2'. - split. auto. - (* mem_shift *) - split. constructor. - (* inj *) - assert (mem_inj val_inject (meminj_of_shift f') m1 m2). - red; intros. - assert (meminj_of_shift f b1 = Some (b2, delta0)). - rewrite <- H8. unfold meminj_of_shift, f'. - destruct (zeq b1 b); auto. - subst b1. - assert (valid_block m1 b) by eauto with mem. - assert (~valid_block m1 b) by eauto with mem. - contradiction. - exploit ms_inj0; eauto. intros [v2 [A B]]. - exists v2; split; auto. - apply val_inject_incr with (meminj_of_shift f). - apply shift_incr_inject_incr. auto. auto. - eapply alloc_parallel_inj; eauto. - unfold meminj_of_shift, f'. rewrite zeq_true. auto. - (* samedomain *) - rewrite (nextblock_alloc _ _ _ _ _ H0). - rewrite (nextblock_alloc _ _ _ _ _ ALLOC2). - congruence. - (* domain *) - intros. unfold f'. - rewrite (nextblock_alloc _ _ _ _ _ H0). - rewrite (alloc_result _ _ _ _ _ H0). - destruct (zeq b0 (nextblock m1)). omega. - generalize (ms_domain0 b0). destruct (f b0); omega. - (* range *) - unfold f'; intros. destruct (zeq b0 b). congruence. eauto. - unfold f'; intros. - rewrite (low_bound_alloc _ _ _ _ _ ALLOC2). - rewrite (high_bound_alloc _ _ _ _ _ ALLOC2). - destruct (zeq b0 b). auto. eauto. - (* shift_incr *) - split. auto. - (* f' b = delta *) - unfold f'. apply zeq_true. -Qed. - -(** ** Relation between signed and unsigned loads and stores *) - -(** Target processors do not distinguish between signed and unsigned - stores of 8- and 16-bit quantities. We show these are equivalent. *) - -(** Signed 8- and 16-bit stores can be performed like unsigned stores. *) - -Remark in_bounds_equiv: - forall chunk1 chunk2 m b ofs (A: Type) (a1 a2: A), - size_chunk chunk1 = size_chunk chunk2 -> - (if in_bounds m chunk1 b ofs then a1 else a2) = - (if in_bounds m chunk2 b ofs then a1 else a2). -Proof. - intros. destruct (in_bounds m chunk1 b ofs). - rewrite in_bounds_true. auto. eapply valid_access_compat; eauto. - destruct (in_bounds m chunk2 b ofs); auto. - elim n. eapply valid_access_compat with (chunk1 := chunk2); eauto. -Qed. - -Lemma storev_8_signed_unsigned: - forall m a v, - storev Mint8signed m a v = storev Mint8unsigned m a v. -Proof. - intros. unfold storev. destruct a; auto. - unfold store. rewrite (in_bounds_equiv Mint8signed Mint8unsigned). - auto. auto. -Qed. - -Lemma storev_16_signed_unsigned: - forall m a v, - storev Mint16signed m a v = storev Mint16unsigned m a v. -Proof. - intros. unfold storev. destruct a; auto. - unfold store. rewrite (in_bounds_equiv Mint16signed Mint16unsigned). - auto. auto. -Qed. - -(** Likewise, some target processors (e.g. the PowerPC) do not have - a ``load 8-bit signed integer'' instruction. - We show that it can be synthesized as a ``load 8-bit unsigned integer'' - followed by a sign extension. *) - -Lemma loadv_8_signed_unsigned: - forall m a, - loadv Mint8signed m a = option_map (Val.sign_ext 8) (loadv Mint8unsigned m a). -Proof. - intros. unfold Mem.loadv. destruct a; try reflexivity. - unfold load. rewrite (in_bounds_equiv Mint8signed Mint8unsigned). - destruct (in_bounds m Mint8unsigned b (Int.signed i)); auto. - simpl. - destruct (getN 0 (Int.signed i) (contents (blocks m b))); auto. - simpl. rewrite Int.sign_ext_zero_ext. auto. compute; auto. - auto. -Qed. - diff --git a/common/Memdata.v b/common/Memdata.v new file mode 100644 index 0000000..2c5fdb6 --- /dev/null +++ b/common/Memdata.v @@ -0,0 +1,1058 @@ +Require Import Coqlib. +Require Import AST. +Require Import Integers. +Require Import Floats. +Require Import Values. + +(** * Properties of memory chunks *) + +(** Memory reads and writes are performed by quantities called memory chunks, + encoding the type, size and signedness of the chunk being addressed. + The following functions extract the size information from a chunk. *) + +Definition size_chunk (chunk: memory_chunk) : Z := + match chunk with + | Mint8signed => 1 + | Mint8unsigned => 1 + | Mint16signed => 2 + | Mint16unsigned => 2 + | Mint32 => 4 + | Mfloat32 => 4 + | Mfloat64 => 8 + end. + +Lemma size_chunk_pos: + forall chunk, size_chunk chunk > 0. +Proof. + intros. destruct chunk; simpl; omega. +Qed. + +Definition size_chunk_nat (chunk: memory_chunk) : nat := + nat_of_Z(size_chunk chunk). + +Lemma size_chunk_conv: + forall chunk, size_chunk chunk = Z_of_nat (size_chunk_nat chunk). +Proof. + intros. destruct chunk; reflexivity. +Qed. + +Lemma size_chunk_nat_pos: + forall chunk, exists n, size_chunk_nat chunk = S n. +Proof. + intros. + generalize (size_chunk_pos chunk). rewrite size_chunk_conv. + destruct (size_chunk_nat chunk). + simpl; intros; omegaContradiction. + intros; exists n; auto. +Qed. + +(** Memory reads and writes must respect alignment constraints: + the byte offset of the location being addressed should be an exact + multiple of the natural alignment for the chunk being addressed. + This natural alignment is defined by the following + [align_chunk] function. Some target architectures + (e.g. the PowerPC) have no alignment constraints, which we could + reflect by taking [align_chunk chunk = 1]. However, other architectures + have stronger alignment requirements. The following definition is + appropriate for PowerPC and ARM. *) + +Definition align_chunk (chunk: memory_chunk) : Z := + match chunk with + | Mint8signed => 1 + | Mint8unsigned => 1 + | Mint16signed => 2 + | Mint16unsigned => 2 + | _ => 4 + end. + +Lemma align_chunk_pos: + forall chunk, align_chunk chunk > 0. +Proof. + intro. destruct chunk; simpl; omega. +Qed. + +Lemma align_size_chunk_divides: + forall chunk, (align_chunk chunk | size_chunk chunk). +Proof. + intros. destruct chunk; simpl; try apply Zdivide_refl. exists 2; auto. +Qed. + +Lemma align_chunk_compat: + forall chunk1 chunk2, + size_chunk chunk1 = size_chunk chunk2 -> align_chunk chunk1 = align_chunk chunk2. +Proof. + intros chunk1 chunk2. + destruct chunk1; destruct chunk2; simpl; congruence. +Qed. + +(** The type (integer/pointer or float) of a chunk. *) + +Definition type_of_chunk (c: memory_chunk) : typ := + match c with + | Mint8signed => Tint + | Mint8unsigned => Tint + | Mint16signed => Tint + | Mint16unsigned => Tint + | Mint32 => Tint + | Mfloat32 => Tfloat + | Mfloat64 => Tfloat + end. + +(** * Memory values *) + +(** A ``memory value'' is a byte-sized quantity that describes the current + content of a memory cell. It can be either: +- a concrete 8-bit integer; +- a byte-sized fragment of an opaque pointer; +- the special constant [Undef] that represents uninitialized memory. +*) + +(** Values stored in memory cells. *) + +Inductive memval: Type := + | Undef: memval + | Byte: byte -> memval + | Pointer: block -> int -> nat -> memval. + +(** * Encoding and decoding integers *) + +(** We define functions to convert between integers and lists of bytes + according to a given memory chunk. *) + +Parameter big_endian: bool. + +Definition rev_if_le (l: list byte) : list byte := + if big_endian then l else List.rev l. + +Lemma rev_if_le_involutive: + forall l, rev_if_le (rev_if_le l) = l. +Proof. + intros; unfold rev_if_le; destruct big_endian. + auto. + apply List.rev_involutive. +Qed. + +Lemma rev_if_le_length: + forall l, length (rev_if_le l) = length l. +Proof. + intros; unfold rev_if_le; destruct big_endian. + auto. + apply List.rev_length. +Qed. + +Definition encode_int (c: memory_chunk) (x: int) : list byte := + let n := Int.unsigned x in + rev_if_le (match c with + | Mint8signed | Mint8unsigned => + Byte.repr n :: nil + | Mint16signed | Mint16unsigned => + Byte.repr (n/256) :: Byte.repr n :: nil + | Mint32 => + Byte.repr (n/16777216) :: Byte.repr (n/65536) :: Byte.repr (n/256) :: Byte.repr n :: nil + | Mfloat32 => + Byte.zero :: Byte.zero :: Byte.zero :: Byte.zero :: nil + | Mfloat64 => + Byte.zero :: Byte.zero :: Byte.zero :: Byte.zero :: + Byte.zero :: Byte.zero :: Byte.zero :: Byte.zero :: nil + end). + +Definition decode_int (c: memory_chunk) (b: list byte) : int := + match c, rev_if_le b with + | Mint8signed, b1 :: nil => + Int.sign_ext 8 (Int.repr (Byte.unsigned b1)) + | Mint8unsigned, b1 :: nil => + Int.repr (Byte.unsigned b1) + | Mint16signed, b1 :: b2 :: nil => + Int.sign_ext 16 (Int.repr (Byte.unsigned b1 * 256 + Byte.unsigned b2)) + | Mint16unsigned, b1 :: b2 :: nil => + Int.repr (Byte.unsigned b1 * 256 + Byte.unsigned b2) + | Mint32, b1 :: b2 :: b3 :: b4 :: nil => + Int.repr (Byte.unsigned b1 * 16777216 + Byte.unsigned b2 * 65536 + + Byte.unsigned b3 * 256 + Byte.unsigned b4) + | _, _ => Int.zero + end. + +Lemma encode_int_length: + forall chunk n, length(encode_int chunk n) = size_chunk_nat chunk. +Proof. + intros. unfold encode_int. rewrite rev_if_le_length. + destruct chunk; reflexivity. +Qed. + +Lemma decode_encode_int8unsigned: forall n, + decode_int Mint8unsigned (encode_int Mint8unsigned n) = Int.zero_ext 8 n. +Proof. + intros. unfold decode_int, encode_int. rewrite rev_if_le_involutive. + simpl. auto. +Qed. + +Lemma decode_encode_int8signed: forall n, + decode_int Mint8signed (encode_int Mint8signed n) = Int.sign_ext 8 n. +Proof. + intros. unfold decode_int, encode_int. rewrite rev_if_le_involutive. simpl. + change (Int.repr (Int.unsigned n mod Byte.modulus)) + with (Int.zero_ext 8 n). + apply Int.sign_ext_zero_ext. compute; auto. +Qed. + +Remark recombine_16: + forall x, + (x / 256) mod Byte.modulus * 256 + x mod Byte.modulus = x mod (two_p 16). +Proof. + intros. symmetry. apply (Zmod_recombine x 256 256); omega. +Qed. + +Lemma decode_encode_int16unsigned: forall n, + decode_int Mint16unsigned (encode_int Mint16unsigned n) = Int.zero_ext 16 n. +Proof. + intros. unfold decode_int, encode_int. rewrite rev_if_le_involutive. simpl. + rewrite recombine_16. auto. +Qed. + +Lemma decode_encode_int16signed: forall n, + decode_int Mint16signed (encode_int Mint16signed n) = Int.sign_ext 16 n. +Proof. + intros. unfold decode_int, encode_int. rewrite rev_if_le_involutive. simpl. + rewrite recombine_16. + fold (Int.zero_ext 16 n). apply Int.sign_ext_zero_ext. compute; auto. +Qed. + +Remark recombine_32: + forall x, + (x / 16777216) mod Byte.modulus * 16777216 + + (x / 65536) mod Byte.modulus * 65536 + + (x / 256) mod Byte.modulus * 256 + + x mod Byte.modulus = + x mod Int.modulus. +Proof. + intros. change Byte.modulus with 256. + exploit (Zmod_recombine x 65536 65536). omega. omega. intro EQ1. + exploit (Zmod_recombine x 256 256). omega. omega. + change (256 * 256) with 65536. intro EQ2. + exploit (Zmod_recombine (x/65536) 256 256). omega. omega. + rewrite Zdiv_Zdiv. change (65536*256) with 16777216. change (256 * 256) with 65536. + intro EQ3. + change Int.modulus with (65536 * 65536). + rewrite EQ1. rewrite EQ2. rewrite EQ3. omega. + omega. omega. +Qed. + +Lemma decode_encode_int32: forall n, + decode_int Mint32 (encode_int Mint32 n) = n. +Proof. + intros. unfold decode_int, encode_int. rewrite rev_if_le_involutive. simpl. + rewrite recombine_32. + transitivity (Int.repr (Int.unsigned n)). 2: apply Int.repr_unsigned. + apply Int.eqm_samerepr. apply Int.eqm_sym. red. apply Int.eqmod_mod. + apply Int.modulus_pos. +Qed. + +Lemma encode_int8_signed_unsigned: forall n, + encode_int Mint8signed n = encode_int Mint8unsigned n. +Proof. + intros; reflexivity. +Qed. + +Remark encode_8_mod: + forall x y, + Int.eqmod (two_p 8) (Int.unsigned x) (Int.unsigned y) -> + encode_int Mint8unsigned x = encode_int Mint8unsigned y. +Proof. + intros. unfold encode_int. decEq. decEq. apply Byte.eqm_samerepr. exact H. +Qed. + +Lemma encode_int8_zero_ext: + forall x, + encode_int Mint8unsigned (Int.zero_ext 8 x) = encode_int Mint8unsigned x. +Proof. + intros. apply encode_8_mod. apply Int.eqmod_sym. + apply Int.eqmod_two_p_zero_ext. compute; auto. +Qed. + +Lemma encode_int8_sign_ext: + forall x, + encode_int Mint8signed (Int.sign_ext 8 x) = encode_int Mint8signed x. +Proof. + intros. repeat rewrite encode_int8_signed_unsigned. + apply encode_8_mod. apply Int.eqmod_sym. + apply Int.eqmod_two_p_sign_ext. compute; auto. +Qed. + +Lemma encode_int16_signed_unsigned: forall n, + encode_int Mint16signed n = encode_int Mint16unsigned n. +Proof. + intros; reflexivity. +Qed. + +Remark encode_16_mod: + forall x y, + Int.eqmod (two_p 16) (Int.unsigned x) (Int.unsigned y) -> + encode_int Mint16unsigned x = encode_int Mint16unsigned y. +Proof. + intros. unfold encode_int. decEq. + set (x' := Int.unsigned x) in *. + set (y' := Int.unsigned y) in *. + assert (Int.eqmod (two_p 8) x' y'). + eapply Int.eqmod_divides; eauto. exists (two_p 8); auto. + assert (Int.eqmod (two_p 8) (x' / 256) (y' / 256)). + destruct H as [k EQ]. + exists k. rewrite EQ. + replace (k * two_p 16) with ((k * two_p 8) * two_p 8). + rewrite Zplus_comm. rewrite Z_div_plus. omega. + omega. rewrite <- Zmult_assoc. auto. + decEq. apply Byte.eqm_samerepr. exact H1. + decEq. apply Byte.eqm_samerepr. exact H0. +Qed. + +Lemma encode_int16_zero_ext: + forall x, + encode_int Mint16unsigned (Int.zero_ext 16 x) = encode_int Mint16unsigned x. +Proof. + intros. apply encode_16_mod. apply Int.eqmod_sym. + apply (Int.eqmod_two_p_zero_ext 16). compute; auto. +Qed. + +Lemma encode_int16_sign_ext: + forall x, + encode_int Mint16signed (Int.sign_ext 16 x) = encode_int Mint16signed x. +Proof. + intros. repeat rewrite encode_int16_signed_unsigned. + apply encode_16_mod. apply Int.eqmod_sym. + apply Int.eqmod_two_p_sign_ext. compute; auto. +Qed. + +Lemma decode_int8_zero_ext: + forall l, + Int.zero_ext 8 (decode_int Mint8unsigned l) = decode_int Mint8unsigned l. +Proof. + intros; simpl. destruct (rev_if_le l); auto. destruct l0; auto. + unfold Int.zero_ext. decEq. + generalize (Byte.unsigned_range i). intro. + rewrite Int.unsigned_repr. apply Zmod_small. assumption. + assert (Byte.modulus < Int.max_unsigned). vm_compute. auto. + omega. +Qed. + +Lemma decode_int8_sign_ext: + forall l, + Int.sign_ext 8 (decode_int Mint8signed l) = decode_int Mint8signed l. +Proof. + intros; simpl. destruct (rev_if_le l); auto. destruct l0; auto. + rewrite Int.sign_ext_idem. auto. vm_compute; auto. +Qed. + +Lemma decode_int16_zero_ext: + forall l, + Int.zero_ext 16 (decode_int Mint16unsigned l) = decode_int Mint16unsigned l. +Proof. + intros; simpl. destruct (rev_if_le l); auto. destruct l0; auto. destruct l0; auto. + unfold Int.zero_ext. decEq. + generalize (Byte.unsigned_range i) (Byte.unsigned_range i0). + change Byte.modulus with 256. intros. + assert (0 <= Byte.unsigned i * 256 + Byte.unsigned i0 < 65536). omega. + rewrite Int.unsigned_repr. apply Zmod_small. assumption. + assert (65536 < Int.max_unsigned). vm_compute. auto. + omega. +Qed. + +Lemma decode_int16_sign_ext: + forall l, + Int.sign_ext 16 (decode_int Mint16signed l) = decode_int Mint16signed l. +Proof. + intros; simpl. destruct (rev_if_le l); auto. destruct l0; auto. destruct l0; auto. + rewrite Int.sign_ext_idem. auto. vm_compute; auto. +Qed. + +Lemma decode_int8_signed_unsigned: + forall l, + decode_int Mint8signed l = Int.sign_ext 8 (decode_int Mint8unsigned l). +Proof. + unfold decode_int; intros. destruct (rev_if_le l); auto. destruct l0; auto. +Qed. + +Lemma decode_int16_signed_unsigned: + forall l, + decode_int Mint16signed l = Int.sign_ext 16 (decode_int Mint16unsigned l). +Proof. + unfold decode_int; intros. destruct (rev_if_le l); auto. + destruct l0; auto. destruct l0; auto. +Qed. + +(** * Encoding and decoding floats *) + +Parameter encode_float: memory_chunk -> float -> list byte. +Parameter decode_float: memory_chunk -> list byte -> float. + +Axiom encode_float_length: + forall chunk n, length(encode_float chunk n) = size_chunk_nat chunk. + +(* More realistic: + decode_float Mfloat32 (encode_float Mfloat32 (Float.singleoffloat n)) = + Float.singleoffloat n +*) +Axiom decode_encode_float32: forall n, + decode_float Mfloat32 (encode_float Mfloat32 n) = Float.singleoffloat n. +Axiom decode_encode_float64: forall n, + decode_float Mfloat64 (encode_float Mfloat64 n) = n. + +Axiom encode_float32_singleoffloat: forall n, + encode_float Mfloat32 (Float.singleoffloat n) = encode_float Mfloat32 n. + +Axiom encode_float8_signed_unsigned: forall n, + encode_float Mint8signed n = encode_float Mint8unsigned n. +Axiom encode_float16_signed_unsigned: forall n, + encode_float Mint16signed n = encode_float Mint16unsigned n. + +Axiom encode_float32_cast: + forall f, + encode_float Mfloat32 (Float.singleoffloat f) = encode_float Mfloat32 f. + +Axiom decode_float32_cast: + forall l, + Float.singleoffloat (decode_float Mfloat32 l) = decode_float Mfloat32 l. + +(** * Encoding and decoding values *) + +Definition inj_bytes (bl: list byte) : list memval := + List.map Byte bl. + +Fixpoint proj_bytes (vl: list memval) : option (list byte) := + match vl with + | nil => Some nil + | Byte b :: vl' => + match proj_bytes vl' with None => None | Some bl => Some(b :: bl) end + | _ => None + end. + +Remark length_inj_bytes: + forall bl, length (inj_bytes bl) = length bl. +Proof. + intros. apply List.map_length. +Qed. + +Remark proj_inj_bytes: + forall bl, proj_bytes (inj_bytes bl) = Some bl. +Proof. + induction bl; simpl. auto. rewrite IHbl. auto. +Qed. + +Lemma inj_proj_bytes: + forall cl bl, proj_bytes cl = Some bl -> cl = inj_bytes bl. +Proof. + induction cl; simpl; intros. + inv H; auto. + destruct a; try congruence. destruct (proj_bytes cl); inv H. + simpl. decEq. auto. +Qed. + +Fixpoint inj_pointer (n: nat) (b: block) (ofs: int) {struct n}: list memval := + match n with + | O => nil + | S m => Pointer b ofs m :: inj_pointer m b ofs + end. + +Fixpoint check_pointer (n: nat) (b: block) (ofs: int) (vl: list memval) + {struct n} : bool := + match n, vl with + | O, nil => true + | S m, Pointer b' ofs' m' :: vl' => + eq_block b b' && Int.eq_dec ofs ofs' && beq_nat m m' && check_pointer m b ofs vl' + | _, _ => false + end. + +Definition proj_pointer (vl: list memval) : val := + match vl with + | Pointer b ofs n :: vl' => + if check_pointer (size_chunk_nat Mint32) b ofs vl + then Vptr b ofs + else Vundef + | _ => Vundef + end. + +Definition encode_val (chunk: memory_chunk) (v: val) : list memval := + match v, chunk with + | Vptr b ofs, Mint32 => inj_pointer (size_chunk_nat Mint32) b ofs + | Vint n, _ => inj_bytes (encode_int chunk n) + | Vfloat f, _ => inj_bytes (encode_float chunk f) + | _, _ => list_repeat (size_chunk_nat chunk) Undef + end. + +Definition decode_val (chunk: memory_chunk) (vl: list memval) : val := + match proj_bytes vl with + | Some bl => + match chunk with + | Mint8signed | Mint8unsigned + | Mint16signed | Mint16unsigned | Mint32 => + Vint(decode_int chunk bl) + | Mfloat32 | Mfloat64 => + Vfloat(decode_float chunk bl) + end + | None => + match chunk with + | Mint32 => proj_pointer vl + | _ => Vundef + end + end. + +(* +Lemma inj_pointer_length: + forall b ofs n, List.length(inj_pointer n b ofs) = n. +Proof. + induction n; simpl; congruence. +Qed. +*) + +Lemma encode_val_length: + forall chunk v, length(encode_val chunk v) = size_chunk_nat chunk. +Proof. + intros. destruct v; simpl. + apply length_list_repeat. + rewrite length_inj_bytes. apply encode_int_length. + rewrite length_inj_bytes. apply encode_float_length. + destruct chunk; try (apply length_list_repeat). reflexivity. +Qed. + +Lemma check_inj_pointer: + forall b ofs n, check_pointer n b ofs (inj_pointer n b ofs) = true. +Proof. + induction n; simpl. auto. + unfold proj_sumbool. rewrite dec_eq_true. rewrite dec_eq_true. + rewrite <- beq_nat_refl. simpl; auto. +Qed. + +Definition decode_encode_val (v1: val) (chunk1 chunk2: memory_chunk) (v2: val) : Prop := + match v1, chunk1, chunk2 with + | Vundef, _, _ => v2 = Vundef + | Vint n, Mint8signed, Mint8signed => v2 = Vint(Int.sign_ext 8 n) + | Vint n, Mint8unsigned, Mint8signed => v2 = Vint(Int.sign_ext 8 n) + | Vint n, Mint8signed, Mint8unsigned => v2 = Vint(Int.zero_ext 8 n) + | Vint n, Mint8unsigned, Mint8unsigned => v2 = Vint(Int.zero_ext 8 n) + | Vint n, Mint16signed, Mint16signed => v2 = Vint(Int.sign_ext 16 n) + | Vint n, Mint16unsigned, Mint16signed => v2 = Vint(Int.sign_ext 16 n) + | Vint n, Mint16signed, Mint16unsigned => v2 = Vint(Int.zero_ext 16 n) + | Vint n, Mint16unsigned, Mint16unsigned => v2 = Vint(Int.zero_ext 16 n) + | Vint n, Mint32, Mint32 => v2 = Vint n + | Vint n, Mint32, Mfloat32 => v2 = Vfloat(decode_float Mfloat32 (encode_int Mint32 n)) + | Vint n, _, _ => True (* nothing interesting to say about v2 *) + | Vptr b ofs, Mint32, Mint32 => v2 = Vptr b ofs + | Vptr b ofs, _, _ => v2 = Vundef + | Vfloat f, Mfloat32, Mfloat32 => v2 = Vfloat(Float.singleoffloat f) + | Vfloat f, Mfloat32, Mint32 => v2 = Vint(decode_int Mint32 (encode_float Mfloat32 f)) + | Vfloat f, Mfloat64, Mfloat64 => v2 = Vfloat f + | Vfloat f, _, _ => True (* nothing interesting to say about v2 *) + end. + +Lemma decode_encode_val_general: + forall v chunk1 chunk2, + decode_encode_val v chunk1 chunk2 (decode_val chunk2 (encode_val chunk1 v)). +Proof. + intros. destruct v. +(* Vundef *) + simpl. destruct (size_chunk_nat_pos chunk1) as [psz EQ]. + rewrite EQ. simpl. + unfold decode_val. simpl. destruct chunk2; auto. +(* Vint *) + simpl. + destruct chunk1; auto; destruct chunk2; auto; unfold decode_val; + rewrite proj_inj_bytes. + rewrite decode_encode_int8signed. auto. + rewrite encode_int8_signed_unsigned. rewrite decode_encode_int8unsigned. auto. + rewrite <- encode_int8_signed_unsigned. rewrite decode_encode_int8signed. auto. + rewrite decode_encode_int8unsigned. auto. + rewrite decode_encode_int16signed. auto. + rewrite encode_int16_signed_unsigned. rewrite decode_encode_int16unsigned. auto. + rewrite <- encode_int16_signed_unsigned. rewrite decode_encode_int16signed. auto. + rewrite decode_encode_int16unsigned. auto. + rewrite decode_encode_int32. auto. + auto. +(* Vfloat *) + unfold decode_val, encode_val, decode_encode_val; + destruct chunk1; auto; destruct chunk2; auto; unfold decode_val; + rewrite proj_inj_bytes. + auto. + rewrite decode_encode_float32. auto. + rewrite decode_encode_float64. auto. +(* Vptr *) + unfold decode_val, encode_val, decode_encode_val; + destruct chunk1; auto; destruct chunk2; auto. + simpl. generalize (check_inj_pointer b i (size_chunk_nat Mint32)). + simpl. intro. rewrite H. auto. +Qed. + +Lemma decode_encode_val_similar: + forall v1 chunk1 chunk2 v2, + type_of_chunk chunk1 = type_of_chunk chunk2 -> + size_chunk chunk1 = size_chunk chunk2 -> + Val.has_type v1 (type_of_chunk chunk1) -> + decode_encode_val v1 chunk1 chunk2 v2 -> + v2 = Val.load_result chunk2 v1. +Proof. + intros. + destruct v1. + simpl in *. destruct chunk2; simpl; auto. + red in H1. + destruct chunk1; simpl in H1; try contradiction; + destruct chunk2; simpl in *; discriminate || auto. + red in H1. + destruct chunk1; simpl in H1; try contradiction; + destruct chunk2; simpl in *; discriminate || auto. + red in H1. + destruct chunk1; simpl in H1; try contradiction; + destruct chunk2; simpl in *; discriminate || auto. +Qed. + +Lemma decode_val_type: + forall chunk cl, + Val.has_type (decode_val chunk cl) (type_of_chunk chunk). +Proof. + intros. unfold decode_val. + destruct (proj_bytes cl). + destruct chunk; simpl; auto. + destruct chunk; simpl; auto. + unfold proj_pointer. destruct cl; try (exact I). + destruct m; try (exact I). + destruct (check_pointer (size_chunk_nat Mint32) b i (Pointer b i n :: cl)); + exact I. +Qed. + +Lemma encode_val_int8_signed_unsigned: + forall v, encode_val Mint8signed v = encode_val Mint8unsigned v. +Proof. + intros. destruct v; simpl; auto. rewrite encode_float8_signed_unsigned; auto. +Qed. + +Lemma encode_val_int16_signed_unsigned: + forall v, encode_val Mint16signed v = encode_val Mint16unsigned v. +Proof. + intros. destruct v; simpl; auto. rewrite encode_float16_signed_unsigned; auto. +Qed. + +Lemma encode_val_int8_zero_ext: + forall n, encode_val Mint8unsigned (Vint (Int.zero_ext 8 n)) = encode_val Mint8unsigned (Vint n). +Proof. + intros; unfold encode_val. rewrite encode_int8_zero_ext. auto. +Qed. + +Lemma encode_val_int8_sign_ext: + forall n, encode_val Mint8signed (Vint (Int.sign_ext 8 n)) = encode_val Mint8signed (Vint n). +Proof. + intros; unfold encode_val. rewrite encode_int8_sign_ext. auto. +Qed. + +Lemma encode_val_int16_zero_ext: + forall n, encode_val Mint16unsigned (Vint (Int.zero_ext 16 n)) = encode_val Mint16unsigned (Vint n). +Proof. + intros; unfold encode_val. rewrite encode_int16_zero_ext. auto. +Qed. + +Lemma encode_val_int16_sign_ext: + forall n, encode_val Mint16signed (Vint (Int.sign_ext 16 n)) = encode_val Mint16signed (Vint n). +Proof. + intros; unfold encode_val. rewrite encode_int16_sign_ext. auto. +Qed. + +Lemma decode_val_int_inv: + forall chunk cl n, + decode_val chunk cl = Vint n -> + type_of_chunk chunk = Tint /\ + exists bytes, proj_bytes cl = Some bytes /\ n = decode_int chunk bytes. +Proof. + intros until n. unfold decode_val. destruct (proj_bytes cl). +Opaque decode_int. + destruct chunk; intro EQ; inv EQ; split; auto; exists l; auto. + destruct chunk; try congruence. unfold proj_pointer. + destruct cl; try congruence. destruct m; try congruence. + destruct (check_pointer (size_chunk_nat Mint32) b i (Pointer b i n0 :: cl)); + congruence. +Qed. + +Lemma decode_val_float_inv: + forall chunk cl f, + decode_val chunk cl = Vfloat f -> + type_of_chunk chunk = Tfloat /\ + exists bytes, proj_bytes cl = Some bytes /\ f = decode_float chunk bytes. +Proof. + intros until f. unfold decode_val. destruct (proj_bytes cl). + destruct chunk; intro EQ; inv EQ; split; auto; exists l; auto. + destruct chunk; try congruence. unfold proj_pointer. + destruct cl; try congruence. destruct m; try congruence. + destruct (check_pointer (size_chunk_nat Mint32) b i (Pointer b i n :: cl)); + congruence. +Qed. + +Lemma decode_val_cast: + forall chunk l, + let v := decode_val chunk l in + match chunk with + | Mint8signed => v = Val.sign_ext 8 v + | Mint8unsigned => v = Val.zero_ext 8 v + | Mint16signed => v = Val.sign_ext 16 v + | Mint16unsigned => v = Val.zero_ext 16 v + | Mfloat32 => v = Val.singleoffloat v + | _ => True + end. +Proof. + unfold decode_val; intros; destruct chunk; auto; destruct (proj_bytes l); auto. + unfold Val.sign_ext. decEq. symmetry. apply decode_int8_sign_ext. + unfold Val.zero_ext. decEq. symmetry. apply decode_int8_zero_ext. + unfold Val.sign_ext. decEq. symmetry. apply decode_int16_sign_ext. + unfold Val.zero_ext. decEq. symmetry. apply decode_int16_zero_ext. + unfold Val.singleoffloat. decEq. symmetry. apply decode_float32_cast. +Qed. + +(** Pointers cannot be forged. *) + +Definition memval_valid_first (mv: memval) : Prop := + match mv with + | Pointer b ofs n => n = pred (size_chunk_nat Mint32) + | _ => True + end. + +Definition memval_valid_cont (mv: memval) : Prop := + match mv with + | Pointer b ofs n => n <> pred (size_chunk_nat Mint32) + | _ => True + end. + +Inductive encoding_shape: list memval -> Prop := + | encoding_shape_intro: forall mv1 mvl, + memval_valid_first mv1 -> + (forall mv, In mv mvl -> memval_valid_cont mv) -> + encoding_shape (mv1 :: mvl). + +Lemma encode_val_shape: + forall chunk v, encoding_shape (encode_val chunk v). +Proof. + intros. + destruct (size_chunk_nat_pos chunk) as [sz1 EQ]. + assert (encoding_shape (list_repeat (size_chunk_nat chunk) Undef)). + rewrite EQ; simpl; constructor. exact I. + intros. replace mv with Undef. exact I. symmetry; eapply in_list_repeat; eauto. + assert (forall bl, length bl = size_chunk_nat chunk -> + encoding_shape (inj_bytes bl)). + intros. destruct bl; simpl in *. congruence. + constructor. exact I. unfold inj_bytes. intros. + exploit list_in_map_inv; eauto. intros [x [A B]]. subst mv. exact I. + destruct v; simpl. + auto. + apply H0. apply encode_int_length. + apply H0. apply encode_float_length. + destruct chunk; auto. + constructor. red. auto. + simpl; intros. intuition; subst mv; red; simpl; congruence. +Qed. + +Lemma check_pointer_inv: + forall b ofs n mv, + check_pointer n b ofs mv = true -> mv = inj_pointer n b ofs. +Proof. + induction n; destruct mv; simpl. + auto. + congruence. + congruence. + destruct m; try congruence. intro. + destruct (andb_prop _ _ H). destruct (andb_prop _ _ H0). + destruct (andb_prop _ _ H2). + decEq. decEq. symmetry; eapply proj_sumbool_true; eauto. + symmetry; eapply proj_sumbool_true; eauto. + symmetry; apply beq_nat_true; auto. + auto. +Qed. + +Inductive decoding_shape: list memval -> Prop := + | decoding_shape_intro: forall mv1 mvl, + memval_valid_first mv1 -> mv1 <> Undef -> + (forall mv, In mv mvl -> memval_valid_cont mv /\ mv <> Undef) -> + decoding_shape (mv1 :: mvl). + +Lemma decode_val_shape: + forall chunk mvl, + List.length mvl = size_chunk_nat chunk -> + decode_val chunk mvl = Vundef \/ decoding_shape mvl. +Proof. + intros. destruct (size_chunk_nat_pos chunk) as [sz EQ]. + unfold decode_val. + caseEq (proj_bytes mvl). + intros bl PROJ. right. exploit inj_proj_bytes; eauto. intros. subst mvl. + destruct bl; simpl in H. congruence. simpl. constructor. + red; auto. congruence. + unfold inj_bytes; intros. exploit list_in_map_inv; eauto. intros [b [A B]]. + subst mv. split. red; auto. congruence. + intros. destruct chunk; auto. unfold proj_pointer. + destruct mvl; auto. destruct m; auto. + caseEq (check_pointer (size_chunk_nat Mint32) b i (Pointer b i n :: mvl)); auto. + intros. right. exploit check_pointer_inv; eauto. simpl; intros; inv H2. + constructor. red. auto. congruence. + simpl; intros. intuition; subst mv; simpl; congruence. +Qed. + +Lemma encode_val_pointer_inv: + forall chunk v b ofs n mvl, + encode_val chunk v = Pointer b ofs n :: mvl -> + chunk = Mint32 /\ v = Vptr b ofs /\ mvl = inj_pointer (pred (size_chunk_nat Mint32)) b ofs. +Proof. + intros until mvl. + destruct (size_chunk_nat_pos chunk) as [sz SZ]. + unfold encode_val. rewrite SZ. destruct v. + simpl. congruence. + generalize (encode_int_length chunk i). destruct (encode_int chunk i); simpl; congruence. + generalize (encode_float_length chunk f). destruct (encode_float chunk f); simpl; congruence. + destruct chunk; try (simpl; congruence). + simpl. intuition congruence. +Qed. + +Lemma decode_val_pointer_inv: + forall chunk mvl b ofs, + decode_val chunk mvl = Vptr b ofs -> + chunk = Mint32 /\ mvl = inj_pointer (size_chunk_nat Mint32) b ofs. +Proof. + intros until ofs; unfold decode_val. + destruct (proj_bytes mvl). + destruct chunk; congruence. + destruct chunk; try congruence. + unfold proj_pointer. destruct mvl. congruence. destruct m; try congruence. + case_eq (check_pointer (size_chunk_nat Mint32) b0 i (Pointer b0 i n :: mvl)); intros. + inv H0. split; auto. apply check_pointer_inv; auto. + congruence. +Qed. + +Inductive pointer_encoding_shape: list memval -> Prop := + | pointer_encoding_shape_intro: forall mv1 mvl, + ~memval_valid_cont mv1 -> + (forall mv, In mv mvl -> ~memval_valid_first mv) -> + pointer_encoding_shape (mv1 :: mvl). + +Lemma encode_pointer_shape: + forall b ofs, pointer_encoding_shape (encode_val Mint32 (Vptr b ofs)). +Proof. + intros. simpl. constructor. + unfold memval_valid_cont. red; intro. elim H. auto. + unfold memval_valid_first. simpl; intros; intuition; subst mv; congruence. +Qed. + +Lemma decode_pointer_shape: + forall chunk mvl b ofs, + decode_val chunk mvl = Vptr b ofs -> + chunk = Mint32 /\ pointer_encoding_shape mvl. +Proof. + intros. exploit decode_val_pointer_inv; eauto. intros [A B]. + split; auto. subst mvl. apply encode_pointer_shape. +Qed. + +(* +Lemma proj_bytes_none: + forall mv, + match mv with Byte _ => False | _ => True end -> + forall mvl, + In mv mvl -> + proj_bytes mvl = None. +Proof. + induction mvl; simpl; intros. + elim H0. + destruct a; auto. destruct H0. subst mv. contradiction. + rewrite (IHmvl H0); auto. +Qed. + +Lemma decode_val_undef: + forall chunk mv mv1 mvl, + match mv with + | Pointer b ofs n => n = pred (size_chunk_nat Mint32) + | Undef => True + | _ => False + end -> + In mv mvl -> + decode_val chunk (mv1 :: mvl) = Vundef. +Proof. + intros. unfold decode_val. + replace (proj_bytes (mv1 :: mvl)) with (@None (list byte)). + destruct chunk; auto. unfold proj_pointer. destruct mv1; auto. + case_eq (check_pointer (size_chunk_nat Mint32) b i (Pointer b i n :: mvl)); intros. + exploit check_pointer_inv; eauto. simpl. intros. inv H2. + simpl in H0. intuition; subst mv; simpl in H; congruence. + auto. + symmetry. apply proj_bytes_none with mv. + destruct mv; tauto. auto with coqlib. +Qed. + +*) + +(** * Compatibility with memory injections *) + +(** Relating two memory values according to a memory injection. *) + +Inductive memval_inject (f: meminj): memval -> memval -> Prop := + | memval_inject_byte: + forall n, memval_inject f (Byte n) (Byte n) + | memval_inject_ptr: + forall b1 ofs1 b2 ofs2 delta n, + f b1 = Some (b2, delta) -> + ofs2 = Int.add ofs1 (Int.repr delta) -> + memval_inject f (Pointer b1 ofs1 n) (Pointer b2 ofs2 n) + | memval_inject_undef: + forall mv, memval_inject f Undef mv. + +Lemma memval_inject_incr: + forall f f' v1 v2, memval_inject f v1 v2 -> inject_incr f f' -> memval_inject f' v1 v2. +Proof. + intros. inv H; econstructor. rewrite (H0 _ _ _ H1). reflexivity. auto. +Qed. + +(** [decode_val], applied to lists of memory values that are pairwise + related by [memval_inject], returns values that are related by [val_inject]. *) + +Lemma proj_bytes_inject: + forall f vl vl', + list_forall2 (memval_inject f) vl vl' -> + forall bl, + proj_bytes vl = Some bl -> + proj_bytes vl' = Some bl. +Proof. + induction 1; simpl. congruence. + inv H; try congruence. + destruct (proj_bytes al); intros. + inv H. rewrite (IHlist_forall2 l); auto. + congruence. +Qed. + +Lemma check_pointer_inject: + forall f vl vl', + list_forall2 (memval_inject f) vl vl' -> + forall n b ofs b' delta, + check_pointer n b ofs vl = true -> + f b = Some(b', delta) -> + check_pointer n b' (Int.add ofs (Int.repr delta)) vl' = true. +Proof. + induction 1; intros; destruct n; simpl in *; auto. + inv H; auto. + destruct (andb_prop _ _ H1). destruct (andb_prop _ _ H). + destruct (andb_prop _ _ H5). + assert (n = n0) by (apply beq_nat_true; auto). + assert (b = b0) by (eapply proj_sumbool_true; eauto). + assert (ofs = ofs1) by (eapply proj_sumbool_true; eauto). + subst. rewrite H3 in H2; inv H2. + unfold proj_sumbool. rewrite dec_eq_true. rewrite dec_eq_true. + rewrite <- beq_nat_refl. simpl. eauto. + congruence. +Qed. + +Lemma proj_pointer_inject: + forall f vl1 vl2, + list_forall2 (memval_inject f) vl1 vl2 -> + val_inject f (proj_pointer vl1) (proj_pointer vl2). +Proof. + intros. unfold proj_pointer. + inversion H; subst. auto. inversion H0; subst; auto. + case_eq (check_pointer (size_chunk_nat Mint32) b0 ofs1 (Pointer b0 ofs1 n :: al)); intros. + exploit check_pointer_inject. eexact H. eauto. eauto. + intro. rewrite H4. econstructor; eauto. + constructor. +Qed. + +Lemma proj_bytes_not_inject: + forall f vl vl', + list_forall2 (memval_inject f) vl vl' -> + proj_bytes vl = None -> proj_bytes vl' <> None -> In Undef vl. +Proof. + induction 1; simpl; intros. + congruence. + inv H; try congruence. + right. apply IHlist_forall2. + destruct (proj_bytes al); congruence. + destruct (proj_bytes bl); congruence. + auto. +Qed. + +Lemma check_pointer_undef: + forall n b ofs vl, + In Undef vl -> check_pointer n b ofs vl = false. +Proof. + induction n; intros; simpl. + destruct vl. elim H. auto. + destruct vl. auto. + destruct m; auto. simpl in H; destruct H. congruence. + rewrite IHn; auto. apply andb_false_r. +Qed. + +Lemma proj_pointer_undef: + forall vl, In Undef vl -> proj_pointer vl = Vundef. +Proof. + intros; unfold proj_pointer. + destruct vl; auto. destruct m; auto. + rewrite check_pointer_undef. auto. auto. +Qed. + +Theorem decode_val_inject: + forall f vl1 vl2 chunk, + list_forall2 (memval_inject f) vl1 vl2 -> + val_inject f (decode_val chunk vl1) (decode_val chunk vl2). +Proof. + intros. unfold decode_val. + case_eq (proj_bytes vl1); intros. + exploit proj_bytes_inject; eauto. intros. rewrite H1. + destruct chunk; constructor. + destruct chunk; auto. + case_eq (proj_bytes vl2); intros. + rewrite proj_pointer_undef. auto. eapply proj_bytes_not_inject; eauto. congruence. + apply proj_pointer_inject; auto. +Qed. + +(** Symmetrically, [encode_val], applied to values related by [val_inject], + returns lists of memory values that are pairwise + related by [memval_inject]. *) + +Lemma inj_bytes_inject: + forall f bl, list_forall2 (memval_inject f) (inj_bytes bl) (inj_bytes bl). +Proof. + induction bl; constructor; auto. constructor. +Qed. + +Lemma repeat_Undef_inject_any: + forall f vl, + list_forall2 (memval_inject f) (list_repeat (length vl) Undef) vl. +Proof. + induction vl; simpl; constructor; auto. constructor. +Qed. + +Lemma repeat_Undef_inject_self: + forall f n, + list_forall2 (memval_inject f) (list_repeat n Undef) (list_repeat n Undef). +Proof. + induction n; simpl; constructor; auto. constructor. +Qed. + +Theorem encode_val_inject: + forall f v1 v2 chunk, + val_inject f v1 v2 -> + list_forall2 (memval_inject f) (encode_val chunk v1) (encode_val chunk v2). +Proof. + intros. inv H; simpl. + apply inj_bytes_inject. + apply inj_bytes_inject. + destruct chunk; try apply repeat_Undef_inject_self. + unfold inj_pointer; simpl; repeat econstructor; auto. + replace (size_chunk_nat chunk) with (length (encode_val chunk v2)). + apply repeat_Undef_inject_any. apply encode_val_length. +Qed. + +(** The identity injection has interesting properties. *) + +Definition inject_id : meminj := fun b => Some(b, 0). + +Lemma val_inject_id: + forall v1 v2, + val_inject inject_id v1 v2 <-> Val.lessdef v1 v2. +Proof. + intros; split; intros. + inv H. constructor. constructor. + unfold inject_id in H0. inv H0. rewrite Int.add_zero. constructor. + constructor. + inv H. destruct v2; econstructor. unfold inject_id; reflexivity. rewrite Int.add_zero; auto. + constructor. +Qed. + +Lemma memval_inject_id: + forall mv, memval_inject inject_id mv mv. +Proof. + destruct mv; econstructor. unfold inject_id; reflexivity. rewrite Int.add_zero; auto. +Qed. + diff --git a/common/Memdataaux.ml b/common/Memdataaux.ml new file mode 100644 index 0000000..3a39428 --- /dev/null +++ b/common/Memdataaux.ml @@ -0,0 +1,68 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +open Camlcoq +open Integers +open AST + +let big_endian = + match Configuration.arch with + | "powerpc" -> true + | "arm" -> false + | _ -> assert false + +let encode_float chunk f = + match chunk with + | Mint8unsigned | Mint8signed -> + [Byte.zero] + | Mint16unsigned | Mint16signed -> + [Byte.zero; Byte.zero] + | Mint32 -> + [Byte.zero; Byte.zero; Byte.zero; Byte.zero] + | Mfloat32 -> + let bits = Int32.bits_of_float f in + let byte n = + coqint_of_camlint + (Int32.logand (Int32.shift_right_logical bits n) 0xFFl) in + if big_endian then + [byte 24; byte 16; byte 8; byte 0] + else + [byte 0; byte 8; byte 16; byte 24] + | Mfloat64 -> + let bits = Int64.bits_of_float f in + let byte n = + coqint_of_camlint + (Int64.to_int32 + (Int64.logand (Int64.shift_right_logical bits n) 0xFFL)) in + if big_endian then + [byte 56; byte 48; byte 40; byte 32; byte 24; byte 16; byte 8; byte 0] + else + [byte 0; byte 8; byte 16; byte 24; byte 32; byte 40; byte 48; byte 56] + +let decode_float chunk bytes = + match chunk with + | Mfloat32 -> + let combine accu b = + Int32.logor (Int32.shift_left accu 8) (camlint_of_coqint b) in + Int32.float_of_bits + (List.fold_left combine 0l + (if big_endian then bytes else List.rev bytes)) + | Mfloat64 -> + let combine accu b = + Int64.logor (Int64.shift_left accu 8) + (Int64.of_int32 (camlint_of_coqint b)) in + Int64.float_of_bits + (List.fold_left combine 0L + (if big_endian then bytes else List.rev bytes)) + | _ -> + 0.0 (* unspecified *) + diff --git a/common/Memory.v b/common/Memory.v new file mode 100644 index 0000000..3092021 --- /dev/null +++ b/common/Memory.v @@ -0,0 +1,2844 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* Sandrine Blazy, ENSIIE and INRIA Paris-Rocquencourt *) +(* *) +(* 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 file develops the memory model that is used in the dynamic + semantics of all the languages used in the compiler. + It defines a type [mem] of memory states, the following 4 basic + operations over memory states, and their properties: +- [load]: read a memory chunk at a given address; +- [store]: store a memory chunk at a given address; +- [alloc]: allocate a fresh memory block; +- [free]: invalidate a memory block. +*) + +Require Import Coqlib. +Require Import AST. +Require Import Integers. +Require Import Floats. +Require Import Values. +Require Export Memdata. +Require Export Memtype. + +Definition update (A: Type) (x: Z) (v: A) (f: Z -> A) : Z -> A := + fun y => if zeq y x then v else f y. + +Implicit Arguments update [A]. + +Lemma update_s: + forall (A: Type) (x: Z) (v: A) (f: Z -> A), + update x v f x = v. +Proof. + intros; unfold update. apply zeq_true. +Qed. + +Lemma update_o: + forall (A: Type) (x: Z) (v: A) (f: Z -> A) (y: Z), + x <> y -> update x v f y = f y. +Proof. + intros; unfold update. apply zeq_false; auto. +Qed. + +Module Mem : MEM. + +Record mem_ : Type := mkmem { + contents: block -> Z -> memval; + access: block -> Z -> bool; + bound: block -> Z * Z; + next: block; + next_pos: next > 0; + next_noaccess: forall b ofs, b >= next -> access b ofs = false; + bound_noaccess: forall b ofs, ofs < fst(bound b) \/ ofs >= snd(bound b) -> access b ofs = false +}. + +Definition mem := mem_. + +(** * Validity of blocks and accesses *) + +(** A block address is valid if it was previously allocated. It remains valid + even after being freed. *) + +Definition nextblock (m: mem) : block := m.(next). + +Theorem nextblock_pos: + forall m, nextblock m > 0. +Proof next_pos. + +Definition valid_block (m: mem) (b: block) := + b < nextblock m. + +Theorem valid_not_valid_diff: + forall m b b', valid_block m b -> ~(valid_block m b') -> b <> b'. +Proof. + intros; red; intros. subst b'. contradiction. +Qed. + +Hint Local Resolve valid_not_valid_diff: mem. + +(** Permissions *) + +Definition perm (m: mem) (b: block) (ofs: Z) (p: permission) : Prop := + m.(access) b ofs = true. + +Theorem perm_implies: + forall m b ofs p1 p2, perm m b ofs p1 -> perm_order p1 p2 -> perm m b ofs p2. +Proof. + unfold perm; auto. +Qed. + +Hint Local Resolve perm_implies: mem. + +Theorem perm_valid_block: + forall m b ofs p, perm m b ofs p -> valid_block m b. +Proof. + unfold perm; intros. + destruct (zlt b m.(next)). + auto. + assert (access m b ofs = false). eapply next_noaccess; eauto. + congruence. +Qed. + +Hint Local Resolve perm_valid_block: mem. + +Theorem perm_dec: + forall m b ofs p, {perm m b ofs p} + {~ perm m b ofs p}. +Proof. + unfold perm; intros. + destruct (access m b ofs). left; auto. right; congruence. +Qed. + +Definition range_perm (m: mem) (b: block) (lo hi: Z) (p: permission) : Prop := + forall ofs, lo <= ofs < hi -> perm m b ofs p. + +Theorem range_perm_implies: + forall m b lo hi p1 p2, + range_perm m b lo hi p1 -> perm_order p1 p2 -> range_perm m b lo hi p2. +Proof. + unfold range_perm; intros; eauto with mem. +Qed. + +Hint Local Resolve range_perm_implies: mem. + +Lemma range_perm_dec: + forall m b lo hi p, {range_perm m b lo hi p} + {~ range_perm m b lo hi p}. +Proof. + intros. + assert (forall n, 0 <= n -> + {range_perm m b lo (lo + n) p} + {~ range_perm m b lo (lo + n) p}). + apply natlike_rec2. + left. red; intros. omegaContradiction. + intros. destruct H0. + destruct (perm_dec m b (lo + z) p). + left. red; intros. destruct (zeq ofs (lo + z)). congruence. apply r. omega. + right; red; intro. elim n. apply H0. omega. + right; red; intro. elim n. red; intros. apply H0. omega. + destruct (zlt lo hi). + replace hi with (lo + (hi - lo)) by omega. apply H. omega. + left; red; intros. omegaContradiction. +Qed. + +(** [valid_access m chunk b ofs p] holds if a memory access + of the given chunk is possible in [m] at address [b, ofs] + with permissions [p]. + This means: +- The range of bytes accessed all have permission [p]. +- The offset [ofs] is aligned. +*) + +Definition valid_access (m: mem) (chunk: memory_chunk) (b: block) (ofs: Z) (p: permission): Prop := + range_perm m b ofs (ofs + size_chunk chunk) p + /\ (align_chunk chunk | ofs). + +Theorem valid_access_writable_any: + forall m chunk b ofs p, + valid_access m chunk b ofs Writable -> + valid_access m chunk b ofs p. +Proof. + intros. inv H. constructor; auto with mem. +Qed. + +Theorem valid_access_implies: + forall m chunk b ofs p1 p2, + valid_access m chunk b ofs p1 -> perm_order p1 p2 -> + valid_access m chunk b ofs p2. +Proof. + intros. inv H. constructor; eauto with mem. +Qed. + +Hint Local Resolve valid_access_implies: mem. + +Theorem valid_access_valid_block: + forall m chunk b ofs, + valid_access m chunk b ofs Nonempty -> + valid_block m b. +Proof. + intros. destruct H. + assert (perm m b ofs Nonempty). + apply H. generalize (size_chunk_pos chunk). omega. + eauto with mem. +Qed. + +Hint Local Resolve valid_access_valid_block: mem. + +Lemma valid_access_perm: + forall m chunk b ofs p, + valid_access m chunk b ofs p -> + perm m b ofs p. +Proof. + intros. destruct H. apply H. generalize (size_chunk_pos chunk). omega. +Qed. + +Lemma valid_access_compat: + forall m chunk1 chunk2 b ofs p, + size_chunk chunk1 = size_chunk chunk2 -> + valid_access m chunk1 b ofs p-> + valid_access m chunk2 b ofs p. +Proof. + intros. inv H0. rewrite H in H1. constructor; auto. + rewrite <- (align_chunk_compat _ _ H). auto. +Qed. + +Lemma valid_access_dec: + forall m chunk b ofs p, + {valid_access m chunk b ofs p} + {~ valid_access m chunk b ofs p}. +Proof. + intros. + destruct (range_perm_dec m b ofs (ofs + size_chunk chunk) p). + destruct (Zdivide_dec (align_chunk chunk) ofs (align_chunk_pos chunk)). + left; constructor; auto. + right; red; intro V; inv V; contradiction. + right; red; intro V; inv V; contradiction. +Qed. + +(** [valid_pointer] is a boolean-valued function that says whether + the byte at the given location is nonempty. *) + +Definition valid_pointer (m: mem) (b: block) (ofs: Z): bool := + perm_dec m b ofs Nonempty. + +Theorem valid_pointer_nonempty_perm: + forall m b ofs, + valid_pointer m b ofs = true <-> perm m b ofs Nonempty. +Proof. + intros. unfold valid_pointer. + destruct (perm_dec m b ofs Nonempty); simpl; + intuition congruence. +Qed. + +Theorem valid_pointer_valid_access: + forall m b ofs, + valid_pointer m b ofs = true <-> valid_access m Mint8unsigned b ofs Nonempty. +Proof. + intros. rewrite valid_pointer_nonempty_perm. + split; intros. + split. simpl; red; intros. replace ofs0 with ofs by omega. auto. + simpl. apply Zone_divide. + destruct H. apply H. simpl. omega. +Qed. + +(** Bounds *) + +(** Each block has a low bound and a high bound, determined at allocation time + and invariant afterward. The crucial properties of bounds is + that any offset below the low bound or above the high bound is + empty. *) + +Definition bounds (m: mem) (b: block) : Z*Z := m.(bound) b. + +Notation low_bound m b := (fst(bounds m b)). +Notation high_bound m b := (snd(bounds m b)). + +Theorem perm_in_bounds: + forall m b ofs p, perm m b ofs p -> low_bound m b <= ofs < high_bound m b. +Proof. + unfold perm, bounds. intros. + destruct (zlt ofs (fst (bound m b))). + exploit bound_noaccess. left; eauto. congruence. + destruct (zlt ofs (snd (bound m b))). + omega. + exploit bound_noaccess. right; eauto. congruence. +Qed. + +Theorem range_perm_in_bounds: + forall m b lo hi p, + range_perm m b lo hi p -> lo < hi -> low_bound m b <= lo /\ hi <= high_bound m b. +Proof. + intros. split. + exploit (perm_in_bounds m b lo p). apply H. omega. omega. + exploit (perm_in_bounds m b (hi-1) p). apply H. omega. omega. +Qed. + +Theorem valid_access_in_bounds: + forall m chunk b ofs p, + valid_access m chunk b ofs p -> + low_bound m b <= ofs /\ ofs + size_chunk chunk <= high_bound m b. +Proof. + intros. inv H. apply range_perm_in_bounds with p; auto. + generalize (size_chunk_pos chunk). omega. +Qed. + +Hint Local Resolve perm_in_bounds range_perm_in_bounds valid_access_in_bounds. + +(** * Store operations *) + +(** The initial store *) + +Program Definition empty: mem := + mkmem (fun b ofs => Undef) + (fun b ofs => false) + (fun b => (0,0)) + 1 _ _ _. +Next Obligation. + omega. +Qed. + +Definition nullptr: block := 0. + +(** Allocation of a fresh block with the given bounds. Return an updated + memory state and the address of the fresh block, which initially contains + undefined cells. Note that allocation never fails: we model an + infinite memory. *) + +Program Definition alloc (m: mem) (lo hi: Z) := + (mkmem (update m.(next) + (fun ofs => Undef) + m.(contents)) + (update m.(next) + (fun ofs => zle lo ofs && zlt ofs hi) + m.(access)) + (update m.(next) (lo, hi) m.(bound)) + (Zsucc m.(next)) + _ _ _, + m.(next)). +Next Obligation. + generalize (next_pos m). omega. +Qed. +Next Obligation. + rewrite update_o. apply next_noaccess. omega. omega. +Qed. +Next Obligation. + unfold update in *. destruct (zeq b (next m)). + simpl in H. destruct H. + unfold proj_sumbool. rewrite zle_false. auto. omega. + unfold proj_sumbool. rewrite zlt_false. apply andb_false_r. auto. + apply bound_noaccess. auto. +Qed. + +(** Freeing a block between the given bounds. + Return the updated memory state where the given range of the given block + has been invalidated: future reads and writes to this + range will fail. Requires write permission on the given range. *) + +Program Definition unchecked_free (m: mem) (b: block) (lo hi: Z): mem := + mkmem m.(contents) + (update b + (fun ofs => if zle lo ofs && zlt ofs hi then false else m.(access) b ofs) + m.(access)) + m.(bound) + m.(next) _ _ _. +Next Obligation. + apply next_pos. +Qed. +Next Obligation. + unfold update. destruct (zeq b0 b). subst b0. + destruct (zle lo ofs); simpl; auto. + destruct (zlt ofs hi); simpl; auto. + apply next_noaccess; auto. + apply next_noaccess; auto. + apply next_noaccess; auto. +Qed. +Next Obligation. + unfold update. destruct (zeq b0 b). subst b0. + destruct (zle lo ofs); simpl; auto. + destruct (zlt ofs hi); simpl; auto. + apply bound_noaccess; auto. + apply bound_noaccess; auto. + apply bound_noaccess; auto. +Qed. + +Definition free (m: mem) (b: block) (lo hi: Z): option mem := + if range_perm_dec m b lo hi Freeable + then Some(unchecked_free m b lo hi) + else None. + +Fixpoint free_list (m: mem) (l: list (block * Z * Z)) {struct l}: option mem := + match l with + | nil => Some m + | (b, lo, hi) :: l' => + match free m b lo hi with + | None => None + | Some m' => free_list m' l' + end + end. + +(** Memory reads. *) + +(** Reading N adjacent bytes in a block content. *) + +Fixpoint getN (n: nat) (p: Z) (c: Z -> memval) {struct n}: list memval := + match n with + | O => nil + | S n' => c p :: getN n' (p + 1) c + end. + +(** [load chunk m b ofs] perform a read in memory state [m], at address + [b] and offset [ofs]. It returns the value of the memory chunk + at that address. [None] is returned if the accessed bytes + are not readable. *) + +Definition load (chunk: memory_chunk) (m: mem) (b: block) (ofs: Z): option val := + if valid_access_dec m chunk b ofs Readable + then Some(decode_val chunk (getN (size_chunk_nat chunk) ofs (m.(contents) b))) + else None. + +(** [loadv chunk m addr] is similar, but the address and offset are given + as a single value [addr], which must be a pointer value. *) + +Definition loadv (chunk: memory_chunk) (m: mem) (addr: val) : option val := + match addr with + | Vptr b ofs => load chunk m b (Int.signed ofs) + | _ => None + end. + +(** [loadbytes m b ofs n] reads [n] consecutive bytes starting at + location [(b, ofs)]. Returns [None] if the accessed locations are + not readable or do not contain bytes. *) + +Definition loadbytes (m: mem) (b: block) (ofs n: Z): option (list byte) := + if range_perm_dec m b ofs (ofs + n) Readable + then proj_bytes (getN (nat_of_Z n) ofs (m.(contents) b)) + else None. + +(** Memory stores. *) + +(** Writing N adjacent bytes in a block content. *) + +Fixpoint setN (vl: list memval) (p: Z) (c: Z -> memval) {struct vl}: Z -> memval := + match vl with + | nil => c + | v :: vl' => setN vl' (p + 1) (update p v c) + end. + +Definition unchecked_store (chunk: memory_chunk) (m: mem) (b: block) (ofs: Z) (v: val): mem := + mkmem (update b + (setN (encode_val chunk v) ofs (m.(contents) b)) + m.(contents)) + m.(access) + m.(bound) + m.(next) + m.(next_pos) + m.(next_noaccess) + m.(bound_noaccess). + +(** [store chunk m b ofs v] perform a write in memory state [m]. + Value [v] is stored at address [b] and offset [ofs]. + Return the updated memory store, or [None] if the accessed bytes + are not writable. *) + +Definition store (chunk: memory_chunk) (m: mem) (b: block) (ofs: Z) (v: val): option mem := + if valid_access_dec m chunk b ofs Writable + then Some(unchecked_store chunk m b ofs v) + else None. + +(** [storev chunk m addr v] is similar, but the address and offset are given + as a single value [addr], which must be a pointer value. *) + +Definition storev (chunk: memory_chunk) (m: mem) (addr v: val) : option mem := + match addr with + | Vptr b ofs => store chunk m b (Int.signed ofs) v + | _ => None + end. + +(** * Properties of the memory operations *) + +(** Properties of the empty store. *) + +Theorem nextblock_empty: nextblock empty = 1. +Proof. reflexivity. Qed. + +Theorem perm_empty: forall b ofs p, ~perm empty b ofs p. +Proof. + intros. unfold perm, empty; simpl. congruence. +Qed. + +Theorem valid_access_empty: forall chunk b ofs p, ~valid_access empty chunk b ofs p. +Proof. + intros. red; intros. elim (perm_empty b ofs p). apply H. + generalize (size_chunk_pos chunk); omega. +Qed. + +(** ** Properties related to [load] *) + +Theorem valid_access_load: + forall m chunk b ofs, + valid_access m chunk b ofs Readable -> + exists v, load chunk m b ofs = Some v. +Proof. + intros. econstructor. unfold load. rewrite pred_dec_true; eauto. +Qed. + +Theorem load_valid_access: + forall m chunk b ofs v, + load chunk m b ofs = Some v -> + valid_access m chunk b ofs Readable. +Proof. + intros until v. unfold load. + destruct (valid_access_dec m chunk b ofs Readable); intros. + auto. + congruence. +Qed. + +Lemma load_result: + forall chunk m b ofs v, + load chunk m b ofs = Some v -> + v = decode_val chunk (getN (size_chunk_nat chunk) ofs (m.(contents) b)). +Proof. + intros until v. unfold load. + destruct (valid_access_dec m chunk b ofs Readable); intros. + congruence. + congruence. +Qed. + +Hint Local Resolve load_valid_access valid_access_load: mem. + +Theorem load_type: + forall m chunk b ofs v, + load chunk m b ofs = Some v -> + Val.has_type v (type_of_chunk chunk). +Proof. + intros. exploit load_result; eauto; intros. rewrite H0. + apply decode_val_type. +Qed. + +Theorem load_cast: + forall m chunk b ofs v, + load chunk m b ofs = Some v -> + match chunk with + | Mint8signed => v = Val.sign_ext 8 v + | Mint8unsigned => v = Val.zero_ext 8 v + | Mint16signed => v = Val.sign_ext 16 v + | Mint16unsigned => v = Val.zero_ext 16 v + | Mfloat32 => v = Val.singleoffloat v + | _ => True + end. +Proof. + intros. exploit load_result; eauto. + set (l := getN (size_chunk_nat chunk) ofs (contents m b)). + intros. subst v. apply decode_val_cast. +Qed. + +Theorem load_int8_signed_unsigned: + forall m b ofs, + load Mint8signed m b ofs = option_map (Val.sign_ext 8) (load Mint8unsigned m b ofs). +Proof. + intros. unfold load. + change (size_chunk_nat Mint8signed) with (size_chunk_nat Mint8unsigned). + set (cl := getN (size_chunk_nat Mint8unsigned) ofs (contents m b)). + destruct (valid_access_dec m Mint8signed b ofs Readable). + rewrite pred_dec_true; auto. unfold decode_val. + destruct (proj_bytes cl); auto. rewrite decode_int8_signed_unsigned. auto. + rewrite pred_dec_false; auto. +Qed. + +Theorem load_int16_signed_unsigned: + forall m b ofs, + load Mint16signed m b ofs = option_map (Val.sign_ext 16) (load Mint16unsigned m b ofs). +Proof. + intros. unfold load. + change (size_chunk_nat Mint16signed) with (size_chunk_nat Mint16unsigned). + set (cl := getN (size_chunk_nat Mint16unsigned) ofs (contents m b)). + destruct (valid_access_dec m Mint16signed b ofs Readable). + rewrite pred_dec_true; auto. unfold decode_val. + destruct (proj_bytes cl); auto. rewrite decode_int16_signed_unsigned. auto. + rewrite pred_dec_false; auto. +Qed. + +Theorem loadbytes_load: + forall chunk m b ofs bytes, + loadbytes m b ofs (size_chunk chunk) = Some bytes -> + (align_chunk chunk | ofs) -> + load chunk m b ofs = + Some(match type_of_chunk chunk with + | Tint => Vint(decode_int chunk bytes) + | Tfloat => Vfloat(decode_float chunk bytes) + end). +Proof. + unfold loadbytes, load; intros. + destruct (range_perm_dec m b ofs (ofs + size_chunk chunk) Readable); + try congruence. + rewrite pred_dec_true. decEq. unfold size_chunk_nat. + unfold decode_val; rewrite H. destruct chunk; auto. + split; auto. +Qed. + +Theorem load_int_loadbytes: + forall chunk m b ofs n, + load chunk m b ofs = Some(Vint n) -> + type_of_chunk chunk = Tint /\ + exists bytes, loadbytes m b ofs (size_chunk chunk) = Some bytes + /\ n = decode_int chunk bytes. +Proof. + intros. exploit load_valid_access; eauto. intros [A B]. + exploit decode_val_int_inv. symmetry. eapply load_result; eauto. + intros [C [bytes [D E]]]. + split. auto. exists bytes; split. + unfold loadbytes. rewrite pred_dec_true; auto. auto. +Qed. + +Theorem load_float_loadbytes: + forall chunk m b ofs f, + load chunk m b ofs = Some(Vfloat f) -> + type_of_chunk chunk = Tfloat /\ + exists bytes, loadbytes m b ofs (size_chunk chunk) = Some bytes + /\ f = decode_float chunk bytes. +Proof. + intros. exploit load_valid_access; eauto. intros [A B]. + exploit decode_val_float_inv. symmetry. eapply load_result; eauto. + intros [C [bytes [D E]]]. + split. auto. exists bytes; split. + unfold loadbytes. rewrite pred_dec_true; auto. auto. +Qed. + +Lemma getN_length: + forall c n p, length (getN n p c) = n. +Proof. + induction n; simpl; intros. auto. decEq; auto. +Qed. + +Theorem loadbytes_length: + forall m b ofs n bytes, + loadbytes m b ofs n = Some bytes -> + length bytes = nat_of_Z n. +Proof. + unfold loadbytes; intros. + destruct (range_perm_dec m b ofs (ofs + n) Readable); try congruence. + exploit inj_proj_bytes; eauto. intros. + transitivity (length (inj_bytes bytes)). + symmetry. unfold inj_bytes. apply List.map_length. + rewrite <- H0. apply getN_length. +Qed. + +Lemma getN_concat: + forall c n1 n2 p, + getN (n1 + n2)%nat p c = getN n1 p c ++ getN n2 (p + Z_of_nat n1) c. +Proof. + induction n1; intros. + simpl. decEq. omega. + rewrite inj_S. simpl. decEq. + replace (p + Zsucc (Z_of_nat n1)) with ((p + 1) + Z_of_nat n1) by omega. + auto. +Qed. + +Theorem loadbytes_concat: + forall m b ofs n1 n2 bytes1 bytes2, + loadbytes m b ofs n1 = Some bytes1 -> + loadbytes m b (ofs + n1) n2 = Some bytes2 -> + n1 >= 0 -> n2 >= 0 -> + loadbytes m b ofs (n1 + n2) = Some(bytes1 ++ bytes2). +Proof. + unfold loadbytes; intros. + destruct (range_perm_dec m b ofs (ofs + n1) Readable); try congruence. + destruct (range_perm_dec m b (ofs + n1) (ofs + n1 + n2) Readable); try congruence. + rewrite pred_dec_true. rewrite nat_of_Z_plus; auto. + rewrite getN_concat. rewrite nat_of_Z_eq; auto. + rewrite (inj_proj_bytes _ _ H). rewrite (inj_proj_bytes _ _ H0). + unfold inj_bytes. rewrite <- List.map_app. apply proj_inj_bytes. + red; intros. + assert (ofs0 < ofs + n1 \/ ofs0 >= ofs + n1) by omega. + destruct H4. apply r; omega. apply r0; omega. +Qed. + +Theorem loadbytes_split: + forall m b ofs n1 n2 bytes, + loadbytes m b ofs (n1 + n2) = Some bytes -> + n1 >= 0 -> n2 >= 0 -> + exists bytes1, exists bytes2, + loadbytes m b ofs n1 = Some bytes1 + /\ loadbytes m b (ofs + n1) n2 = Some bytes2 + /\ bytes = bytes1 ++ bytes2. +Proof. + unfold loadbytes; intros. + destruct (range_perm_dec m b ofs (ofs + (n1 + n2)) Readable); + try congruence. + rewrite nat_of_Z_plus in H; auto. rewrite getN_concat in H. + rewrite nat_of_Z_eq in H; auto. + repeat rewrite pred_dec_true. + exploit inj_proj_bytes; eauto. unfold inj_bytes. intros. + exploit list_append_map_inv; eauto. intros [l1 [l2 [P [Q R]]]]. + exists l1; exists l2; intuition. + rewrite <- P. apply proj_inj_bytes. + rewrite <- Q. apply proj_inj_bytes. + red; intros; apply r; omega. + red; intros; apply r; omega. +Qed. + +(** ** Properties related to [store] *) + +Theorem valid_access_store: + forall m1 chunk b ofs v, + valid_access m1 chunk b ofs Writable -> + { m2: mem | store chunk m1 b ofs v = Some m2 }. +Proof. + intros. econstructor. unfold store. rewrite pred_dec_true; auto. +Qed. + +Hint Local Resolve valid_access_store: mem. + +Section STORE. +Variable chunk: memory_chunk. +Variable m1: mem. +Variable b: block. +Variable ofs: Z. +Variable v: val. +Variable m2: mem. +Hypothesis STORE: store chunk m1 b ofs v = Some m2. + +Lemma store_result: + m2 = unchecked_store chunk m1 b ofs v. +Proof. + unfold store in STORE. + destruct (valid_access_dec m1 chunk b ofs Writable). + congruence. + congruence. +Qed. + +Theorem perm_store_1: + forall b' ofs' p, perm m1 b' ofs' p -> perm m2 b' ofs' p. +Proof. + intros. rewrite store_result. exact H. +Qed. + +Theorem perm_store_2: + forall b' ofs' p, perm m2 b' ofs' p -> perm m1 b' ofs' p. +Proof. + intros. rewrite store_result in H. exact H. +Qed. + +Hint Local Resolve perm_store_1 perm_store_2: mem. + +Theorem nextblock_store: + nextblock m2 = nextblock m1. +Proof. + intros. rewrite store_result. reflexivity. +Qed. + +Theorem store_valid_block_1: + forall b', valid_block m1 b' -> valid_block m2 b'. +Proof. + unfold valid_block; intros. rewrite nextblock_store; auto. +Qed. + +Theorem store_valid_block_2: + forall b', valid_block m2 b' -> valid_block m1 b'. +Proof. + unfold valid_block; intros. rewrite nextblock_store in H; auto. +Qed. + +Hint Local Resolve store_valid_block_1 store_valid_block_2: mem. + +Theorem store_valid_access_1: + forall chunk' b' ofs' p, + valid_access m1 chunk' b' ofs' p -> valid_access m2 chunk' b' ofs' p. +Proof. + intros. inv H. constructor; try red; auto with mem. +Qed. + +Theorem store_valid_access_2: + forall chunk' b' ofs' p, + valid_access m2 chunk' b' ofs' p -> valid_access m1 chunk' b' ofs' p. +Proof. + intros. inv H. constructor; try red; auto with mem. +Qed. + +Theorem store_valid_access_3: + valid_access m1 chunk b ofs Writable. +Proof. + unfold store in STORE. destruct (valid_access_dec m1 chunk b ofs Writable). + auto. + congruence. +Qed. + +Hint Local Resolve store_valid_access_1 store_valid_access_2 + store_valid_access_3: mem. + +Theorem bounds_store: + forall b', bounds m2 b' = bounds m1 b'. +Proof. + intros. rewrite store_result. simpl. auto. +Qed. + +Remark setN_other: + forall vl c p q, + (forall r, p <= r < p + Z_of_nat (length vl) -> r <> q) -> + setN vl p c q = c q. +Proof. + induction vl; intros; simpl. + auto. + simpl length in H. rewrite inj_S in H. + transitivity (update p a c q). + apply IHvl. intros. apply H. omega. + apply update_o. apply H. omega. +Qed. + +Remark setN_outside: + forall vl c p q, + q < p \/ q >= p + Z_of_nat (length vl) -> + setN vl p c q = c q. +Proof. + intros. apply setN_other. + intros. omega. +Qed. + +Remark getN_setN_same: + forall vl p c, + getN (length vl) p (setN vl p c) = vl. +Proof. + induction vl; intros; simpl. + auto. + decEq. + rewrite setN_outside. apply update_s. omega. + apply IHvl. +Qed. + +Remark getN_setN_outside: + forall vl q c n p, + p + Z_of_nat n <= q \/ q + Z_of_nat (length vl) <= p -> + getN n p (setN vl q c) = getN n p c. +Proof. + induction n; intros; simpl. + auto. + rewrite inj_S in H. decEq. + apply setN_outside. omega. + apply IHn. omega. +Qed. + +Theorem load_store_similar: + forall chunk', + size_chunk chunk' = size_chunk chunk -> + exists v', load chunk' m2 b ofs = Some v' /\ decode_encode_val v chunk chunk' v'. +Proof. + intros. + exploit (valid_access_load m2 chunk'). + eapply valid_access_compat. symmetry; eauto. eauto with mem. + intros [v' LOAD]. + exists v'; split; auto. + exploit load_result; eauto. intros B. + rewrite B. rewrite store_result; simpl. + rewrite update_s. + replace (size_chunk_nat chunk') with (length (encode_val chunk v)). + rewrite getN_setN_same. apply decode_encode_val_general. + rewrite encode_val_length. repeat rewrite size_chunk_conv in H. + apply inj_eq_rev; auto. +Qed. + +Theorem load_store_same: + Val.has_type v (type_of_chunk chunk) -> + load chunk m2 b ofs = Some (Val.load_result chunk v). +Proof. + intros. + destruct (load_store_similar chunk) as [v' [A B]]. auto. + rewrite A. decEq. eapply decode_encode_val_similar; eauto. +Qed. + +Theorem load_store_other: + forall chunk' b' ofs', + b' <> b + \/ ofs' + size_chunk chunk' <= ofs + \/ ofs + size_chunk chunk <= ofs' -> + load chunk' m2 b' ofs' = load chunk' m1 b' ofs'. +Proof. + intros. unfold load. + destruct (valid_access_dec m1 chunk' b' ofs' Readable). + rewrite pred_dec_true. + decEq. decEq. rewrite store_result; unfold unchecked_store; simpl. + unfold update. destruct (zeq b' b). subst b'. + apply getN_setN_outside. rewrite encode_val_length. repeat rewrite <- size_chunk_conv. + intuition. + auto. + eauto with mem. + rewrite pred_dec_false. auto. + eauto with mem. +Qed. + +Theorem loadbytes_store_same: + loadbytes m2 b ofs (size_chunk chunk) = + match v with + | Vundef => None + | Vint n => Some(encode_int chunk n) + | Vfloat n => Some(encode_float chunk n) + | Vptr _ _ => None + end. +Proof. + intros. + assert (valid_access m2 chunk b ofs Readable) by eauto with mem. + unfold loadbytes. rewrite pred_dec_true. rewrite store_result; simpl. + rewrite update_s. + replace (nat_of_Z (size_chunk chunk)) + with (length (encode_val chunk v)). + rewrite getN_setN_same. + destruct (size_chunk_nat_pos chunk) as [sz1 EQ]. + unfold encode_val; destruct v. + rewrite EQ; auto. + apply proj_inj_bytes. + apply proj_inj_bytes. + rewrite EQ; destruct chunk; auto. + apply encode_val_length. + apply H. +Qed. + +Theorem loadbytes_store_other: + forall b' ofs' n, + b' <> b + \/ n <= 0 + \/ ofs' + n <= ofs + \/ ofs + size_chunk chunk <= ofs' -> + loadbytes m2 b' ofs' n = loadbytes m1 b' ofs' n. +Proof. + intros. unfold loadbytes. + destruct (range_perm_dec m1 b' ofs' (ofs' + n) Readable). + rewrite pred_dec_true. + decEq. rewrite store_result; unfold unchecked_store; simpl. + unfold update. destruct (zeq b' b). subst b'. + destruct H. congruence. + destruct (zle n 0). + rewrite (nat_of_Z_neg _ z). auto. + destruct H. omegaContradiction. + apply getN_setN_outside. rewrite encode_val_length. rewrite <- size_chunk_conv. + rewrite nat_of_Z_eq. auto. omega. + auto. + red; intros. eauto with mem. + rewrite pred_dec_false. auto. + red; intro; elim n0; red; intros; eauto with mem. +Qed. + +Lemma setN_property: + forall (P: memval -> Prop) vl p q c, + (forall v, In v vl -> P v) -> + p <= q < p + Z_of_nat (length vl) -> + P(setN vl p c q). +Proof. + induction vl; intros. + simpl in H0. omegaContradiction. + simpl length in H0. rewrite inj_S in H0. simpl. + destruct (zeq p q). subst q. rewrite setN_outside. rewrite update_s. + auto with coqlib. omega. + apply IHvl. auto with coqlib. omega. +Qed. + +Lemma getN_in: + forall c q n p, + p <= q < p + Z_of_nat n -> + In (c q) (getN n p c). +Proof. + induction n; intros. + simpl in H; omegaContradiction. + rewrite inj_S in H. simpl. destruct (zeq p q). + subst q. auto. + right. apply IHn. omega. +Qed. + +Theorem load_pointer_store: + forall chunk' b' ofs' v_b v_o, + load chunk' m2 b' ofs' = Some(Vptr v_b v_o) -> + (chunk = Mint32 /\ v = Vptr v_b v_o /\ chunk' = Mint32 /\ b' = b /\ ofs' = ofs) + \/ (b' <> b \/ ofs' + size_chunk chunk' <= ofs \/ ofs + size_chunk chunk <= ofs'). +Proof. + intros. exploit load_result; eauto. rewrite store_result; simpl. + unfold update. destruct (zeq b' b); auto. subst b'. intro DEC. + destruct (zle (ofs' + size_chunk chunk') ofs); auto. + destruct (zle (ofs + size_chunk chunk) ofs'); auto. + destruct (size_chunk_nat_pos chunk) as [sz SZ]. + destruct (size_chunk_nat_pos chunk') as [sz' SZ']. + exploit decode_pointer_shape; eauto. intros [CHUNK' PSHAPE]. clear CHUNK'. + generalize (encode_val_shape chunk v). intro VSHAPE. + set (c := contents m1 b) in *. + set (c' := setN (encode_val chunk v) ofs c) in *. + destruct (zeq ofs ofs'). + +(* 1. ofs = ofs': must be same chunks and same value *) + subst ofs'. inv VSHAPE. + exploit decode_val_pointer_inv; eauto. intros [A B]. + subst chunk'. simpl in B. inv B. + generalize H4. unfold c'. rewrite <- H0. simpl. + rewrite setN_outside; try omega. rewrite update_s. intros. + exploit (encode_val_pointer_inv chunk v v_b v_o). + rewrite <- H0. subst mv1. eauto. intros [C [D E]]. + left; auto. + + destruct (zlt ofs ofs'). + +(* 2. ofs < ofs': + + ofs ofs' ofs+|chunk| + [-------------------] write + [-------------------] read + + The byte at ofs' satisfies memval_valid_cont (consequence of write). + For the read to return a pointer, it must satisfy ~memval_valid_cont. +*) + elimtype False. + assert (~memval_valid_cont (c' ofs')). + rewrite SZ' in PSHAPE. simpl in PSHAPE. inv PSHAPE. auto. + assert (memval_valid_cont (c' ofs')). + inv VSHAPE. unfold c'. rewrite <- H1. simpl. + apply setN_property. auto. + assert (length mvl = sz). + generalize (encode_val_length chunk v). rewrite <- H1. rewrite SZ. + simpl; congruence. + rewrite H4. rewrite size_chunk_conv in z0. omega. + contradiction. + +(* 3. ofs > ofs': + + ofs' ofs ofs'+|chunk'| + [-------------------] write + [----------------] read + + The byte at ofs satisfies memval_valid_first (consequence of write). + For the read to return a pointer, it must satisfy ~memval_valid_first. +*) + elimtype False. + assert (memval_valid_first (c' ofs)). + inv VSHAPE. unfold c'. rewrite <- H0. simpl. + rewrite setN_outside. rewrite update_s. auto. omega. + assert (~memval_valid_first (c' ofs)). + rewrite SZ' in PSHAPE. simpl in PSHAPE. inv PSHAPE. + apply H4. apply getN_in. rewrite size_chunk_conv in z. + rewrite SZ' in z. rewrite inj_S in z. omega. + contradiction. +Qed. + +End STORE. + +Hint Local Resolve perm_store_1 perm_store_2: mem. +Hint Local Resolve store_valid_block_1 store_valid_block_2: mem. +Hint Local Resolve store_valid_access_1 store_valid_access_2 + store_valid_access_3: mem. + +Theorem load_store_pointer_overlap: + forall chunk m1 b ofs v_b v_o m2 chunk' ofs' v, + store chunk m1 b ofs (Vptr v_b v_o) = Some m2 -> + load chunk' m2 b ofs' = Some v -> + ofs' <> ofs -> + ofs' + size_chunk chunk' > ofs -> + ofs + size_chunk chunk > ofs' -> + v = Vundef. +Proof. + intros. + exploit store_result; eauto. intro ST. + exploit load_result; eauto. intro LD. + rewrite LD; clear LD. +Opaque encode_val. + rewrite ST; simpl. + rewrite update_s. + set (c := contents m1 b). + set (c' := setN (encode_val chunk (Vptr v_b v_o)) ofs c). + destruct (decode_val_shape chunk' (getN (size_chunk_nat chunk') ofs' c')) + as [OK | VSHAPE]. + apply getN_length. + exact OK. + elimtype False. + destruct (size_chunk_nat_pos chunk) as [sz SZ]. + destruct (size_chunk_nat_pos chunk') as [sz' SZ']. + assert (ENC: encode_val chunk (Vptr v_b v_o) = list_repeat (size_chunk_nat chunk) Undef + \/ pointer_encoding_shape (encode_val chunk (Vptr v_b v_o))). + destruct chunk; try (left; reflexivity). + right. apply encode_pointer_shape. + assert (GET: getN (size_chunk_nat chunk) ofs c' = encode_val chunk (Vptr v_b v_o)). + unfold c'. rewrite <- (encode_val_length chunk (Vptr v_b v_o)). + apply getN_setN_same. + destruct (zlt ofs ofs'). + +(* ofs < ofs': + + ofs ofs' ofs+|chunk| + [-------------------] write + [-------------------] read + + The byte at ofs' is Undef or not memval_valid_first (because write of pointer). + The byte at ofs' must be memval_valid_first and not Undef (otherwise load returns Vundef). +*) + assert (memval_valid_first (c' ofs') /\ c' ofs' <> Undef). + rewrite SZ' in VSHAPE. simpl in VSHAPE. inv VSHAPE. auto. + assert (~memval_valid_first (c' ofs') \/ c' ofs' = Undef). + unfold c'. destruct ENC. + right. apply setN_property. rewrite H5. intros. eapply in_list_repeat; eauto. + rewrite encode_val_length. rewrite <- size_chunk_conv. omega. + left. revert H5. rewrite <- GET. rewrite SZ. simpl. intros. inv H5. + apply setN_property. apply H9. rewrite getN_length. + rewrite size_chunk_conv in H3. rewrite SZ in H3. rewrite inj_S in H3. omega. + intuition. + +(* ofs > ofs': + + ofs' ofs ofs'+|chunk'| + [-------------------] write + [----------------] read + + The byte at ofs is Undef or not memval_valid_cont (because write of pointer). + The byte at ofs must be memval_valid_cont and not Undef (otherwise load returns Vundef). +*) + assert (memval_valid_cont (c' ofs) /\ c' ofs <> Undef). + rewrite SZ' in VSHAPE. simpl in VSHAPE. inv VSHAPE. + apply H8. apply getN_in. rewrite size_chunk_conv in H2. + rewrite SZ' in H2. rewrite inj_S in H2. omega. + assert (~memval_valid_cont (c' ofs) \/ c' ofs = Undef). + elim ENC. + rewrite <- GET. rewrite SZ. simpl. intros. right; congruence. + rewrite <- GET. rewrite SZ. simpl. intros. inv H5. auto. + intuition. +Qed. + +Theorem load_store_pointer_mismatch: + forall chunk m1 b ofs v_b v_o m2 chunk' v, + store chunk m1 b ofs (Vptr v_b v_o) = Some m2 -> + load chunk' m2 b ofs = Some v -> + chunk <> Mint32 \/ chunk' <> Mint32 -> + v = Vundef. +Proof. + intros. + exploit store_result; eauto. intro ST. + exploit load_result; eauto. intro LD. + rewrite LD; clear LD. +Opaque encode_val. + rewrite ST; simpl. + rewrite update_s. + set (c1 := contents m1 b). + set (e := encode_val chunk (Vptr v_b v_o)). + destruct (size_chunk_nat_pos chunk) as [sz SZ]. + destruct (size_chunk_nat_pos chunk') as [sz' SZ']. + assert (match e with + | Undef :: _ => True + | Pointer _ _ _ :: _ => chunk = Mint32 + | _ => False + end). +Transparent encode_val. + unfold e, encode_val. rewrite SZ. destruct chunk; simpl; auto. + destruct e as [ | e1 el]. contradiction. + rewrite SZ'. simpl. rewrite setN_outside. rewrite update_s. + destruct e1; try contradiction. + destruct chunk'; auto. + destruct chunk'; auto. intuition. + omega. +Qed. + +Lemma store_similar_chunks: + forall chunk1 chunk2 v1 v2 m b ofs, + encode_val chunk1 v1 = encode_val chunk2 v2 -> + store chunk1 m b ofs v1 = store chunk2 m b ofs v2. +Proof. + intros. unfold store. + assert (size_chunk chunk1 = size_chunk chunk2). + repeat rewrite size_chunk_conv. + rewrite <- (encode_val_length chunk1 v1). + rewrite <- (encode_val_length chunk2 v2). + congruence. + unfold store. + destruct (valid_access_dec m chunk1 b ofs Writable). + rewrite pred_dec_true. unfold unchecked_store. congruence. + eapply valid_access_compat; eauto. + rewrite pred_dec_false; auto. + red; intro; elim n. apply valid_access_compat with chunk2; auto. +Qed. + +Theorem store_signed_unsigned_8: + forall m b ofs v, + store Mint8signed m b ofs v = store Mint8unsigned m b ofs v. +Proof. intros. apply store_similar_chunks. apply encode_val_int8_signed_unsigned. Qed. + +Theorem store_signed_unsigned_16: + forall m b ofs v, + store Mint16signed m b ofs v = store Mint16unsigned m b ofs v. +Proof. intros. apply store_similar_chunks. apply encode_val_int16_signed_unsigned. Qed. + +Theorem store_int8_zero_ext: + forall m b ofs n, + store Mint8unsigned m b ofs (Vint (Int.zero_ext 8 n)) = + store Mint8unsigned m b ofs (Vint n). +Proof. intros. apply store_similar_chunks. apply encode_val_int8_zero_ext. Qed. + +Theorem store_int8_sign_ext: + forall m b ofs n, + store Mint8signed m b ofs (Vint (Int.sign_ext 8 n)) = + store Mint8signed m b ofs (Vint n). +Proof. intros. apply store_similar_chunks. apply encode_val_int8_sign_ext. Qed. + +Theorem store_int16_zero_ext: + forall m b ofs n, + store Mint16unsigned m b ofs (Vint (Int.zero_ext 16 n)) = + store Mint16unsigned m b ofs (Vint n). +Proof. intros. apply store_similar_chunks. apply encode_val_int16_zero_ext. Qed. + +Theorem store_int16_sign_ext: + forall m b ofs n, + store Mint16signed m b ofs (Vint (Int.sign_ext 16 n)) = + store Mint16signed m b ofs (Vint n). +Proof. intros. apply store_similar_chunks. apply encode_val_int16_sign_ext. Qed. + +Theorem store_float32_truncate: + forall m b ofs n, + store Mfloat32 m b ofs (Vfloat (Float.singleoffloat n)) = + store Mfloat32 m b ofs (Vfloat n). +Proof. intros. apply store_similar_chunks. simpl. decEq. apply encode_float32_cast. Qed. + +(** ** Properties related to [alloc]. *) + +Section ALLOC. + +Variable m1: mem. +Variables lo hi: Z. +Variable m2: mem. +Variable b: block. +Hypothesis ALLOC: alloc m1 lo hi = (m2, b). + +Theorem nextblock_alloc: + nextblock m2 = Zsucc (nextblock m1). +Proof. + injection ALLOC; intros. rewrite <- H0; auto. +Qed. + +Theorem alloc_result: + b = nextblock m1. +Proof. + injection ALLOC; auto. +Qed. + +Theorem valid_block_alloc: + forall b', valid_block m1 b' -> valid_block m2 b'. +Proof. + unfold valid_block; intros. rewrite nextblock_alloc. omega. +Qed. + +Theorem fresh_block_alloc: + ~(valid_block m1 b). +Proof. + unfold valid_block. rewrite alloc_result. omega. +Qed. + +Theorem valid_new_block: + valid_block m2 b. +Proof. + unfold valid_block. rewrite alloc_result. rewrite nextblock_alloc. omega. +Qed. + +Hint Local Resolve valid_block_alloc fresh_block_alloc valid_new_block: mem. + +Theorem valid_block_alloc_inv: + forall b', valid_block m2 b' -> b' = b \/ valid_block m1 b'. +Proof. + unfold valid_block; intros. + rewrite nextblock_alloc in H. rewrite alloc_result. + unfold block; omega. +Qed. + +Theorem perm_alloc_1: + forall b' ofs p, perm m1 b' ofs p -> perm m2 b' ofs p. +Proof. + unfold perm; intros. injection ALLOC; intros. rewrite <- H1; simpl. + subst b. unfold update. destruct (zeq b' (next m1)); auto. + assert (access m1 b' ofs = false). apply next_noaccess. omega. congruence. +Qed. + +Theorem perm_alloc_2: + forall ofs, lo <= ofs < hi -> perm m2 b ofs Writable. +Proof. + unfold perm; intros. injection ALLOC; intros. rewrite <- H1; simpl. + subst b. rewrite update_s. unfold proj_sumbool. rewrite zle_true. + rewrite zlt_true. auto. omega. omega. +Qed. + +Theorem perm_alloc_3: + forall ofs p, ofs < lo \/ hi <= ofs -> ~perm m2 b ofs p. +Proof. + unfold perm; intros. injection ALLOC; intros. rewrite <- H1; simpl. + subst b. rewrite update_s. unfold proj_sumbool. + destruct H. rewrite zle_false. simpl. congruence. omega. + rewrite zlt_false. rewrite andb_false_r. congruence. omega. +Qed. + +Hint Local Resolve perm_alloc_1 perm_alloc_2 perm_alloc_3: mem. + +Theorem perm_alloc_inv: + forall b' ofs p, + perm m2 b' ofs p -> + if zeq b' b then lo <= ofs < hi else perm m1 b' ofs p. +Proof. + intros until p; unfold perm. inv ALLOC. simpl. + unfold update. destruct (zeq b' (next m1)); intros. + destruct (andb_prop _ _ H). + split; eapply proj_sumbool_true; eauto. + auto. +Qed. + +Theorem valid_access_alloc_other: + forall chunk b' ofs p, + valid_access m1 chunk b' ofs p -> + valid_access m2 chunk b' ofs p. +Proof. + intros. inv H. constructor; auto with mem. + red; auto with mem. +Qed. + +Theorem valid_access_alloc_same: + forall chunk ofs, + lo <= ofs -> ofs + size_chunk chunk <= hi -> (align_chunk chunk | ofs) -> + valid_access m2 chunk b ofs Writable. +Proof. + intros. constructor; auto with mem. + red; intros. apply perm_alloc_2. omega. +Qed. + +Hint Local Resolve valid_access_alloc_other valid_access_alloc_same: mem. + +Theorem valid_access_alloc_inv: + forall chunk b' ofs p, + valid_access m2 chunk b' ofs p -> + if eq_block b' b + then lo <= ofs /\ ofs + size_chunk chunk <= hi /\ (align_chunk chunk | ofs) + else valid_access m1 chunk b' ofs p. +Proof. + intros. inv H. + generalize (size_chunk_pos chunk); intro. + unfold eq_block. destruct (zeq b' b). subst b'. + assert (perm m2 b ofs p). apply H0. omega. + assert (perm m2 b (ofs + size_chunk chunk - 1) p). apply H0. omega. + exploit perm_alloc_inv. eexact H2. rewrite zeq_true. intro. + exploit perm_alloc_inv. eexact H3. rewrite zeq_true. intro. + intuition omega. + split; auto. red; intros. + exploit perm_alloc_inv. apply H0. eauto. rewrite zeq_false; auto. +Qed. + +Theorem bounds_alloc: + forall b', bounds m2 b' = if eq_block b' b then (lo, hi) else bounds m1 b'. +Proof. + injection ALLOC; intros. rewrite <- H; rewrite <- H0; simpl. + unfold update. auto. +Qed. + +Theorem bounds_alloc_same: + bounds m2 b = (lo, hi). +Proof. + rewrite bounds_alloc. apply dec_eq_true. +Qed. + +Theorem bounds_alloc_other: + forall b', b' <> b -> bounds m2 b' = bounds m1 b'. +Proof. + intros. rewrite bounds_alloc. apply dec_eq_false. auto. +Qed. + +Theorem load_alloc_unchanged: + forall chunk b' ofs, + valid_block m1 b' -> + load chunk m2 b' ofs = load chunk m1 b' ofs. +Proof. + intros. unfold load. + destruct (valid_access_dec m2 chunk b' ofs Readable). + exploit valid_access_alloc_inv; eauto. destruct (eq_block b' b); intros. + subst b'. elimtype False. eauto with mem. + rewrite pred_dec_true; auto. + injection ALLOC; intros. rewrite <- H2; simpl. + rewrite update_o. auto. rewrite H1. apply sym_not_equal; eauto with mem. + rewrite pred_dec_false. auto. + eauto with mem. +Qed. + +Theorem load_alloc_other: + forall chunk b' ofs v, + load chunk m1 b' ofs = Some v -> + load chunk m2 b' ofs = Some v. +Proof. + intros. rewrite <- H. apply load_alloc_unchanged. eauto with mem. +Qed. + +Theorem load_alloc_same: + forall chunk ofs v, + load chunk m2 b ofs = Some v -> + v = Vundef. +Proof. + intros. exploit load_result; eauto. intro. rewrite H0. + injection ALLOC; intros. rewrite <- H2; simpl. rewrite <- H1. + rewrite update_s. destruct chunk; reflexivity. +Qed. + +Theorem load_alloc_same': + forall chunk ofs, + lo <= ofs -> ofs + size_chunk chunk <= hi -> (align_chunk chunk | ofs) -> + load chunk m2 b ofs = Some Vundef. +Proof. + intros. assert (exists v, load chunk m2 b ofs = Some v). + apply valid_access_load. constructor; auto. + red; intros. eapply perm_implies. apply perm_alloc_2. omega. auto with mem. + destruct H2 as [v LOAD]. rewrite LOAD. decEq. + eapply load_alloc_same; eauto. +Qed. + +End ALLOC. + +Hint Local Resolve valid_block_alloc fresh_block_alloc valid_new_block: mem. +Hint Local Resolve valid_access_alloc_other valid_access_alloc_same: mem. + +(** ** Properties related to [free]. *) + +Theorem range_perm_free: + forall m1 b lo hi, + range_perm m1 b lo hi Freeable -> + { m2: mem | free m1 b lo hi = Some m2 }. +Proof. + intros; unfold free. rewrite pred_dec_true; auto. econstructor; eauto. +Qed. + +Section FREE. + +Variable m1: mem. +Variable bf: block. +Variables lo hi: Z. +Variable m2: mem. +Hypothesis FREE: free m1 bf lo hi = Some m2. + +Theorem free_range_perm: + range_perm m1 bf lo hi Writable. +Proof. + unfold free in FREE. destruct (range_perm_dec m1 bf lo hi Freeable). + auto. congruence. +Qed. + +Lemma free_result: + m2 = unchecked_free m1 bf lo hi. +Proof. + unfold free in FREE. destruct (range_perm_dec m1 bf lo hi Freeable). + congruence. congruence. +Qed. + +Theorem nextblock_free: + nextblock m2 = nextblock m1. +Proof. + rewrite free_result; reflexivity. +Qed. + +Theorem valid_block_free_1: + forall b, valid_block m1 b -> valid_block m2 b. +Proof. + intros. rewrite free_result. assumption. +Qed. + +Theorem valid_block_free_2: + forall b, valid_block m2 b -> valid_block m1 b. +Proof. + intros. rewrite free_result in H. assumption. +Qed. + +Hint Local Resolve valid_block_free_1 valid_block_free_2: mem. + +Theorem perm_free_1: + forall b ofs p, + b <> bf \/ ofs < lo \/ hi <= ofs -> + perm m1 b ofs p -> + perm m2 b ofs p. +Proof. + intros. rewrite free_result. unfold perm, unchecked_free; simpl. + unfold update. destruct (zeq b bf). subst b. + destruct (zle lo ofs); simpl. + destruct (zlt ofs hi); simpl. + elimtype False; intuition. + auto. auto. + auto. +Qed. + +Theorem perm_free_2: + forall ofs p, lo <= ofs < hi -> ~ perm m2 bf ofs p. +Proof. + intros. rewrite free_result. unfold perm, unchecked_free; simpl. + rewrite update_s. unfold proj_sumbool. rewrite zle_true. rewrite zlt_true. + simpl. congruence. omega. omega. +Qed. + +Theorem perm_free_3: + forall b ofs p, + perm m2 b ofs p -> perm m1 b ofs p. +Proof. + intros until p. rewrite free_result. unfold perm, unchecked_free; simpl. + unfold update. destruct (zeq b bf). subst b. + destruct (zle lo ofs); simpl. + destruct (zlt ofs hi); simpl. + congruence. auto. auto. + auto. +Qed. + +Theorem valid_access_free_1: + forall chunk b ofs p, + valid_access m1 chunk b ofs p -> + b <> bf \/ lo >= hi \/ ofs + size_chunk chunk <= lo \/ hi <= ofs -> + valid_access m2 chunk b ofs p. +Proof. + intros. inv H. constructor; auto with mem. + red; intros. eapply perm_free_1; eauto. + destruct (zlt lo hi). intuition. right. omega. +Qed. + +Theorem valid_access_free_2: + forall chunk ofs p, + lo < hi -> ofs + size_chunk chunk > lo -> ofs < hi -> + ~(valid_access m2 chunk bf ofs p). +Proof. + intros; red; intros. inv H2. + generalize (size_chunk_pos chunk); intros. + destruct (zlt ofs lo). + elim (perm_free_2 lo p). + omega. apply H3. omega. + elim (perm_free_2 ofs p). + omega. apply H3. omega. +Qed. + +Theorem valid_access_free_inv_1: + forall chunk b ofs p, + valid_access m2 chunk b ofs p -> + valid_access m1 chunk b ofs p. +Proof. + intros. destruct H. split; auto. + red; intros. generalize (H ofs0 H1). + rewrite free_result. unfold perm, unchecked_free; simpl. + unfold update. destruct (zeq b bf). subst b. + destruct (zle lo ofs0); simpl. + destruct (zlt ofs0 hi); simpl. + congruence. auto. auto. auto. +Qed. + +Theorem valid_access_free_inv_2: + forall chunk ofs p, + valid_access m2 chunk bf ofs p -> + lo >= hi \/ ofs + size_chunk chunk <= lo \/ hi <= ofs. +Proof. + intros. + destruct (zlt lo hi); auto. + destruct (zle (ofs + size_chunk chunk) lo); auto. + destruct (zle hi ofs); auto. + elim (valid_access_free_2 chunk ofs p); auto. omega. +Qed. + +Theorem bounds_free: + forall b, bounds m2 b = bounds m1 b. +Proof. + intros. rewrite free_result; simpl. auto. +Qed. + +Theorem load_free: + forall chunk b ofs, + b <> bf \/ lo >= hi \/ ofs + size_chunk chunk <= lo \/ hi <= ofs -> + load chunk m2 b ofs = load chunk m1 b ofs. +Proof. + intros. unfold load. + destruct (valid_access_dec m2 chunk b ofs Readable). + rewrite pred_dec_true. + rewrite free_result; auto. + apply valid_access_free_inv_1; auto. + rewrite pred_dec_false; auto. + red; intro; elim n. eapply valid_access_free_1; eauto. +Qed. + +End FREE. + +Hint Local Resolve valid_block_free_1 valid_block_free_2 + perm_free_1 perm_free_2 perm_free_3 + valid_access_free_1 valid_access_free_inv_1: mem. + +(** * Generic injections *) + +(** A memory state [m1] generically injects into another memory state [m2] via the + memory injection [f] if the following conditions hold: +- each access in [m2] that corresponds to a valid access in [m1] + is itself valid; +- the memory value associated in [m1] to an accessible address + must inject into [m2]'s memory value at the corersponding address. +*) + +Record mem_inj (f: meminj) (m1 m2: mem) : Prop := + mk_mem_inj { + mi_access: + forall b1 b2 delta chunk ofs p, + f b1 = Some(b2, delta) -> + valid_access m1 chunk b1 ofs p -> + valid_access m2 chunk b2 (ofs + delta) p; + mi_memval: + forall b1 ofs b2 delta, + f b1 = Some(b2, delta) -> + perm m1 b1 ofs Nonempty -> + memval_inject f (m1.(contents) b1 ofs) (m2.(contents) b2 (ofs + delta)) + }. + +(** Preservation of permissions *) + +Lemma perm_inj: + forall f m1 m2 b1 ofs p b2 delta, + mem_inj f m1 m2 -> + perm m1 b1 ofs p -> + f b1 = Some(b2, delta) -> + perm m2 b2 (ofs + delta) p. +Proof. + intros. + assert (valid_access m1 Mint8unsigned b1 ofs p). + split. red; intros. simpl in H2. replace ofs0 with ofs by omega. auto. + simpl. apply Zone_divide. + exploit mi_access; eauto. intros [A B]. + apply A. simpl; omega. +Qed. + +(** Preservation of loads. *) + +Lemma getN_inj: + forall f m1 m2 b1 b2 delta, + mem_inj f m1 m2 -> + f b1 = Some(b2, delta) -> + forall n ofs, + range_perm m1 b1 ofs (ofs + Z_of_nat n) Readable -> + list_forall2 (memval_inject f) + (getN n ofs (m1.(contents) b1)) + (getN n (ofs + delta) (m2.(contents) b2)). +Proof. + induction n; intros; simpl. + constructor. + rewrite inj_S in H1. + constructor. + eapply mi_memval; eauto. apply H1. omega. + replace (ofs + delta + 1) with ((ofs + 1) + delta) by omega. + apply IHn. red; intros; apply H1; omega. +Qed. + +Lemma load_inj: + forall f m1 m2 chunk b1 ofs b2 delta v1, + mem_inj f m1 m2 -> + load chunk m1 b1 ofs = Some v1 -> + f b1 = Some (b2, delta) -> + exists v2, load chunk m2 b2 (ofs + delta) = Some v2 /\ val_inject f v1 v2. +Proof. + intros. + exists (decode_val chunk (getN (size_chunk_nat chunk) (ofs + delta) (m2.(contents) b2))). + split. unfold load. apply pred_dec_true. + eapply mi_access; eauto with mem. + exploit load_result; eauto. intro. rewrite H2. + apply decode_val_inject. apply getN_inj; auto. + rewrite <- size_chunk_conv. exploit load_valid_access; eauto. intros [A B]. auto. +Qed. + +(** Preservation of stores. *) + +Lemma setN_inj: + forall (access: Z -> Prop) delta f vl1 vl2, + list_forall2 (memval_inject f) vl1 vl2 -> + forall p c1 c2, + (forall q, access q -> memval_inject f (c1 q) (c2 (q + delta))) -> + (forall q, access q -> memval_inject f ((setN vl1 p c1) q) + ((setN vl2 (p + delta) c2) (q + delta))). +Proof. + induction 1; intros; simpl. + auto. + replace (p + delta + 1) with ((p + 1) + delta) by omega. + apply IHlist_forall2; auto. + intros. unfold update at 1. destruct (zeq q0 p). subst q0. + rewrite update_s. auto. + rewrite update_o. auto. omega. +Qed. + +Definition meminj_no_overlap (f: meminj) (m: mem) : Prop := + forall b1 b1' delta1 b2 b2' delta2, + b1 <> b2 -> + f b1 = Some (b1', delta1) -> + f b2 = Some (b2', delta2) -> + b1' <> b2' +(* + \/ low_bound m b1 >= high_bound m b1 + \/ low_bound m b2 >= high_bound m b2 *) + \/ high_bound m b1 + delta1 <= low_bound m b2 + delta2 + \/ high_bound m b2 + delta2 <= low_bound m b1 + delta1. + +Lemma meminj_no_overlap_perm: + forall f m b1 b1' delta1 b2 b2' delta2 ofs1 ofs2, + meminj_no_overlap f m -> + b1 <> b2 -> + f b1 = Some (b1', delta1) -> + f b2 = Some (b2', delta2) -> + perm m b1 ofs1 Nonempty -> + perm m b2 ofs2 Nonempty -> + b1' <> b2' \/ ofs1 + delta1 <> ofs2 + delta2. +Proof. + intros. exploit H; eauto. intro. + exploit perm_in_bounds. eexact H3. intro. + exploit perm_in_bounds. eexact H4. intro. + destruct H5. auto. right. omega. +Qed. + +Lemma store_mapped_inj: + forall f chunk m1 b1 ofs v1 n1 m2 b2 delta v2, + mem_inj f m1 m2 -> + store chunk m1 b1 ofs v1 = Some n1 -> + meminj_no_overlap f m1 -> + f b1 = Some (b2, delta) -> + val_inject f v1 v2 -> + exists n2, + store chunk m2 b2 (ofs + delta) v2 = Some n2 + /\ mem_inj f n1 n2. +Proof. + intros. inversion H. + assert (valid_access m2 chunk b2 (ofs + delta) Writable). + eapply mi_access0; eauto with mem. + destruct (valid_access_store _ _ _ _ v2 H4) as [n2 STORE]. + exists n2; split. eauto. + constructor. +(* access *) + eauto with mem. +(* contents *) + intros. + assert (perm m1 b0 ofs0 Readable). eapply perm_store_2; eauto. + rewrite (store_result _ _ _ _ _ _ H0). + rewrite (store_result _ _ _ _ _ _ STORE). + unfold unchecked_store; simpl. unfold update. + destruct (zeq b0 b1). subst b0. + (* block = b1, block = b2 *) + assert (b3 = b2) by congruence. subst b3. + assert (delta0 = delta) by congruence. subst delta0. + rewrite zeq_true. + apply setN_inj with (access := fun ofs => perm m1 b1 ofs Nonempty). + apply encode_val_inject; auto. auto. auto. + destruct (zeq b3 b2). subst b3. + (* block <> b1, block = b2 *) + rewrite setN_other. auto. + rewrite encode_val_length. rewrite <- size_chunk_conv. intros. + assert (b2 <> b2 \/ ofs0 + delta0 <> (r - delta) + delta). + eapply meminj_no_overlap_perm; eauto. + exploit store_valid_access_3. eexact H0. intros [A B]. + eapply perm_implies. apply A. omega. auto with mem. + destruct H9. congruence. omega. + (* block <> b1, block <> b2 *) + eauto. +Qed. + +Lemma store_unmapped_inj: + forall f chunk m1 b1 ofs v1 n1 m2, + mem_inj f m1 m2 -> + store chunk m1 b1 ofs v1 = Some n1 -> + f b1 = None -> + mem_inj f n1 m2. +Proof. + intros. inversion H. + constructor. +(* access *) + eauto with mem. +(* contents *) + intros. + rewrite (store_result _ _ _ _ _ _ H0). + unfold unchecked_store; simpl. rewrite update_o. eauto with mem. + congruence. +Qed. + +Lemma store_outside_inj: + forall f m1 m2 chunk b ofs v m2', + mem_inj f m1 m2 -> + (forall b' delta ofs', + f b' = Some(b, delta) -> + perm m1 b' ofs' Nonempty -> + ofs' + delta < ofs \/ ofs' + delta >= ofs + size_chunk chunk) -> + store chunk m2 b ofs v = Some m2' -> + mem_inj f m1 m2'. +Proof. + intros. inversion H. constructor. +(* access *) + eauto with mem. +(* contents *) + intros. + rewrite (store_result _ _ _ _ _ _ H1). + unfold unchecked_store; simpl. unfold update. destruct (zeq b2 b). subst b2. + rewrite setN_outside. auto. + rewrite encode_val_length. rewrite <- size_chunk_conv. + eapply H0; eauto. + eauto with mem. +Qed. + +(** Preservation of allocations *) + +Lemma alloc_right_inj: + forall f m1 m2 lo hi b2 m2', + mem_inj f m1 m2 -> + alloc m2 lo hi = (m2', b2) -> + mem_inj f m1 m2'. +Proof. + intros. injection H0. intros NEXT MEM. + inversion H. constructor. +(* access *) + intros. eauto with mem. +(* contents *) + intros. + assert (valid_access m2 Mint8unsigned b0 (ofs + delta) Nonempty). + eapply mi_access0; eauto. + split. simpl. red; intros. assert (ofs0 = ofs) by omega. congruence. + simpl. apply Zone_divide. + assert (valid_block m2 b0) by eauto with mem. + rewrite <- MEM; simpl. rewrite update_o. eauto with mem. + rewrite NEXT. apply sym_not_equal. eauto with mem. +Qed. + +Lemma alloc_left_unmapped_inj: + forall f m1 m2 lo hi m1' b1, + mem_inj f m1 m2 -> + alloc m1 lo hi = (m1', b1) -> + f b1 = None -> + mem_inj f m1' m2. +Proof. + intros. inversion H. constructor. +(* access *) + unfold update; intros. + exploit valid_access_alloc_inv; eauto. unfold eq_block. intros. + destruct (zeq b0 b1). congruence. eauto. +(* contents *) + injection H0; intros NEXT MEM. intros. + rewrite <- MEM; simpl. rewrite NEXT. unfold update. + exploit perm_alloc_inv; eauto. intros. + destruct (zeq b0 b1). constructor. eauto. +Qed. + +Definition inj_offset_aligned (delta: Z) (size: Z) : Prop := + forall chunk, size_chunk chunk <= size -> (align_chunk chunk | delta). + +Lemma alloc_left_mapped_inj: + forall f m1 m2 lo hi m1' b1 b2 delta, + mem_inj f m1 m2 -> + alloc m1 lo hi = (m1', b1) -> + valid_block m2 b2 -> + inj_offset_aligned delta (hi-lo) -> + (forall ofs p, lo <= ofs < hi -> perm m2 b2 (ofs + delta) p) -> + f b1 = Some(b2, delta) -> + mem_inj f m1' m2. +Proof. + intros. inversion H. constructor. +(* access *) + intros. + exploit valid_access_alloc_inv; eauto. unfold eq_block. intros. + destruct (zeq b0 b1). subst b0. rewrite H4 in H5. inversion H5; clear H5; subst b3 delta0. + split. red; intros. + replace ofs0 with ((ofs0 - delta) + delta) by omega. + apply H3. omega. + destruct H6. apply Zdivide_plus_r. auto. apply H2. omega. + eauto. +(* contents *) + injection H0; intros NEXT MEM. + intros. rewrite <- MEM; simpl. rewrite NEXT. unfold update. + exploit perm_alloc_inv; eauto. intros. + destruct (zeq b0 b1). constructor. eauto. +Qed. + +Lemma free_left_inj: + forall f m1 m2 b lo hi m1', + mem_inj f m1 m2 -> + free m1 b lo hi = Some m1' -> + mem_inj f m1' m2. +Proof. + intros. exploit free_result; eauto. intro FREE. inversion H. constructor. +(* access *) + intros. eauto with mem. +(* contents *) + intros. rewrite FREE; simpl. eauto with mem. +Qed. + +Lemma free_right_inj: + forall f m1 m2 b lo hi m2', + mem_inj f m1 m2 -> + free m2 b lo hi = Some m2' -> + (forall b1 delta ofs p, + f b1 = Some(b, delta) -> perm m1 b1 ofs p -> + lo <= ofs + delta < hi -> False) -> + mem_inj f m1 m2'. +Proof. + intros. exploit free_result; eauto. intro FREE. inversion H. constructor. +(* access *) + intros. exploit mi_access0; eauto. intros [RG AL]. split; auto. + red; intros. eapply perm_free_1; eauto. + destruct (zeq b2 b); auto. subst b. right. + destruct (zlt ofs0 lo); auto. destruct (zle hi ofs0); auto. + elimtype False. eapply H1 with (ofs := ofs0 - delta). eauto. + apply H3. omega. omega. +(* contents *) + intros. rewrite FREE; simpl. eauto. +Qed. + +(** * Memory extensions *) + +(** A store [m2] extends a store [m1] if [m2] can be obtained from [m1] + by increasing the sizes of the memory blocks of [m1] (decreasing + the low bounds, increasing the high bounds), and replacing some of + the [Vundef] values stored in [m1] by more defined values stored + in [m2] at the same locations. *) + +Record extends_ (m1 m2: mem) : Prop := + mk_extends { + mext_next: nextblock m1 = nextblock m2; + mext_inj: mem_inj inject_id m1 m2 +(* + mext_bounds: forall b, low_bound m2 b <= low_bound m1 b /\ high_bound m1 b <= high_bound m2 b +*) + }. + +Definition extends := extends_. + +Theorem extends_refl: + forall m, extends m m. +Proof. + intros. constructor. auto. constructor. + intros. unfold inject_id in H; inv H. replace (ofs + 0) with ofs by omega. auto. + intros. unfold inject_id in H; inv H. replace (ofs + 0) with ofs by omega. + apply memval_inject_id. +(* intros. omega. *) +Qed. + +Theorem load_extends: + forall chunk m1 m2 b ofs v1, + extends m1 m2 -> + load chunk m1 b ofs = Some v1 -> + exists v2, load chunk m2 b ofs = Some v2 /\ Val.lessdef v1 v2. +Proof. + intros. inv H. exploit load_inj; eauto. unfold inject_id; reflexivity. + intros [v2 [A B]]. exists v2; split. + replace (ofs + 0) with ofs in A by omega. auto. + rewrite val_inject_id in B. auto. +Qed. + +Theorem loadv_extends: + forall chunk m1 m2 addr1 addr2 v1, + extends m1 m2 -> + loadv chunk m1 addr1 = Some v1 -> + Val.lessdef addr1 addr2 -> + exists v2, loadv chunk m2 addr2 = Some v2 /\ Val.lessdef v1 v2. +Proof. + unfold loadv; intros. inv H1. + destruct addr2; try congruence. eapply load_extends; eauto. + congruence. +Qed. + +Theorem store_within_extends: + forall chunk m1 m2 b ofs v1 m1' v2, + extends m1 m2 -> + store chunk m1 b ofs v1 = Some m1' -> + Val.lessdef v1 v2 -> + exists m2', + store chunk m2 b ofs v2 = Some m2' + /\ extends m1' m2'. +Proof. + intros. inversion H. + exploit store_mapped_inj; eauto. + unfold inject_id; red; intros. inv H3; inv H4. auto. + unfold inject_id; reflexivity. + rewrite val_inject_id. eauto. + intros [m2' [A B]]. + exists m2'; split. + replace (ofs + 0) with ofs in A by omega. auto. + split; auto. + rewrite (nextblock_store _ _ _ _ _ _ H0). + rewrite (nextblock_store _ _ _ _ _ _ A). + auto. +(* + intros. + rewrite (bounds_store _ _ _ _ _ _ H0). + rewrite (bounds_store _ _ _ _ _ _ A). + auto. +*) +Qed. + +Theorem store_outside_extends: + forall chunk m1 m2 b ofs v m2', + extends m1 m2 -> + store chunk m2 b ofs v = Some m2' -> + ofs + size_chunk chunk <= low_bound m1 b \/ high_bound m1 b <= ofs -> + extends m1 m2'. +Proof. + intros. inversion H. constructor. + rewrite (nextblock_store _ _ _ _ _ _ H0). auto. + eapply store_outside_inj; eauto. + unfold inject_id; intros. inv H2. + exploit perm_in_bounds; eauto. omega. +(* + intros. + rewrite (bounds_store _ _ _ _ _ _ H0). auto. +*) +Qed. + +Theorem storev_extends: + forall chunk m1 m2 addr1 v1 m1' addr2 v2, + extends m1 m2 -> + storev chunk m1 addr1 v1 = Some m1' -> + Val.lessdef addr1 addr2 -> + Val.lessdef v1 v2 -> + exists m2', + storev chunk m2 addr2 v2 = Some m2' + /\ extends m1' m2'. +Proof. + unfold storev; intros. inv H1. + destruct addr2; try congruence. eapply store_within_extends; eauto. + congruence. +Qed. + +Theorem alloc_extends: + forall m1 m2 lo1 hi1 b m1' lo2 hi2, + extends m1 m2 -> + alloc m1 lo1 hi1 = (m1', b) -> + lo2 <= lo1 -> hi1 <= hi2 -> + exists m2', + alloc m2 lo2 hi2 = (m2', b) + /\ extends m1' m2'. +Proof. + intros. inv H. + case_eq (alloc m2 lo2 hi2); intros m2' b' ALLOC. + assert (b' = b). + rewrite (alloc_result _ _ _ _ _ H0). + rewrite (alloc_result _ _ _ _ _ ALLOC). + auto. + subst b'. + exists m2'; split; auto. + constructor. + rewrite (nextblock_alloc _ _ _ _ _ H0). + rewrite (nextblock_alloc _ _ _ _ _ ALLOC). + congruence. + eapply alloc_left_mapped_inj with (m1 := m1) (m2 := m2') (b2 := b) (delta := 0); eauto. + eapply alloc_right_inj; eauto. + eauto with mem. + red. intros. apply Zdivide_0. + intros. eapply perm_alloc_2; eauto. omega. +(* + intros. destruct (zeq b0 b). subst b0. + rewrite (bounds_alloc_same _ _ _ _ _ H0). + rewrite (bounds_alloc_same _ _ _ _ _ ALLOC). + simpl. auto. + rewrite (bounds_alloc_other _ _ _ _ _ H0); auto. + rewrite (bounds_alloc_other _ _ _ _ _ ALLOC); auto. +*) +Qed. + +Theorem free_left_extends: + forall m1 m2 b lo hi m1', + extends m1 m2 -> + free m1 b lo hi = Some m1' -> + extends m1' m2. +Proof. + intros. inv H. constructor. + rewrite (nextblock_free _ _ _ _ _ H0). auto. + eapply free_left_inj; eauto. +(* + intros. rewrite (bounds_free _ _ _ _ _ H0). auto. +*) +Qed. + +Theorem free_right_extends: + forall m1 m2 b lo hi m2', + extends m1 m2 -> + free m2 b lo hi = Some m2' -> + (forall ofs p, lo <= ofs < hi -> ~perm m1 b ofs p) -> + extends m1 m2'. +Proof. + intros. inv H. constructor. + rewrite (nextblock_free _ _ _ _ _ H0). auto. + eapply free_right_inj; eauto. + unfold inject_id; intros. inv H. + elim (H1 ofs p); auto. omega. +(* + intros. rewrite (bounds_free _ _ _ _ _ H0). auto. +*) +Qed. + +Theorem free_parallel_extends: + forall m1 m2 b lo hi m1', + extends m1 m2 -> + free m1 b lo hi = Some m1' -> + exists m2', + free m2 b lo hi = Some m2' + /\ extends m1' m2'. +Proof. + intros. inversion H. + assert ({ m2': mem | free m2 b lo hi = Some m2' }). + apply range_perm_free. red; intros. + replace ofs with (ofs + 0) by omega. + eapply perm_inj with (b1 := b); eauto. + eapply free_range_perm; eauto. + destruct X as [m2' FREE]. exists m2'; split; auto. + inv H. constructor. + rewrite (nextblock_free _ _ _ _ _ H0). + rewrite (nextblock_free _ _ _ _ _ FREE). auto. + eapply free_right_inj with (m1 := m1'); eauto. + eapply free_left_inj; eauto. + unfold inject_id; intros. inv H. + assert (~perm m1' b ofs p). eapply perm_free_2; eauto. omega. + contradiction. +(* + intros. + rewrite (bounds_free _ _ _ _ _ H0). + rewrite (bounds_free _ _ _ _ _ FREE). + auto. +*) +Qed. + +Theorem valid_block_extends: + forall m1 m2 b, + extends m1 m2 -> + (valid_block m1 b <-> valid_block m2 b). +Proof. + intros. inv H. unfold valid_block. rewrite mext_next0. omega. +Qed. + +Theorem perm_extends: + forall m1 m2 b ofs p, + extends m1 m2 -> perm m1 b ofs p -> perm m2 b ofs p. +Proof. + intros. inv H. replace ofs with (ofs + 0) by omega. + eapply perm_inj; eauto. +Qed. + +Theorem valid_access_extends: + forall m1 m2 chunk b ofs p, + extends m1 m2 -> valid_access m1 chunk b ofs p -> valid_access m2 chunk b ofs p. +Proof. + intros. inv H. replace ofs with (ofs + 0) by omega. + eapply mi_access; eauto. auto. +Qed. + +(* +Theorem bounds_extends: + forall m1 m2 b, + extends m1 m2 -> low_bound m2 b <= low_bound m1 b /\ high_bound m1 b <= high_bound m2 b. +Proof. + intros. inv H. auto. +Qed. +*) + +(** * Memory injections *) + +(** A memory state [m1] injects into another memory state [m2] via the + memory injection [f] if the following conditions hold: +- each access in [m2] that corresponds to a valid access in [m1] + is itself valid; +- the memory value associated in [m1] to an accessible address + must inject into [m2]'s memory value at the corersponding address; +- unallocated blocks in [m1] must be mapped to [None] by [f]; +- if [f b = Some(b', delta)], [b'] must be valid in [m2]; +- distinct blocks in [m1] are mapped to non-overlapping sub-blocks in [m2]; +- the sizes of [m2]'s blocks are representable with signed machine integers; +- the offsets [delta] are representable with signed machine integers. +*) + +Record inject_ (f: meminj) (m1 m2: mem) : Prop := + mk_inject { + mi_inj: + mem_inj f m1 m2; + mi_freeblocks: + forall b, ~(valid_block m1 b) -> f b = None; + mi_mappedblocks: + forall b b' delta, f b = Some(b', delta) -> valid_block m2 b'; + mi_no_overlap: + meminj_no_overlap f m1; + mi_range_offset: + forall b b' delta, + f b = Some(b', delta) -> + Int.min_signed <= delta <= Int.max_signed; + mi_range_block: + forall b b' delta, + f b = Some(b', delta) -> + delta = 0 \/ + (Int.min_signed <= low_bound m2 b' /\ high_bound m2 b' <= Int.max_signed) + }. + +Definition inject := inject_. + +Hint Local Resolve mi_mappedblocks mi_range_offset: mem. + +(** Preservation of access validity and pointer validity *) + +Theorem valid_block_inject_1: + forall f m1 m2 b1 b2 delta, + f b1 = Some(b2, delta) -> + inject f m1 m2 -> + valid_block m1 b1. +Proof. + intros. inv H. destruct (zlt b1 (nextblock m1)). auto. + assert (f b1 = None). eapply mi_freeblocks; eauto. congruence. +Qed. + +Theorem valid_block_inject_2: + forall f m1 m2 b1 b2 delta, + f b1 = Some(b2, delta) -> + inject f m1 m2 -> + valid_block m2 b2. +Proof. + intros. eapply mi_mappedblocks; eauto. +Qed. + +Hint Local Resolve valid_block_inject_1 valid_block_inject_2: mem. + +Theorem perm_inject: + forall f m1 m2 b1 b2 delta ofs p, + f b1 = Some(b2, delta) -> + inject f m1 m2 -> + perm m1 b1 ofs p -> perm m2 b2 (ofs + delta) p. +Proof. + intros. inv H0. eapply perm_inj; eauto. +Qed. + +Theorem valid_access_inject: + forall f m1 m2 chunk b1 ofs b2 delta p, + f b1 = Some(b2, delta) -> + inject f m1 m2 -> + valid_access m1 chunk b1 ofs p -> + valid_access m2 chunk b2 (ofs + delta) p. +Proof. + intros. eapply mi_access; eauto. apply mi_inj; auto. +Qed. + +Theorem valid_pointer_inject: + forall f m1 m2 b1 ofs b2 delta, + f b1 = Some(b2, delta) -> + inject f m1 m2 -> + valid_pointer m1 b1 ofs = true -> + valid_pointer m2 b2 (ofs + delta) = true. +Proof. + intros. + rewrite valid_pointer_valid_access in H1. + rewrite valid_pointer_valid_access. + eapply valid_access_inject; eauto. +Qed. + +(** The following lemmas establish the absence of machine integer overflow + during address computations. *) + +Lemma address_inject: + forall f m1 m2 b1 ofs1 b2 delta, + inject f m1 m2 -> + perm m1 b1 (Int.signed ofs1) Nonempty -> + f b1 = Some (b2, delta) -> + Int.signed (Int.add ofs1 (Int.repr delta)) = Int.signed ofs1 + delta. +Proof. + intros. + exploit perm_inject; eauto. intro A. + exploit perm_in_bounds. eexact A. intros [B C]. + exploit mi_range_block; eauto. intros [D | [E F]]. + subst delta. rewrite Int.add_zero. omega. + rewrite Int.add_signed. + repeat rewrite Int.signed_repr. auto. + eapply mi_range_offset; eauto. + omega. + eapply mi_range_offset; eauto. +Qed. + +Lemma address_inject': + forall f m1 m2 chunk b1 ofs1 b2 delta, + inject f m1 m2 -> + valid_access m1 chunk b1 (Int.signed ofs1) Nonempty -> + f b1 = Some (b2, delta) -> + Int.signed (Int.add ofs1 (Int.repr delta)) = Int.signed ofs1 + delta. +Proof. + intros. destruct H0. eapply address_inject; eauto. + apply H0. generalize (size_chunk_pos chunk). omega. +Qed. + +Theorem valid_pointer_inject_no_overflow: + forall f m1 m2 b ofs b' x, + inject f m1 m2 -> + valid_pointer m1 b (Int.signed ofs) = true -> + f b = Some(b', x) -> + Int.min_signed <= Int.signed ofs + Int.signed (Int.repr x) <= Int.max_signed. +Proof. + intros. rewrite valid_pointer_valid_access in H0. + exploit address_inject'; eauto. intros. + rewrite Int.signed_repr; eauto. + rewrite <- H2. apply Int.signed_range. + eapply mi_range_offset; eauto. +Qed. + +Theorem valid_pointer_inject_val: + forall f m1 m2 b ofs b' ofs', + inject f m1 m2 -> + valid_pointer m1 b (Int.signed ofs) = true -> + val_inject f (Vptr b ofs) (Vptr b' ofs') -> + valid_pointer m2 b' (Int.signed ofs') = true. +Proof. + intros. inv H1. + exploit valid_pointer_inject_no_overflow; eauto. intro NOOV. + rewrite Int.add_signed. rewrite Int.signed_repr; auto. + rewrite Int.signed_repr. + eapply valid_pointer_inject; eauto. + eapply mi_range_offset; eauto. +Qed. + +Theorem inject_no_overlap: + forall f m1 m2 b1 b2 b1' b2' delta1 delta2 ofs1 ofs2, + inject f m1 m2 -> + b1 <> b2 -> + f b1 = Some (b1', delta1) -> + f b2 = Some (b2', delta2) -> + perm m1 b1 ofs1 Nonempty -> + perm m1 b2 ofs2 Nonempty -> + b1' <> b2' \/ ofs1 + delta1 <> ofs2 + delta2. +Proof. + intros. inv H. eapply meminj_no_overlap_perm; eauto. +Qed. + +Theorem different_pointers_inject: + forall f m m' b1 ofs1 b2 ofs2 b1' delta1 b2' delta2, + inject f m m' -> + b1 <> b2 -> + valid_pointer m b1 (Int.signed ofs1) = true -> + valid_pointer m b2 (Int.signed ofs2) = true -> + f b1 = Some (b1', delta1) -> + f b2 = Some (b2', delta2) -> + b1' <> b2' \/ + Int.signed (Int.add ofs1 (Int.repr delta1)) <> + Int.signed (Int.add ofs2 (Int.repr delta2)). +Proof. + intros. + rewrite valid_pointer_valid_access in H1. + rewrite valid_pointer_valid_access in H2. + rewrite (address_inject' _ _ _ _ _ _ _ _ H H1 H3). + rewrite (address_inject' _ _ _ _ _ _ _ _ H H2 H4). + inv H1. simpl in H5. inv H2. simpl in H1. + eapply meminj_no_overlap_perm. + eapply mi_no_overlap; eauto. eauto. eauto. eauto. + apply (H5 (Int.signed ofs1)). omega. + apply (H1 (Int.signed ofs2)). omega. +Qed. + +(** Preservation of loads *) + +Theorem load_inject: + forall f m1 m2 chunk b1 ofs b2 delta v1, + inject f m1 m2 -> + load chunk m1 b1 ofs = Some v1 -> + f b1 = Some (b2, delta) -> + exists v2, load chunk m2 b2 (ofs + delta) = Some v2 /\ val_inject f v1 v2. +Proof. + intros. inv H. eapply load_inj; eauto. +Qed. + +Theorem loadv_inject: + forall f m1 m2 chunk a1 a2 v1, + inject f m1 m2 -> + loadv chunk m1 a1 = Some v1 -> + val_inject f a1 a2 -> + exists v2, loadv chunk m2 a2 = Some v2 /\ val_inject f v1 v2. +Proof. + intros. inv H1; simpl in H0; try discriminate. + exploit load_inject; eauto. intros [v2 [LOAD INJ]]. + exists v2; split; auto. simpl. + replace (Int.signed (Int.add ofs1 (Int.repr delta))) + with (Int.signed ofs1 + delta). + auto. symmetry. eapply address_inject'; eauto with mem. +Qed. + +(** Preservation of stores *) + +Theorem store_mapped_inject: + forall f chunk m1 b1 ofs v1 n1 m2 b2 delta v2, + inject f m1 m2 -> + store chunk m1 b1 ofs v1 = Some n1 -> + f b1 = Some (b2, delta) -> + val_inject f v1 v2 -> + exists n2, + store chunk m2 b2 (ofs + delta) v2 = Some n2 + /\ inject f n1 n2. +Proof. + intros. inversion H. + exploit store_mapped_inj; eauto. intros [n2 [STORE MI]]. + exists n2; split. eauto. constructor. +(* inj *) + auto. +(* freeblocks *) + eauto with mem. +(* mappedblocks *) + eauto with mem. +(* no overlap *) + red; intros. + repeat rewrite (bounds_store _ _ _ _ _ _ H0). + eauto. +(* range offset *) + eauto. +(* range blocks *) + intros. rewrite (bounds_store _ _ _ _ _ _ STORE). eauto. +Qed. + +Theorem store_unmapped_inject: + forall f chunk m1 b1 ofs v1 n1 m2, + inject f m1 m2 -> + store chunk m1 b1 ofs v1 = Some n1 -> + f b1 = None -> + inject f n1 m2. +Proof. + intros. inversion H. + constructor. +(* inj *) + eapply store_unmapped_inj; eauto. +(* freeblocks *) + eauto with mem. +(* mappedblocks *) + eauto with mem. +(* no overlap *) + red; intros. + repeat rewrite (bounds_store _ _ _ _ _ _ H0). + eauto. +(* range offset *) + eauto. +(* range blocks *) + auto. +Qed. + +Theorem store_outside_inject: + forall f m1 m2 chunk b ofs v m2', + inject f m1 m2 -> + (forall b' delta, + f b' = Some(b, delta) -> + high_bound m1 b' + delta <= ofs + \/ ofs + size_chunk chunk <= low_bound m1 b' + delta) -> + store chunk m2 b ofs v = Some m2' -> + inject f m1 m2'. +Proof. + intros. inversion H. constructor. +(* inj *) + eapply store_outside_inj; eauto. + intros. exploit perm_in_bounds; eauto. intro. + exploit H0; eauto. intro. omega. +(* freeblocks *) + auto. +(* mappedblocks *) + eauto with mem. +(* no overlap *) + auto. +(* range offset *) + auto. +(* rang blocks *) + intros. rewrite (bounds_store _ _ _ _ _ _ H1). eauto. +Qed. + +Theorem storev_mapped_inject: + forall f chunk m1 a1 v1 n1 m2 a2 v2, + inject f m1 m2 -> + storev chunk m1 a1 v1 = Some n1 -> + val_inject f a1 a2 -> + val_inject f v1 v2 -> + exists n2, + storev chunk m2 a2 v2 = Some n2 /\ inject f n1 n2. +Proof. + intros. inv H1; simpl in H0; try discriminate. + simpl. replace (Int.signed (Int.add ofs1 (Int.repr delta))) + with (Int.signed ofs1 + delta). + eapply store_mapped_inject; eauto. + symmetry. eapply address_inject'; eauto with mem. +Qed. + +(* Preservation of allocations *) + +Theorem alloc_right_inject: + forall f m1 m2 lo hi b2 m2', + inject f m1 m2 -> + alloc m2 lo hi = (m2', b2) -> + inject f m1 m2'. +Proof. + intros. injection H0. intros NEXT MEM. + inversion H. constructor. +(* inj *) + eapply alloc_right_inj; eauto. +(* freeblocks *) + auto. +(* mappedblocks *) + eauto with mem. +(* no overlap *) + auto. +(* range offset *) + auto. +(* range block *) + intros. rewrite (bounds_alloc_other _ _ _ _ _ H0). eauto. + eapply valid_not_valid_diff; eauto with mem. +Qed. + +Theorem alloc_left_unmapped_inject: + forall f m1 m2 lo hi m1' b1, + inject f m1 m2 -> + alloc m1 lo hi = (m1', b1) -> + exists f', + inject f' m1' m2 + /\ inject_incr f f' + /\ f' b1 = None + /\ (forall b, b <> b1 -> f' b = f b). +Proof. + intros. inversion H. + assert (inject_incr f (update b1 None f)). + red; unfold update; intros. destruct (zeq b b1). subst b. + assert (f b1 = None). eauto with mem. congruence. + auto. + assert (mem_inj (update b1 None f) m1 m2). + inversion mi_inj0; constructor; eauto with mem. + unfold update; intros. destruct (zeq b0 b1). congruence. eauto. + unfold update; intros. destruct (zeq b0 b1). congruence. + apply memval_inject_incr with f; auto. + exists (update b1 None f); split. constructor. +(* inj *) + eapply alloc_left_unmapped_inj; eauto. apply update_s. +(* freeblocks *) + intros. unfold update. destruct (zeq b b1). auto. + apply mi_freeblocks0. red; intro; elim H3. eauto with mem. +(* mappedblocks *) + unfold update; intros. destruct (zeq b b1). congruence. eauto. +(* no overlap *) + unfold update; red; intros. + destruct (zeq b0 b1); destruct (zeq b2 b1); try congruence. + repeat rewrite (bounds_alloc_other _ _ _ _ _ H0); eauto. +(* range offset *) + unfold update; intros. + destruct (zeq b b1). congruence. eauto. +(* range block *) + unfold update; intros. + destruct (zeq b b1). congruence. eauto. +(* incr *) + split. auto. +(* image *) + split. apply update_s. +(* incr *) + intros; apply update_o; auto. +Qed. + +Theorem alloc_left_mapped_inject: + forall f m1 m2 lo hi m1' b1 b2 delta, + inject f m1 m2 -> + alloc m1 lo hi = (m1', b1) -> + valid_block m2 b2 -> + Int.min_signed <= delta <= Int.max_signed -> + delta = 0 \/ Int.min_signed <= low_bound m2 b2 /\ high_bound m2 b2 <= Int.max_signed -> + (forall ofs p, lo <= ofs < hi -> perm m2 b2 (ofs + delta) p) -> + inj_offset_aligned delta (hi-lo) -> + (forall b ofs, + f b = Some (b2, ofs) -> + high_bound m1 b + ofs <= lo + delta \/ + hi + delta <= low_bound m1 b + ofs) -> + exists f', + inject f' m1' m2 + /\ inject_incr f f' + /\ f' b1 = Some(b2, delta) + /\ (forall b, b <> b1 -> f' b = f b). +Proof. + intros. inversion H. + assert (inject_incr f (update b1 (Some(b2, delta)) f)). + red; unfold update; intros. destruct (zeq b b1). subst b. + assert (f b1 = None). eauto with mem. congruence. + auto. + assert (mem_inj (update b1 (Some(b2, delta)) f) m1 m2). + inversion mi_inj0; constructor; eauto with mem. + unfold update; intros. destruct (zeq b0 b1). + inv H8. elim (fresh_block_alloc _ _ _ _ _ H0). eauto with mem. + eauto. + unfold update; intros. destruct (zeq b0 b1). + inv H8. elim (fresh_block_alloc _ _ _ _ _ H0). eauto with mem. + apply memval_inject_incr with f; auto. + exists (update b1 (Some(b2, delta)) f). split. constructor. +(* inj *) + eapply alloc_left_mapped_inj; eauto. apply update_s. +(* freeblocks *) + unfold update; intros. destruct (zeq b b1). subst b. + elim H9. eauto with mem. + eauto with mem. +(* mappedblocks *) + unfold update; intros. destruct (zeq b b1). inv H9. auto. + eauto. +(* overlap *) + unfold update; red; intros. + repeat rewrite (bounds_alloc _ _ _ _ _ H0). unfold eq_block. + destruct (zeq b0 b1); destruct (zeq b3 b1); simpl. + inv H10; inv H11. congruence. + inv H10. destruct (zeq b1' b2'); auto. subst b2'. + right. generalize (H6 _ _ H11). tauto. + inv H11. destruct (zeq b1' b2'); auto. subst b2'. + right. eapply H6; eauto. + eauto. +(* range offset *) + unfold update; intros. destruct (zeq b b1). inv H9. auto. eauto. +(* range block *) + unfold update; intros. destruct (zeq b b1). inv H9. auto. eauto. +(* incr *) + split. auto. +(* image of b1 *) + split. apply update_s. +(* image of others *) + intros. apply update_o; auto. +Qed. + +Theorem alloc_parallel_inject: + forall f m1 m2 lo1 hi1 m1' b1 lo2 hi2, + inject f m1 m2 -> + alloc m1 lo1 hi1 = (m1', b1) -> + lo2 <= lo1 -> hi1 <= hi2 -> + exists f', exists m2', exists b2, + alloc m2 lo2 hi2 = (m2', b2) + /\ inject f' m1' m2' + /\ inject_incr f f' + /\ f' b1 = Some(b2, 0) + /\ (forall b, b <> b1 -> f' b = f b). +Proof. + intros. + case_eq (alloc m2 lo2 hi2). intros m2' b2 ALLOC. + exploit alloc_left_mapped_inject. + eapply alloc_right_inject; eauto. + eauto. + instantiate (1 := b2). eauto with mem. + instantiate (1 := 0). generalize Int.min_signed_neg Int.max_signed_pos; omega. + auto. + intros. eapply perm_alloc_2; eauto. omega. + red; intros. apply Zdivide_0. + intros. elimtype False. apply (valid_not_valid_diff m2 b2 b2); eauto with mem. + intros [f' [A [B [C D]]]]. + exists f'; exists m2'; exists b2; auto. +Qed. + +(** Preservation of [free] operations *) + +Lemma free_left_inject: + forall f m1 m2 b lo hi m1', + inject f m1 m2 -> + free m1 b lo hi = Some m1' -> + inject f m1' m2. +Proof. + intros. inversion H. constructor. +(* inj *) + eapply free_left_inj; eauto. +(* freeblocks *) + eauto with mem. +(* mappedblocks *) + auto. +(* no overlap *) + red; intros. repeat rewrite (bounds_free _ _ _ _ _ H0). eauto. +(* range offset *) + auto. +(* range block *) + auto. +Qed. + +Lemma free_list_left_inject: + forall f m2 l m1 m1', + inject f m1 m2 -> + free_list m1 l = Some m1' -> + inject f m1' m2. +Proof. + induction l; simpl; intros. + inv H0. auto. + destruct a as [[b lo] hi]. generalize H0. case_eq (free m1 b lo hi); intros. + apply IHl with m; auto. eapply free_left_inject; eauto. + congruence. +Qed. + +Lemma free_right_inject: + forall f m1 m2 b lo hi m2', + inject f m1 m2 -> + free m2 b lo hi = Some m2' -> + (forall b1 delta ofs p, + f b1 = Some(b, delta) -> perm m1 b1 ofs p -> + lo <= ofs + delta < hi -> False) -> + inject f m1 m2'. +Proof. + intros. inversion H. constructor. +(* inj *) + eapply free_right_inj; eauto. +(* freeblocks *) + auto. +(* mappedblocks *) + eauto with mem. +(* no overlap *) + auto. +(* range offset *) + auto. +(* range blocks *) + intros. rewrite (bounds_free _ _ _ _ _ H0). eauto. +Qed. + +Lemma perm_free_list: + forall l m m' b ofs p, + free_list m l = Some m' -> + perm m' b ofs p -> + perm m b ofs p /\ + (forall lo hi, In (b, lo, hi) l -> lo <= ofs < hi -> False). +Proof. + induction l; intros until p; simpl. + intros. inv H. split; auto. + destruct a as [[b1 lo1] hi1]. + case_eq (free m b1 lo1 hi1); intros; try congruence. + exploit IHl; eauto. intros [A B]. + split. eauto with mem. + intros. destruct H2. inv H2. + elim (perm_free_2 _ _ _ _ _ H ofs p). auto. auto. + eauto. +Qed. + +Theorem free_inject: + forall f m1 l m1' m2 b lo hi m2', + inject f m1 m2 -> + free_list m1 l = Some m1' -> + free m2 b lo hi = Some m2' -> + (forall b1 delta ofs p, + f b1 = Some(b, delta) -> + perm m1 b1 ofs p -> lo <= ofs + delta < hi -> + exists lo1, exists hi1, In (b1, lo1, hi1) l /\ lo1 <= ofs < hi1) -> + inject f m1' m2'. +Proof. + intros. + eapply free_right_inject; eauto. + eapply free_list_left_inject; eauto. + intros. exploit perm_free_list; eauto. intros [A B]. + exploit H2; eauto. intros [lo1 [hi1 [C D]]]. eauto. +Qed. + +(* +Theorem free_inject': + forall f m1 l m1' m2 b lo hi m2', + inject f m1 m2 -> + free_list m1 l = Some m1' -> + free m2 b lo hi = Some m2' -> + (forall b1 delta, + f b1 = Some(b, delta) -> In (b1, low_bound m1 b1, high_bound m1 b1) l) -> + inject f m1' m2'. +Proof. + intros. eapply free_inject; eauto. + intros. exists (low_bound m1 b1); exists (high_bound m1 b1). + split. eauto. apply perm_in_bounds with p. auto. +Qed. +*) + +(** Injecting a memory into itself. *) + +Definition flat_inj (thr: block) : meminj := + fun (b: block) => if zlt b thr then Some(b, 0) else None. + +Definition inject_neutral (thr: block) (m: mem) := + mem_inj (flat_inj thr) m m. + +Remark flat_inj_no_overlap: + forall thr m, meminj_no_overlap (flat_inj thr) m. +Proof. + unfold flat_inj; intros; red; intros. + destruct (zlt b1 thr); inversion H0; subst. + destruct (zlt b2 thr); inversion H1; subst. + auto. +Qed. + +Theorem neutral_inject: + forall m, inject_neutral (nextblock m) m -> inject (flat_inj (nextblock m)) m m. +Proof. + intros. constructor. +(* meminj *) + auto. +(* freeblocks *) + unfold flat_inj, valid_block; intros. + apply zlt_false. omega. +(* mappedblocks *) + unfold flat_inj, valid_block; intros. + destruct (zlt b (nextblock m)); inversion H0; subst. auto. +(* no overlap *) + apply flat_inj_no_overlap. +(* range *) + unfold flat_inj; intros. + destruct (zlt b (nextblock m)); inv H0. + generalize Int.min_signed_neg Int.max_signed_pos; omega. +(* range *) + unfold flat_inj; intros. + destruct (zlt b (nextblock m)); inv H0. auto. +Qed. + +Theorem empty_inject_neutral: + forall thr, inject_neutral thr empty. +Proof. + intros; red; constructor. +(* access *) + unfold flat_inj; intros. destruct (zlt b1 thr); inv H. + replace (ofs + 0) with ofs by omega; auto. +(* contents *) + intros; simpl; constructor. +Qed. + +Theorem alloc_inject_neutral: + forall thr m lo hi b m', + alloc m lo hi = (m', b) -> + inject_neutral thr m -> + nextblock m < thr -> + inject_neutral thr m'. +Proof. + intros; red. + eapply alloc_left_mapped_inj with (m1 := m) (b2 := b) (delta := 0). + eapply alloc_right_inj; eauto. eauto. eauto with mem. + red. intros. apply Zdivide_0. + intros. eapply perm_alloc_2; eauto. omega. + unfold flat_inj. apply zlt_true. + rewrite (alloc_result _ _ _ _ _ H). auto. +Qed. + +Theorem store_inject_neutral: + forall chunk m b ofs v m' thr, + store chunk m b ofs v = Some m' -> + inject_neutral thr m -> + b < thr -> + val_inject (flat_inj thr) v v -> + inject_neutral thr m'. +Proof. + intros; red. + exploit store_mapped_inj. eauto. eauto. apply flat_inj_no_overlap. + unfold flat_inj. apply zlt_true; auto. eauto. + replace (ofs + 0) with ofs by omega. + intros [m'' [A B]]. congruence. +Qed. + +End Mem. + +Notation mem := Mem.mem. + +Hint Resolve + Mem.valid_not_valid_diff + Mem.perm_implies + Mem.perm_valid_block + Mem.range_perm_implies + Mem.valid_access_implies + Mem.valid_access_valid_block + Mem.valid_access_perm + Mem.valid_access_load + Mem.load_valid_access + Mem.valid_access_store + Mem.perm_store_1 + Mem.perm_store_2 + Mem.nextblock_store + Mem.store_valid_block_1 + Mem.store_valid_block_2 + Mem.store_valid_access_1 + Mem.store_valid_access_2 + Mem.store_valid_access_3 + Mem.nextblock_alloc + Mem.alloc_result + Mem.valid_block_alloc + Mem.fresh_block_alloc + Mem.valid_new_block + Mem.perm_alloc_1 + Mem.perm_alloc_2 + Mem.perm_alloc_3 + Mem.perm_alloc_inv + Mem.valid_access_alloc_other + Mem.valid_access_alloc_same + Mem.valid_access_alloc_inv + Mem.range_perm_free + Mem.free_range_perm + Mem.nextblock_free + Mem.valid_block_free_1 + Mem.valid_block_free_2 + Mem.perm_free_1 + Mem.perm_free_2 + Mem.perm_free_3 + Mem.valid_access_free_1 + Mem.valid_access_free_2 + Mem.valid_access_free_inv_1 + Mem.valid_access_free_inv_2 +: mem. diff --git a/common/Memtype.v b/common/Memtype.v new file mode 100644 index 0000000..cfbe511 --- /dev/null +++ b/common/Memtype.v @@ -0,0 +1,989 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* 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 file defines the interface for the memory model that + is used in the dynamic semantics of all the languages used in the compiler. + It defines a type [mem] of memory states, the following 4 basic + operations over memory states, and their properties: +- [load]: read a memory chunk at a given address; +- [store]: store a memory chunk at a given address; +- [alloc]: allocate a fresh memory block; +- [free]: invalidate a memory block. +*) + +Require Import Coqlib. +Require Import AST. +Require Import Integers. +Require Import Floats. +Require Import Values. +Require Import Memdata. + +(** Memory states are accessed by addresses [b, ofs]: pairs of a block + identifier [b] and a byte offset [ofs] within that block. + Each address is in one of the following five states: +- Freeable (exclusive access): all operations permitted +- Writable: load, store and pointer comparison operations are permitted, + but freeing is not. +- Readable: only load and pointer comparison operations are permitted. +- Nonempty: valid, but only pointer comparisons are permitted. +- Empty: not yet allocated or previously freed; no operation permitted. + +The first four cases are represented by the following type of permissions. +Being empty is represented by the absence of any permission. +*) + +Inductive permission: Type := + | Freeable: permission + | Writable: permission + | Readable: permission + | Nonempty: permission. + +(** In the list, each permission implies the other permissions further down the + list. We reflect this fact by the following order over permissions. *) + +Inductive perm_order: permission -> permission -> Prop := + | perm_F_any: forall p, perm_order Freeable p + | perm_W_R: perm_order Writable Readable + | perm_any_N: forall p, perm_order p Nonempty. + +Hint Constructors perm_order: mem. + +Module Type MEM. + +(** The abstract type of memory states. *) +Parameter mem: Type. + +Definition nullptr: block := 0. + +(** * Operations on memory states *) + +(** [empty] is the initial memory state. *) +Parameter empty: mem. + +(** [alloc m lo hi] allocates a fresh block of size [hi - lo] bytes. + Valid offsets in this block are between [lo] included and [hi] excluded. + These offsets are writable in the returned memory state. + This block is not initialized: its contents are initially undefined. + Returns a pair [(m', b)] of the updated memory state [m'] and + the identifier [b] of the newly-allocated block. + Note that [alloc] never fails: we are modeling an infinite memory. *) +Parameter alloc: forall (m: mem) (lo hi: Z), mem * block. + +(** [free m b lo hi] frees (deallocates) the range of offsets from [lo] + included to [hi] excluded in block [b]. Returns the updated memory + state, or [None] if the freed addresses are not writable. *) +Parameter free: forall (m: mem) (b: block) (lo hi: Z), option mem. + +(** [load chunk m b ofs] reads a memory quantity [chunk] from + addresses [b, ofs] to [b, ofs + size_chunk chunk - 1] in memory state + [m]. Returns the value read, or [None] if the accessed addresses + are not readable. *) +Parameter load: forall (chunk: memory_chunk) (m: mem) (b: block) (ofs: Z), option val. + +(** [store chunk m b ofs v] writes value [v] as memory quantity [chunk] + from addresses [b, ofs] to [b, ofs + size_chunk chunk - 1] in memory state + [m]. Returns the updated memory state, or [None] if the accessed addresses + are not writable. *) +Parameter store: forall (chunk: memory_chunk) (m: mem) (b: block) (ofs: Z) (v: val), option mem. + +(** [loadv] and [storev] are variants of [load] and [store] where + the address being accessed is passed as a value (of the [Vptr] kind). *) + +Definition loadv (chunk: memory_chunk) (m: mem) (addr: val) : option val := + match addr with + | Vptr b ofs => load chunk m b (Int.signed ofs) + | _ => None + end. + +Definition storev (chunk: memory_chunk) (m: mem) (addr v: val) : option mem := + match addr with + | Vptr b ofs => store chunk m b (Int.signed ofs) v + | _ => None + end. + +(** [loadbytes m b ofs n] reads and returns the byte-level representation of + the values contained at offsets [ofs] to [ofs + n - 1] within block [b] + in memory state [m]. These values must be integers or floats. + [None] is returned if the accessed addresses are not readable + or contain undefined or pointer values. *) +Parameter loadbytes: forall (m: mem) (b: block) (ofs n: Z), option (list byte). + +(** [free_list] frees all the given (block, lo, hi) triples. *) +Fixpoint free_list (m: mem) (l: list (block * Z * Z)) {struct l}: option mem := + match l with + | nil => Some m + | (b, lo, hi) :: l' => + match free m b lo hi with + | None => None + | Some m' => free_list m' l' + end + end. + +(** * Permissions, block validity, access validity, and bounds *) + +(** The next block of a memory state is the block identifier for the + next allocation. It increases by one at each allocation. + Block identifiers below [nextblock] are said to be valid, meaning + that they have been allocated previously. Block identifiers above + [nextblock] are fresh or invalid, i.e. not yet allocated. Note that + a block identifier remains valid after a [free] operation over this + block. *) + +Parameter nextblock: mem -> block. +Axiom nextblock_pos: + forall m, nextblock m > 0. + +Definition valid_block (m: mem) (b: block) := + b < nextblock m. +Axiom valid_not_valid_diff: + forall m b b', valid_block m b -> ~(valid_block m b') -> b <> b'. + +(** [perm m b ofs p] holds if the address [b, ofs] in memory state [m] + has permission [p]: one of writable, readable, and nonempty. + If the address is empty, [perm m b ofs p] is false for all values of [p]. *) +Parameter perm: forall (m: mem) (b: block) (ofs: Z) (p: permission), Prop. + +(** Logical implications between permissions *) + +Axiom perm_implies: + forall m b ofs p1 p2, perm m b ofs p1 -> perm_order p1 p2 -> perm m b ofs p2. + +(** Having a (nonempty) permission implies that the block is valid. + In other words, invalid blocks, not yet allocated, are all empty. *) +Axiom perm_valid_block: + forall m b ofs p, perm m b ofs p -> valid_block m b. + +(* Unused? +(** The [Mem.perm] predicate is decidable. *) +Axiom perm_dec: + forall m b ofs p, {perm m b ofs p} + {~ perm m b ofs p}. +*) + +(** [range_perm m b lo hi p] holds iff the addresses [b, lo] to [b, hi-1] + all have permission [p]. *) +Definition range_perm (m: mem) (b: block) (lo hi: Z) (p: permission) : Prop := + forall ofs, lo <= ofs < hi -> perm m b ofs p. + +Axiom range_perm_implies: + forall m b lo hi p1 p2, + range_perm m b lo hi p1 -> perm_order p1 p2 -> range_perm m b lo hi p2. + +(** An access to a memory quantity [chunk] at address [b, ofs] with + permission [p] is valid in [m] if the accessed addresses all have + permission [p] and moreover the offset is properly aligned. *) +Definition valid_access (m: mem) (chunk: memory_chunk) (b: block) (ofs: Z) (p: permission): Prop := + range_perm m b ofs (ofs + size_chunk chunk) p + /\ (align_chunk chunk | ofs). + +Axiom valid_access_implies: + forall m chunk b ofs p1 p2, + valid_access m chunk b ofs p1 -> perm_order p1 p2 -> + valid_access m chunk b ofs p2. + +Axiom valid_access_valid_block: + forall m chunk b ofs, + valid_access m chunk b ofs Nonempty -> + valid_block m b. + +Axiom valid_access_perm: + forall m chunk b ofs p, + valid_access m chunk b ofs p -> + perm m b ofs p. + +(** [valid_pointer m b ofs] returns [true] if the address [b, ofs] + is nonempty in [m] and [false] if it is empty. *) + +Parameter valid_pointer: forall (m: mem) (b: block) (ofs: Z), bool. + +Axiom valid_pointer_nonempty_perm: + forall m b ofs, + valid_pointer m b ofs = true <-> perm m b ofs Nonempty. +Axiom valid_pointer_valid_access: + forall m b ofs, + valid_pointer m b ofs = true <-> valid_access m Mint8unsigned b ofs Nonempty. + +(** Each block has associated low and high bounds. These are the bounds + that were given when the block was allocated. *) + +Parameter bounds: forall (m: mem) (b: block), Z*Z. + +Notation low_bound m b := (fst(bounds m b)). +Notation high_bound m b := (snd(bounds m b)). + +(** The crucial properties of bounds is that any offset below the low + bound or above the high bound is empty. *) + +Axiom perm_in_bounds: + forall m b ofs p, perm m b ofs p -> low_bound m b <= ofs < high_bound m b. + +Axiom range_perm_in_bounds: + forall m b lo hi p, + range_perm m b lo hi p -> lo < hi -> + low_bound m b <= lo /\ hi <= high_bound m b. + +Axiom valid_access_in_bounds: + forall m chunk b ofs p, + valid_access m chunk b ofs p -> + low_bound m b <= ofs /\ ofs + size_chunk chunk <= high_bound m b. + +(** * Properties of the memory operations *) + +(** ** Properties of the initial memory state. *) + +Axiom nextblock_empty: nextblock empty = 1. +Axiom perm_empty: forall b ofs p, ~perm empty b ofs p. +Axiom valid_access_empty: + forall chunk b ofs p, ~valid_access empty chunk b ofs p. + +(** ** Properties of [load]. *) + +(** A load succeeds if and only if the access is valid for reading *) +Axiom valid_access_load: + forall m chunk b ofs, + valid_access m chunk b ofs Readable -> + exists v, load chunk m b ofs = Some v. +Axiom load_valid_access: + forall m chunk b ofs v, + load chunk m b ofs = Some v -> + valid_access m chunk b ofs Readable. + +(** The value returned by [load] belongs to the type of the memory quantity + accessed: [Vundef], [Vint] or [Vptr] for an integer quantity, + [Vundef] or [Vfloat] for a float quantity. *) +Axiom load_type: + forall m chunk b ofs v, + load chunk m b ofs = Some v -> + Val.has_type v (type_of_chunk chunk). + +(** For a small integer or float type, the value returned by [load] + is invariant under the corresponding cast. *) +Axiom load_cast: + forall m chunk b ofs v, + load chunk m b ofs = Some v -> + match chunk with + | Mint8signed => v = Val.sign_ext 8 v + | Mint8unsigned => v = Val.zero_ext 8 v + | Mint16signed => v = Val.sign_ext 16 v + | Mint16unsigned => v = Val.zero_ext 16 v + | Mfloat32 => v = Val.singleoffloat v + | _ => True + end. + +Axiom load_int8_signed_unsigned: + forall m b ofs, + load Mint8signed m b ofs = option_map (Val.sign_ext 8) (load Mint8unsigned m b ofs). + +Axiom load_int16_signed_unsigned: + forall m b ofs, + load Mint16signed m b ofs = option_map (Val.sign_ext 16) (load Mint16unsigned m b ofs). + + +(** ** Properties of [loadbytes]. *) + +(** If [loadbytes] succeeds, the corresponding [load] succeeds and + returns a [Vint] or [Vfloat] value that is determined by the + bytes read by [loadbytes]. *) +Axiom loadbytes_load: + forall chunk m b ofs bytes, + loadbytes m b ofs (size_chunk chunk) = Some bytes -> + (align_chunk chunk | ofs) -> + load chunk m b ofs = + Some(match type_of_chunk chunk with + | Tint => Vint(decode_int chunk bytes) + | Tfloat => Vfloat(decode_float chunk bytes) + end). + +(** Conversely, if [load] returns an int or a float, the corresponding + [loadbytes] succeeds and returns a list of bytes which decodes into the + result of [load]. *) +Axiom load_int_loadbytes: + forall chunk m b ofs n, + load chunk m b ofs = Some(Vint n) -> + type_of_chunk chunk = Tint /\ + exists bytes, loadbytes m b ofs (size_chunk chunk) = Some bytes + /\ n = decode_int chunk bytes. + +Axiom load_float_loadbytes: + forall chunk m b ofs f, + load chunk m b ofs = Some(Vfloat f) -> + type_of_chunk chunk = Tfloat /\ + exists bytes, loadbytes m b ofs (size_chunk chunk) = Some bytes + /\ f = decode_float chunk bytes. + + +(** [loadbytes] returns a list of length [n] (the number of bytes read). *) +Axiom loadbytes_length: + forall m b ofs n bytes, + loadbytes m b ofs n = Some bytes -> + length bytes = nat_of_Z n. + +(** Composing or decomposing [loadbytes] operations at adjacent addresses. *) +Axiom loadbytes_concat: + forall m b ofs n1 n2 bytes1 bytes2, + loadbytes m b ofs n1 = Some bytes1 -> + loadbytes m b (ofs + n1) n2 = Some bytes2 -> + n1 >= 0 -> n2 >= 0 -> + loadbytes m b ofs (n1 + n2) = Some(bytes1 ++ bytes2). +Axiom loadbytes_split: + forall m b ofs n1 n2 bytes, + loadbytes m b ofs (n1 + n2) = Some bytes -> + n1 >= 0 -> n2 >= 0 -> + exists bytes1, exists bytes2, + loadbytes m b ofs n1 = Some bytes1 + /\ loadbytes m b (ofs + n1) n2 = Some bytes2 + /\ bytes = bytes1 ++ bytes2. + +(** ** Properties of [store]. *) + +(** [store] preserves block validity, permissions, access validity, and bounds. + Moreover, a [store] succeeds if and only if the corresponding access + is valid for writing. *) + +Axiom nextblock_store: + forall chunk m1 b ofs v m2, store chunk m1 b ofs v = Some m2 -> + nextblock m2 = nextblock m1. +Axiom store_valid_block_1: + forall chunk m1 b ofs v m2, store chunk m1 b ofs v = Some m2 -> + forall b', valid_block m1 b' -> valid_block m2 b'. +Axiom store_valid_block_2: + forall chunk m1 b ofs v m2, store chunk m1 b ofs v = Some m2 -> + forall b', valid_block m2 b' -> valid_block m1 b'. + +Axiom perm_store_1: + forall chunk m1 b ofs v m2, store chunk m1 b ofs v = Some m2 -> + forall b' ofs' p, perm m1 b' ofs' p -> perm m2 b' ofs' p. +Axiom perm_store_2: + forall chunk m1 b ofs v m2, store chunk m1 b ofs v = Some m2 -> + forall b' ofs' p, perm m2 b' ofs' p -> perm m1 b' ofs' p. + +Axiom valid_access_store: + forall m1 chunk b ofs v, + valid_access m1 chunk b ofs Writable -> + { m2: mem | store chunk m1 b ofs v = Some m2 }. +Axiom store_valid_access_1: + forall chunk m1 b ofs v m2, store chunk m1 b ofs v = Some m2 -> + forall chunk' b' ofs' p, + valid_access m1 chunk' b' ofs' p -> valid_access m2 chunk' b' ofs' p. +Axiom store_valid_access_2: + forall chunk m1 b ofs v m2, store chunk m1 b ofs v = Some m2 -> + forall chunk' b' ofs' p, + valid_access m2 chunk' b' ofs' p -> valid_access m1 chunk' b' ofs' p. +Axiom store_valid_access_3: + forall chunk m1 b ofs v m2, store chunk m1 b ofs v = Some m2 -> + valid_access m1 chunk b ofs Writable. + +Axiom bounds_store: + forall chunk m1 b ofs v m2, store chunk m1 b ofs v = Some m2 -> + forall b', bounds m2 b' = bounds m1 b'. + +(** Load-store properties. *) + +Axiom load_store_similar: + forall chunk m1 b ofs v m2, store chunk m1 b ofs v = Some m2 -> + forall chunk', + size_chunk chunk' = size_chunk chunk -> + exists v', load chunk' m2 b ofs = Some v' /\ decode_encode_val v chunk chunk' v'. + +Axiom load_store_same: + forall chunk m1 b ofs v m2, store chunk m1 b ofs v = Some m2 -> + Val.has_type v (type_of_chunk chunk) -> + load chunk m2 b ofs = Some (Val.load_result chunk v). + +Axiom load_store_other: + forall chunk m1 b ofs v m2, store chunk m1 b ofs v = Some m2 -> + forall chunk' b' ofs', + b' <> b + \/ ofs' + size_chunk chunk' <= ofs + \/ ofs + size_chunk chunk <= ofs' -> + load chunk' m2 b' ofs' = load chunk' m1 b' ofs'. + +(** Integrity of pointer values. *) + +Axiom load_store_pointer_overlap: + forall chunk m1 b ofs v_b v_o m2 chunk' ofs' v, + store chunk m1 b ofs (Vptr v_b v_o) = Some m2 -> + load chunk' m2 b ofs' = Some v -> + ofs' <> ofs -> + ofs' + size_chunk chunk' > ofs -> + ofs + size_chunk chunk > ofs' -> + v = Vundef. +Axiom load_store_pointer_mismatch: + forall chunk m1 b ofs v_b v_o m2 chunk' v, + store chunk m1 b ofs (Vptr v_b v_o) = Some m2 -> + load chunk' m2 b ofs = Some v -> + chunk <> Mint32 \/ chunk' <> Mint32 -> + v = Vundef. +Axiom load_pointer_store: + forall chunk m1 b ofs v m2, store chunk m1 b ofs v = Some m2 -> + forall chunk' b' ofs' v_b v_o, + load chunk' m2 b' ofs' = Some(Vptr v_b v_o) -> + (chunk = Mint32 /\ v = Vptr v_b v_o /\ chunk' = Mint32 /\ b' = b /\ ofs' = ofs) + \/ (b' <> b \/ ofs' + size_chunk chunk' <= ofs \/ ofs + size_chunk chunk <= ofs'). + +(** Load-store properties for [loadbytes]. *) + +Axiom loadbytes_store_same: + forall chunk m1 b ofs v m2, store chunk m1 b ofs v = Some m2 -> + loadbytes m2 b ofs (size_chunk chunk) = + match v with + | Vundef => None + | Vint n => Some(encode_int chunk n) + | Vfloat n => Some(encode_float chunk n) + | Vptr _ _ => None + end. +Axiom loadbytes_store_other: + forall chunk m1 b ofs v m2, store chunk m1 b ofs v = Some m2 -> + forall b' ofs' n, + b' <> b \/ n <= 0 \/ ofs' + n <= ofs \/ ofs + size_chunk chunk <= ofs' -> + loadbytes m2 b' ofs' n = loadbytes m1 b' ofs' n. + +(** [store] is insensitive to the signedness or the high bits of + small integer quantities. *) + +Axiom store_signed_unsigned_8: + forall m b ofs v, + store Mint8signed m b ofs v = store Mint8unsigned m b ofs v. +Axiom store_signed_unsigned_16: + forall m b ofs v, + store Mint16signed m b ofs v = store Mint16unsigned m b ofs v. +Axiom store_int8_zero_ext: + forall m b ofs n, + store Mint8unsigned m b ofs (Vint (Int.zero_ext 8 n)) = + store Mint8unsigned m b ofs (Vint n). +Axiom store_int8_sign_ext: + forall m b ofs n, + store Mint8signed m b ofs (Vint (Int.sign_ext 8 n)) = + store Mint8signed m b ofs (Vint n). +Axiom store_int16_zero_ext: + forall m b ofs n, + store Mint16unsigned m b ofs (Vint (Int.zero_ext 16 n)) = + store Mint16unsigned m b ofs (Vint n). +Axiom store_int16_sign_ext: + forall m b ofs n, + store Mint16signed m b ofs (Vint (Int.sign_ext 16 n)) = + store Mint16signed m b ofs (Vint n). +Axiom store_float32_truncate: + forall m b ofs n, + store Mfloat32 m b ofs (Vfloat (Float.singleoffloat n)) = + store Mfloat32 m b ofs (Vfloat n). + +(** ** Properties of [alloc]. *) + +(** The identifier of the freshly allocated block is the next block + of the initial memory state. *) + +Axiom alloc_result: + forall m1 lo hi m2 b, alloc m1 lo hi = (m2, b) -> + b = nextblock m1. + +(** Effect of [alloc] on block validity. *) + +Axiom nextblock_alloc: + forall m1 lo hi m2 b, alloc m1 lo hi = (m2, b) -> + nextblock m2 = Zsucc (nextblock m1). + +Axiom valid_block_alloc: + forall m1 lo hi m2 b, alloc m1 lo hi = (m2, b) -> + forall b', valid_block m1 b' -> valid_block m2 b'. +Axiom fresh_block_alloc: + forall m1 lo hi m2 b, alloc m1 lo hi = (m2, b) -> + ~(valid_block m1 b). +Axiom valid_new_block: + forall m1 lo hi m2 b, alloc m1 lo hi = (m2, b) -> + valid_block m2 b. +Axiom valid_block_alloc_inv: + forall m1 lo hi m2 b, alloc m1 lo hi = (m2, b) -> + forall b', valid_block m2 b' -> b' = b \/ valid_block m1 b'. + +(** Effect of [alloc] on permissions. *) + +Axiom perm_alloc_1: + forall m1 lo hi m2 b, alloc m1 lo hi = (m2, b) -> + forall b' ofs p, perm m1 b' ofs p -> perm m2 b' ofs p. +Axiom perm_alloc_2: + forall m1 lo hi m2 b, alloc m1 lo hi = (m2, b) -> + forall ofs, lo <= ofs < hi -> perm m2 b ofs Freeable. +Axiom perm_alloc_3: + forall m1 lo hi m2 b, alloc m1 lo hi = (m2, b) -> + forall ofs p, ofs < lo \/ hi <= ofs -> ~perm m2 b ofs p. +Axiom perm_alloc_inv: + forall m1 lo hi m2 b, alloc m1 lo hi = (m2, b) -> + forall b' ofs p, + perm m2 b' ofs p -> + if zeq b' b then lo <= ofs < hi else perm m1 b' ofs p. + +(** Effect of [alloc] on access validity. *) + +Axiom valid_access_alloc_other: + forall m1 lo hi m2 b, alloc m1 lo hi = (m2, b) -> + forall chunk b' ofs p, + valid_access m1 chunk b' ofs p -> + valid_access m2 chunk b' ofs p. +Axiom valid_access_alloc_same: + forall m1 lo hi m2 b, alloc m1 lo hi = (m2, b) -> + forall chunk ofs, + lo <= ofs -> ofs + size_chunk chunk <= hi -> (align_chunk chunk | ofs) -> + valid_access m2 chunk b ofs Freeable. +Axiom valid_access_alloc_inv: + forall m1 lo hi m2 b, alloc m1 lo hi = (m2, b) -> + forall chunk b' ofs p, + valid_access m2 chunk b' ofs p -> + if eq_block b' b + then lo <= ofs /\ ofs + size_chunk chunk <= hi /\ (align_chunk chunk | ofs) + else valid_access m1 chunk b' ofs p. + +(** Effect of [alloc] on bounds. *) + +Axiom bounds_alloc: + forall m1 lo hi m2 b, alloc m1 lo hi = (m2, b) -> + forall b', bounds m2 b' = if eq_block b' b then (lo, hi) else bounds m1 b'. + +Axiom bounds_alloc_same: + forall m1 lo hi m2 b, alloc m1 lo hi = (m2, b) -> + bounds m2 b = (lo, hi). + +Axiom bounds_alloc_other: + forall m1 lo hi m2 b, alloc m1 lo hi = (m2, b) -> + forall b', b' <> b -> bounds m2 b' = bounds m1 b'. + +(** Load-alloc properties. *) + +Axiom load_alloc_unchanged: + forall m1 lo hi m2 b, alloc m1 lo hi = (m2, b) -> + forall chunk b' ofs, + valid_block m1 b' -> + load chunk m2 b' ofs = load chunk m1 b' ofs. +Axiom load_alloc_other: + forall m1 lo hi m2 b, alloc m1 lo hi = (m2, b) -> + forall chunk b' ofs v, + load chunk m1 b' ofs = Some v -> + load chunk m2 b' ofs = Some v. +Axiom load_alloc_same: + forall m1 lo hi m2 b, alloc m1 lo hi = (m2, b) -> + forall chunk ofs v, + load chunk m2 b ofs = Some v -> + v = Vundef. +Axiom load_alloc_same': + forall m1 lo hi m2 b, alloc m1 lo hi = (m2, b) -> + forall chunk ofs, + lo <= ofs -> ofs + size_chunk chunk <= hi -> (align_chunk chunk | ofs) -> + load chunk m2 b ofs = Some Vundef. + +(** ** Properties of [free]. *) + +(** [free] succeeds if and only if the correspond range of addresses + has [Freeable] permission. *) + +Axiom range_perm_free: + forall m1 b lo hi, + range_perm m1 b lo hi Freeable -> + { m2: mem | free m1 b lo hi = Some m2 }. +Axiom free_range_perm: + forall m1 bf lo hi m2, free m1 bf lo hi = Some m2 -> + range_perm m1 bf lo hi Freeable. + +(** Block validity is preserved by [free]. *) + +Axiom nextblock_free: + forall m1 bf lo hi m2, free m1 bf lo hi = Some m2 -> + nextblock m2 = nextblock m1. +Axiom valid_block_free_1: + forall m1 bf lo hi m2, free m1 bf lo hi = Some m2 -> + forall b, valid_block m1 b -> valid_block m2 b. +Axiom valid_block_free_2: + forall m1 bf lo hi m2, free m1 bf lo hi = Some m2 -> + forall b, valid_block m2 b -> valid_block m1 b. + +(** Effect of [free] on permissions. *) + +Axiom perm_free_1: + forall m1 bf lo hi m2, free m1 bf lo hi = Some m2 -> + forall b ofs p, + b <> bf \/ ofs < lo \/ hi <= ofs -> + perm m1 b ofs p -> + perm m2 b ofs p. +Axiom perm_free_2: + forall m1 bf lo hi m2, free m1 bf lo hi = Some m2 -> + forall ofs p, lo <= ofs < hi -> ~ perm m2 bf ofs p. +Axiom perm_free_3: + forall m1 bf lo hi m2, free m1 bf lo hi = Some m2 -> + forall b ofs p, + perm m2 b ofs p -> perm m1 b ofs p. + +(** Effect of [free] on access validity. *) + +Axiom valid_access_free_1: + forall m1 bf lo hi m2, free m1 bf lo hi = Some m2 -> + forall chunk b ofs p, + valid_access m1 chunk b ofs p -> + b <> bf \/ lo >= hi \/ ofs + size_chunk chunk <= lo \/ hi <= ofs -> + valid_access m2 chunk b ofs p. +Axiom valid_access_free_2: + forall m1 bf lo hi m2, free m1 bf lo hi = Some m2 -> + forall chunk ofs p, + lo < hi -> ofs + size_chunk chunk > lo -> ofs < hi -> + ~(valid_access m2 chunk bf ofs p). +Axiom valid_access_free_inv_1: + forall m1 bf lo hi m2, free m1 bf lo hi = Some m2 -> + forall chunk b ofs p, + valid_access m2 chunk b ofs p -> + valid_access m1 chunk b ofs p. +Axiom valid_access_free_inv_2: + forall m1 bf lo hi m2, free m1 bf lo hi = Some m2 -> + forall chunk ofs p, + valid_access m2 chunk bf ofs p -> + lo >= hi \/ ofs + size_chunk chunk <= lo \/ hi <= ofs. + +(** [free] preserves bounds. *) + +Axiom bounds_free: + forall m1 bf lo hi m2, free m1 bf lo hi = Some m2 -> + forall b, bounds m2 b = bounds m1 b. + +(** Load-free properties *) + +Axiom load_free: + forall m1 bf lo hi m2, free m1 bf lo hi = Some m2 -> + forall chunk b ofs, + b <> bf \/ lo >= hi \/ ofs + size_chunk chunk <= lo \/ hi <= ofs -> + load chunk m2 b ofs = load chunk m1 b ofs. + +(** * Relating two memory states. *) + +(** ** Memory extensions *) + +(** A store [m2] extends a store [m1] if [m2] can be obtained from [m1] + by relaxing the permissions of [m1] (for instance, allocating larger + blocks) and replacing some of the [Vundef] values stored in [m1] by + more defined values stored in [m2] at the same addresses. *) + +Parameter extends: mem -> mem -> Prop. + +Axiom extends_refl: + forall m, extends m m. + +Axiom load_extends: + forall chunk m1 m2 b ofs v1, + extends m1 m2 -> + load chunk m1 b ofs = Some v1 -> + exists v2, load chunk m2 b ofs = Some v2 /\ Val.lessdef v1 v2. + +Axiom loadv_extends: + forall chunk m1 m2 addr1 addr2 v1, + extends m1 m2 -> + loadv chunk m1 addr1 = Some v1 -> + Val.lessdef addr1 addr2 -> + exists v2, loadv chunk m2 addr2 = Some v2 /\ Val.lessdef v1 v2. + +Axiom store_within_extends: + forall chunk m1 m2 b ofs v1 m1' v2, + extends m1 m2 -> + store chunk m1 b ofs v1 = Some m1' -> + Val.lessdef v1 v2 -> + exists m2', + store chunk m2 b ofs v2 = Some m2' + /\ extends m1' m2'. + +Axiom store_outside_extends: + forall chunk m1 m2 b ofs v m2', + extends m1 m2 -> + store chunk m2 b ofs v = Some m2' -> + ofs + size_chunk chunk <= low_bound m1 b \/ high_bound m1 b <= ofs -> + extends m1 m2'. + +Axiom storev_extends: + forall chunk m1 m2 addr1 v1 m1' addr2 v2, + extends m1 m2 -> + storev chunk m1 addr1 v1 = Some m1' -> + Val.lessdef addr1 addr2 -> + Val.lessdef v1 v2 -> + exists m2', + storev chunk m2 addr2 v2 = Some m2' + /\ extends m1' m2'. + +Axiom alloc_extends: + forall m1 m2 lo1 hi1 b m1' lo2 hi2, + extends m1 m2 -> + alloc m1 lo1 hi1 = (m1', b) -> + lo2 <= lo1 -> hi1 <= hi2 -> + exists m2', + alloc m2 lo2 hi2 = (m2', b) + /\ extends m1' m2'. + +Axiom free_left_extends: + forall m1 m2 b lo hi m1', + extends m1 m2 -> + free m1 b lo hi = Some m1' -> + extends m1' m2. + +Axiom free_right_extends: + forall m1 m2 b lo hi m2', + extends m1 m2 -> + free m2 b lo hi = Some m2' -> + (forall ofs p, lo <= ofs < hi -> ~perm m1 b ofs p) -> + extends m1 m2'. + +Axiom free_parallel_extends: + forall m1 m2 b lo hi m1', + extends m1 m2 -> + free m1 b lo hi = Some m1' -> + exists m2', + free m2 b lo hi = Some m2' + /\ extends m1' m2'. + +Axiom valid_block_extends: + forall m1 m2 b, + extends m1 m2 -> + (valid_block m1 b <-> valid_block m2 b). +Axiom perm_extends: + forall m1 m2 b ofs p, + extends m1 m2 -> perm m1 b ofs p -> perm m2 b ofs p. +Axiom valid_access_extends: + forall m1 m2 chunk b ofs p, + extends m1 m2 -> valid_access m1 chunk b ofs p -> valid_access m2 chunk b ofs p. + +(** * Memory injections *) + +(** A memory injection [f] is a function from addresses to either [None] + or [Some] of an address and an offset. It defines a correspondence + between the blocks of two memory states [m1] and [m2]: +- if [f b = None], the block [b] of [m1] has no equivalent in [m2]; +- if [f b = Some(b', ofs)], the block [b] of [m2] corresponds to + a sub-block at offset [ofs] of the block [b'] in [m2]. + +A memory injection [f] defines a relation [val_inject] between values +that is the identity for integer and float values, and relocates pointer +values as prescribed by [f]. (See module [Values].) + +Likewise, a memory injection [f] defines a relation between memory states +that we now axiomatize. *) + +Parameter inject: meminj -> mem -> mem -> Prop. + +Axiom valid_block_inject_1: + forall f m1 m2 b1 b2 delta, + f b1 = Some(b2, delta) -> + inject f m1 m2 -> + valid_block m1 b1. + +Axiom valid_block_inject_2: + forall f m1 m2 b1 b2 delta, + f b1 = Some(b2, delta) -> + inject f m1 m2 -> + valid_block m2 b2. + +Axiom perm_inject: + forall f m1 m2 b1 b2 delta ofs p, + f b1 = Some(b2, delta) -> + inject f m1 m2 -> + perm m1 b1 ofs p -> perm m2 b2 (ofs + delta) p. + +Axiom valid_access_inject: + forall f m1 m2 chunk b1 ofs b2 delta p, + f b1 = Some(b2, delta) -> + inject f m1 m2 -> + valid_access m1 chunk b1 ofs p -> + valid_access m2 chunk b2 (ofs + delta) p. + +Axiom valid_pointer_inject: + forall f m1 m2 b1 ofs b2 delta, + f b1 = Some(b2, delta) -> + inject f m1 m2 -> + valid_pointer m1 b1 ofs = true -> + valid_pointer m2 b2 (ofs + delta) = true. + +Axiom address_inject: + forall f m1 m2 b1 ofs1 b2 delta, + inject f m1 m2 -> + perm m1 b1 (Int.signed ofs1) Nonempty -> + f b1 = Some (b2, delta) -> + Int.signed (Int.add ofs1 (Int.repr delta)) = Int.signed ofs1 + delta. + +Axiom valid_pointer_inject_no_overflow: + forall f m1 m2 b ofs b' x, + inject f m1 m2 -> + valid_pointer m1 b (Int.signed ofs) = true -> + f b = Some(b', x) -> + Int.min_signed <= Int.signed ofs + Int.signed (Int.repr x) <= Int.max_signed. + +Axiom valid_pointer_inject_val: + forall f m1 m2 b ofs b' ofs', + inject f m1 m2 -> + valid_pointer m1 b (Int.signed ofs) = true -> + val_inject f (Vptr b ofs) (Vptr b' ofs') -> + valid_pointer m2 b' (Int.signed ofs') = true. + +Axiom inject_no_overlap: + forall f m1 m2 b1 b2 b1' b2' delta1 delta2 ofs1 ofs2, + inject f m1 m2 -> + b1 <> b2 -> + f b1 = Some (b1', delta1) -> + f b2 = Some (b2', delta2) -> + perm m1 b1 ofs1 Nonempty -> + perm m1 b2 ofs2 Nonempty -> + b1' <> b2' \/ ofs1 + delta1 <> ofs2 + delta2. + +Axiom different_pointers_inject: + forall f m m' b1 ofs1 b2 ofs2 b1' delta1 b2' delta2, + inject f m m' -> + b1 <> b2 -> + valid_pointer m b1 (Int.signed ofs1) = true -> + valid_pointer m b2 (Int.signed ofs2) = true -> + f b1 = Some (b1', delta1) -> + f b2 = Some (b2', delta2) -> + b1' <> b2' \/ + Int.signed (Int.add ofs1 (Int.repr delta1)) <> + Int.signed (Int.add ofs2 (Int.repr delta2)). + +Axiom load_inject: + forall f m1 m2 chunk b1 ofs b2 delta v1, + inject f m1 m2 -> + load chunk m1 b1 ofs = Some v1 -> + f b1 = Some (b2, delta) -> + exists v2, load chunk m2 b2 (ofs + delta) = Some v2 /\ val_inject f v1 v2. + +Axiom loadv_inject: + forall f m1 m2 chunk a1 a2 v1, + inject f m1 m2 -> + loadv chunk m1 a1 = Some v1 -> + val_inject f a1 a2 -> + exists v2, loadv chunk m2 a2 = Some v2 /\ val_inject f v1 v2. + +Axiom store_mapped_inject: + forall f chunk m1 b1 ofs v1 n1 m2 b2 delta v2, + inject f m1 m2 -> + store chunk m1 b1 ofs v1 = Some n1 -> + f b1 = Some (b2, delta) -> + val_inject f v1 v2 -> + exists n2, + store chunk m2 b2 (ofs + delta) v2 = Some n2 + /\ inject f n1 n2. + +Axiom store_unmapped_inject: + forall f chunk m1 b1 ofs v1 n1 m2, + inject f m1 m2 -> + store chunk m1 b1 ofs v1 = Some n1 -> + f b1 = None -> + inject f n1 m2. + +Axiom store_outside_inject: + forall f m1 m2 chunk b ofs v m2', + inject f m1 m2 -> + (forall b' delta, + f b' = Some(b, delta) -> + high_bound m1 b' + delta <= ofs + \/ ofs + size_chunk chunk <= low_bound m1 b' + delta) -> + store chunk m2 b ofs v = Some m2' -> + inject f m1 m2'. + +Axiom storev_mapped_inject: + forall f chunk m1 a1 v1 n1 m2 a2 v2, + inject f m1 m2 -> + storev chunk m1 a1 v1 = Some n1 -> + val_inject f a1 a2 -> + val_inject f v1 v2 -> + exists n2, + storev chunk m2 a2 v2 = Some n2 /\ inject f n1 n2. + +Axiom alloc_right_inject: + forall f m1 m2 lo hi b2 m2', + inject f m1 m2 -> + alloc m2 lo hi = (m2', b2) -> + inject f m1 m2'. + +Axiom alloc_left_unmapped_inject: + forall f m1 m2 lo hi m1' b1, + inject f m1 m2 -> + alloc m1 lo hi = (m1', b1) -> + exists f', + inject f' m1' m2 + /\ inject_incr f f' + /\ f' b1 = None + /\ (forall b, b <> b1 -> f' b = f b). + +Definition inj_offset_aligned (delta: Z) (size: Z) : Prop := + forall chunk, size_chunk chunk <= size -> (align_chunk chunk | delta). + +Axiom alloc_left_mapped_inject: + forall f m1 m2 lo hi m1' b1 b2 delta, + inject f m1 m2 -> + alloc m1 lo hi = (m1', b1) -> + valid_block m2 b2 -> + Int.min_signed <= delta <= Int.max_signed -> + delta = 0 \/ Int.min_signed <= low_bound m2 b2 /\ high_bound m2 b2 <= Int.max_signed -> + (forall ofs p, lo <= ofs < hi -> perm m2 b2 (ofs + delta) p) -> + inj_offset_aligned delta (hi-lo) -> + (forall b ofs, + f b = Some (b2, ofs) -> + high_bound m1 b + ofs <= lo + delta \/ + hi + delta <= low_bound m1 b + ofs) -> + exists f', + inject f' m1' m2 + /\ inject_incr f f' + /\ f' b1 = Some(b2, delta) + /\ (forall b, b <> b1 -> f' b = f b). + +Axiom alloc_parallel_inject: + forall f m1 m2 lo1 hi1 m1' b1 lo2 hi2, + inject f m1 m2 -> + alloc m1 lo1 hi1 = (m1', b1) -> + lo2 <= lo1 -> hi1 <= hi2 -> + exists f', exists m2', exists b2, + alloc m2 lo2 hi2 = (m2', b2) + /\ inject f' m1' m2' + /\ inject_incr f f' + /\ f' b1 = Some(b2, 0) + /\ (forall b, b <> b1 -> f' b = f b). + +Axiom free_inject: + forall f m1 l m1' m2 b lo hi m2', + inject f m1 m2 -> + free_list m1 l = Some m1' -> + free m2 b lo hi = Some m2' -> + (forall b1 delta ofs p, + f b1 = Some(b, delta) -> perm m1 b1 ofs p -> lo <= ofs + delta < hi -> + exists lo1, exists hi1, In (b1, lo1, hi1) l /\ lo1 <= ofs < hi1) -> + inject f m1' m2'. + +(** Memory states that inject into themselves. *) + +Definition flat_inj (thr: block) : meminj := + fun (b: block) => if zlt b thr then Some(b, 0) else None. + +Parameter inject_neutral: forall (thr: block) (m: mem), Prop. + +Axiom neutral_inject: + forall m, inject_neutral (nextblock m) m -> + inject (flat_inj (nextblock m)) m m. + +Axiom empty_inject_neutral: + forall thr, inject_neutral thr empty. + +Axiom alloc_inject_neutral: + forall thr m lo hi b m', + alloc m lo hi = (m', b) -> + inject_neutral thr m -> + nextblock m < thr -> + inject_neutral thr m'. + +Axiom store_inject_neutral: + forall chunk m b ofs v m' thr, + store chunk m b ofs v = Some m' -> + inject_neutral thr m -> + b < thr -> + val_inject (flat_inj thr) v v -> + inject_neutral thr m'. + +End MEM. diff --git a/common/Values.v b/common/Values.v index 19a8077..056cffb 100644 --- a/common/Values.v +++ b/common/Values.v @@ -46,6 +46,8 @@ Definition Vmone: val := Vint Int.mone. Definition Vtrue: val := Vint Int.one. Definition Vfalse: val := Vint Int.zero. +(** * Operations over values *) + (** The module [Val] defines a number of arithmetic and logical operations over type [val]. Most of these operations are straightforward extensions of the corresponding integer or floating-point operations. *) @@ -984,3 +986,82 @@ Proof. Qed. End Val. + +(** * Values and memory injections *) + +(** A memory injection [f] is a function from addresses to either [None] + or [Some] of an address and an offset. It defines a correspondence + between the blocks of two memory states [m1] and [m2]: +- if [f b = None], the block [b] of [m1] has no equivalent in [m2]; +- if [f b = Some(b', ofs)], the block [b] of [m2] corresponds to + a sub-block at offset [ofs] of the block [b'] in [m2]. +*) + +Definition meminj : Type := block -> option (block * Z). + +(** A memory injection defines a relation between values that is the + identity relation, except for pointer values which are shifted + as prescribed by the memory injection. Moreover, [Vundef] values + inject into any other value. *) + +Inductive val_inject (mi: meminj): val -> val -> Prop := + | val_inject_int: + forall i, val_inject mi (Vint i) (Vint i) + | val_inject_float: + forall f, val_inject mi (Vfloat f) (Vfloat f) + | val_inject_ptr: + forall b1 ofs1 b2 ofs2 delta, + mi b1 = Some (b2, delta) -> + ofs2 = Int.add ofs1 (Int.repr delta) -> + val_inject mi (Vptr b1 ofs1) (Vptr b2 ofs2) + | val_inject_undef: forall v, + val_inject mi Vundef v. + +Hint Resolve val_inject_int val_inject_float val_inject_ptr + val_inject_undef. + +Inductive val_list_inject (mi: meminj): list val -> list val-> Prop:= + | val_nil_inject : + val_list_inject mi nil nil + | val_cons_inject : forall v v' vl vl' , + val_inject mi v v' -> val_list_inject mi vl vl'-> + val_list_inject mi (v :: vl) (v' :: vl'). + +Hint Resolve val_nil_inject val_cons_inject. + +(** Monotone evolution of a memory injection. *) + +Definition inject_incr (f1 f2: meminj) : Prop := + forall b b' delta, f1 b = Some(b', delta) -> f2 b = Some(b', delta). + +Lemma inject_incr_refl : + forall f , inject_incr f f . +Proof. unfold inject_incr. auto. Qed. + +Lemma inject_incr_trans : + forall f1 f2 f3, + inject_incr f1 f2 -> inject_incr f2 f3 -> inject_incr f1 f3 . +Proof . + unfold inject_incr; intros. eauto. +Qed. + +Lemma val_inject_incr: + forall f1 f2 v v', + inject_incr f1 f2 -> + val_inject f1 v v' -> + val_inject f2 v v'. +Proof. + intros. inv H0; eauto. +Qed. + +Lemma val_list_inject_incr: + forall f1 f2 vl vl' , + inject_incr f1 f2 -> val_list_inject f1 vl vl' -> + val_list_inject f2 vl vl'. +Proof. + induction vl; intros; inv H0. auto. + constructor. eapply val_inject_incr; eauto. auto. +Qed. + +Hint Resolve inject_incr_refl val_inject_incr val_list_inject_incr. + @@ -1,7 +1,17 @@ #!/bin/sh # Start coqide with the right -I options +# Use the Makefile to rebuild dependencies if needed +# Recompile the modified file after coqide editing ARCH=`sed -n -e 's/^ARCH=//p' Makefile.config` VARIANT=`sed -n -e 's/^VARIANT=//p' Makefile.config` -coqide -I lib -I common -I $ARCH/$VARIANT -I $ARCH -I backend -I cfrontend $1 && make ${1}o +make -q ${1}o || { + make -n ${1}o | grep -v "\\b${1}\\b" | \ + (while read cmd; do + $cmd || exit 2 + done) +} + +coqide -I lib -I common -I $ARCH/$VARIANT -I $ARCH -I backend -I cfrontend $1 \ +&& make ${1}o diff --git a/driver/Complements.v b/driver/Complements.v index 6fe5038..b76a99f 100644 --- a/driver/Complements.v +++ b/driver/Complements.v @@ -51,31 +51,29 @@ Qed. Lemma step_internal_deterministic: forall ge s t1 s1 t2 s2, - Asm.step ge s t1 s1 -> Asm.step ge s t2 s2 -> internal_determinism _ t1 s1 t2 s2. + Asm.step ge s t1 s1 -> Asm.step ge s t2 s2 -> matching_traces t1 t2 -> + s1 = s2 /\ t1 = t2. Proof. intros. inv H; inv H0. assert (c0 = c) by congruence. assert (i0 = i) by congruence. assert (rs'0 = rs') by congruence. assert (m'0 = m') by congruence. - subst. constructor. + subst. auto. congruence. congruence. assert (ef0 = ef) by congruence. subst ef0. assert (args0 = args). eapply extcall_arguments_deterministic; eauto. subst args0. - inv H3; inv H8. - assert (eargs0 = eargs). eapply eventval_list_match_deterministic; eauto. subst eargs0. - constructor. intros. - exploit eventval_match_deterministic. eexact H0. eexact H5. intros. - assert (res = res0). tauto. - congruence. + exploit external_call_determ. eexact H4. eexact H9. auto. + intros [A [B C]]. subst. + intuition congruence. Qed. Lemma initial_state_deterministic: forall p s1 s2, initial_state p s1 -> initial_state p s2 -> s1 = s2. Proof. - intros. inv H; inv H0. reflexivity. + intros. inv H; inv H0. f_equal. congruence. Qed. Lemma final_state_not_step: diff --git a/extraction/extraction.v b/extraction/extraction.v index 6488d8b..e8fc572 100644 --- a/extraction/extraction.v +++ b/extraction/extraction.v @@ -43,6 +43,14 @@ Extract Constant Floats.Float.div => "( /. )". Extract Constant Floats.Float.cmp => "Floataux.cmp". Extract Constant Floats.Float.eq_dec => "fun (x: float) (y: float) -> x = y". +(* Memdata *) +Extract Constant Memdata.big_endian => "Memdataaux.big_endian". +Extract Constant Memdata.encode_float => "Memdataaux.encode_float". +Extract Constant Memdata.decode_float => "Memdataaux.decode_float". + +(* Memory - work around an extraction bug. *) +Extraction NoInline Memory.Mem.valid_pointer. + (* Iteration *) Extract Constant Iteration.dependent_description' => "fun x -> assert false". diff --git a/lib/Coqlib.v b/lib/Coqlib.v index 5375c04..380ac73 100644 --- a/lib/Coqlib.v +++ b/lib/Coqlib.v @@ -554,6 +554,27 @@ Proof. omega. Qed. +Lemma Zmod_recombine: + forall x a b, + a > 0 -> b > 0 -> + x mod (a * b) = ((x/b) mod a) * b + (x mod b). +Proof. + intros. + set (xb := x/b). + apply Zmod_unique with (xb/a). + generalize (Z_div_mod_eq x b H0); fold xb; intro EQ1. + generalize (Z_div_mod_eq xb a H); intro EQ2. + rewrite EQ2 in EQ1. + eapply trans_eq. eexact EQ1. ring. + generalize (Z_mod_lt x b H0). intro. + generalize (Z_mod_lt xb a H). intro. + assert (0 <= xb mod a * b <= a * b - b). + split. apply Zmult_le_0_compat; omega. + replace (a * b - b) with ((a - 1) * b) by ring. + apply Zmult_le_compat; omega. + omega. +Qed. + (** Properties of divisibility. *) Lemma Zdivides_trans: @@ -573,6 +594,45 @@ Proof. inv H0. rewrite Z_div_mult; auto. ring. Qed. +(** Conversion from [Z] to [nat]. *) + +Definition nat_of_Z (z: Z) : nat := + match z with + | Z0 => O + | Zpos p => nat_of_P p + | Zneg p => O + end. + +Lemma nat_of_Z_max: + forall z, Z_of_nat (nat_of_Z z) = Zmax z 0. +Proof. + intros. unfold Zmax. destruct z; simpl; auto. + symmetry. apply Zpos_eq_Z_of_nat_o_nat_of_P. +Qed. + +Lemma nat_of_Z_eq: + forall z, z >= 0 -> Z_of_nat (nat_of_Z z) = z. +Proof. + intros. rewrite nat_of_Z_max. apply Zmax_left. auto. +Qed. + +Lemma nat_of_Z_neg: + forall n, n <= 0 -> nat_of_Z n = O. +Proof. + destruct n; unfold Zle; simpl; auto. congruence. +Qed. + +Lemma nat_of_Z_plus: + forall p q, + p >= 0 -> q >= 0 -> + nat_of_Z (p + q) = (nat_of_Z p + nat_of_Z q)%nat. +Proof. + intros. + apply inj_eq_rev. rewrite inj_plus. + repeat rewrite nat_of_Z_eq; auto. omega. +Qed. + + (** Alignment: [align n amount] returns the smallest multiple of [amount] greater than or equal to [n]. *) @@ -817,6 +877,18 @@ Proof. auto. rewrite IHl1. auto. Qed. +Lemma list_append_map_inv: + forall (A B: Type) (f: A -> B) (m1 m2: list B) (l: list A), + List.map f l = m1 ++ m2 -> + exists l1, exists l2, List.map f l1 = m1 /\ List.map f l2 = m2 /\ l = l1 ++ l2. +Proof. + induction m1; simpl; intros. + exists (@nil A); exists l; auto. + destruct l; simpl in H; inv H. + exploit IHm1; eauto. intros [l1 [l2 [P [Q R]]]]. subst l. + exists (a0 :: l1); exists l2; intuition. simpl; congruence. +Qed. + (** Properties of list membership. *) Lemma in_cns: @@ -1050,6 +1122,14 @@ Inductive list_forall2: list A -> list B -> Prop := list_forall2 al bl -> list_forall2 (a1 :: al) (b1 :: bl). +Lemma list_forall2_app: + forall a2 b2 a1 b1, + list_forall2 a1 b1 -> list_forall2 a2 b2 -> + list_forall2 (a1 ++ a2) (b1 ++ b2). +Proof. + induction 1; intros; simpl. auto. constructor; auto. +Qed. + End FORALL2. Lemma list_forall2_imply: @@ -1095,6 +1175,26 @@ Proof. destruct l; simpl; auto. Qed. +(** A list of [n] elements, all equal to [x]. *) + +Fixpoint list_repeat {A: Type} (n: nat) (x: A) {struct n} := + match n with + | O => nil + | S m => x :: list_repeat m x + end. + +Lemma length_list_repeat: + forall (A: Type) n (x: A), length (list_repeat n x) = n. +Proof. + induction n; simpl; intros. auto. decEq; auto. +Qed. + +Lemma in_list_repeat: + forall (A: Type) n (x: A) y, In y (list_repeat n x) -> y = x. +Proof. + induction n; simpl; intros. elim H. destruct H; auto. +Qed. + (** * Definitions and theorems over boolean types *) Definition proj_sumbool (P Q: Prop) (a: {P} + {Q}) : bool := @@ -1110,6 +1210,12 @@ Proof. intros P Q a. destruct a; simpl. auto. congruence. Qed. +Lemma proj_sumbool_is_true: + forall (P: Prop) (a: {P}+{~P}), P -> proj_sumbool a = true. +Proof. + intros. unfold proj_sumbool. destruct a. auto. contradiction. +Qed. + Section DECIDABLE_EQUALITY. Variable A: Type. @@ -1141,3 +1247,24 @@ Proof. Qed. End DECIDABLE_EQUALITY. + +Section DECIDABLE_PREDICATE. + +Variable P: Prop. +Variable dec: {P} + {~P}. +Variable A: Type. + +Lemma pred_dec_true: + forall (a b: A), P -> (if dec then a else b) = a. +Proof. + intros. destruct dec. auto. contradiction. +Qed. + +Lemma pred_dec_false: + forall (a b: A), ~P -> (if dec then a else b) = b. +Proof. + intros. destruct dec. contradiction. auto. +Qed. + +End DECIDABLE_PREDICATE. + diff --git a/lib/Integers.v b/lib/Integers.v index fb6eee2..b443d54 100644 --- a/lib/Integers.v +++ b/lib/Integers.v @@ -2670,15 +2670,15 @@ Qed. End Make. -(** * Specialization to 32-bit integers. *) +(** * Specialization to 32-bit integers and to bytes. *) -Module IntWordsize. +Module Wordsize_32. Definition wordsize := 32%nat. Remark wordsize_not_zero: wordsize <> 0%nat. Proof. unfold wordsize; congruence. Qed. -End IntWordsize. +End Wordsize_32. -Module Int := Make(IntWordsize). +Module Int := Make(Wordsize_32). Notation int := Int.int. @@ -2688,5 +2688,12 @@ Proof. exists (two_p (32-5)); reflexivity. Qed. +Module Wordsize_8. + Definition wordsize := 8%nat. + Remark wordsize_not_zero: wordsize <> 0%nat. + Proof. unfold wordsize; congruence. Qed. +End Wordsize_8. +Module Byte := Integers.Make(Wordsize_8). +Notation byte := Byte.int. diff --git a/lib/Intv.v b/lib/Intv.v new file mode 100644 index 0000000..834f83d --- /dev/null +++ b/lib/Intv.v @@ -0,0 +1,319 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* 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. *) +(* *) +(* *********************************************************************) + +(** Definitions and theorems about semi-open integer intervals *) + +Require Import Coqlib. +Require Import Zwf. +Require Coq.Program.Wf. +Require Recdef. + +Definition interv : Type := (Z * Z)%type. + +(** * Membership *) + +Definition In (x: Z) (i: interv) : Prop := fst i <= x < snd i. + +Lemma In_dec: + forall x i, {In x i} + {~In x i}. +Proof. + unfold In; intros. + case (zle (fst i) x); intros. + case (zlt x (snd i)); intros. + left; auto. + right; intuition. + right; intuition. +Qed. + +Lemma notin_range: + forall x i, + x < fst i \/ x >= snd i -> ~In x i. +Proof. + unfold In; intros; omega. +Qed. + +Lemma range_notin: + forall x i, + ~In x i -> fst i < snd i -> x < fst i \/ x >= snd i. +Proof. + unfold In; intros; omega. +Qed. + +(** * Emptyness *) + +Definition empty (i: interv) : Prop := fst i >= snd i. + +Lemma empty_dec: + forall i, {empty i} + {~empty i}. +Proof. + unfold empty; intros. + case (zle (snd i) (fst i)); intros. + left; omega. + right; omega. +Qed. + +Lemma is_notempty: + forall i, fst i < snd i -> ~empty i. +Proof. + unfold empty; intros; omega. +Qed. + +Lemma empty_notin: + forall x i, empty i -> ~In x i. +Proof. + unfold empty, In; intros. omega. +Qed. + +Lemma in_notempty: + forall x i, In x i -> ~empty i. +Proof. + unfold empty, In; intros. omega. +Qed. + +(** * Disjointness *) + +Definition disjoint (i j: interv) : Prop := + forall x, In x i -> ~In x j. + +Lemma disjoint_sym: + forall i j, disjoint i j -> disjoint j i. +Proof. + unfold disjoint; intros; red; intros. elim (H x); auto. +Qed. + +Lemma empty_disjoint_r: + forall i j, empty j -> disjoint i j. +Proof. + unfold disjoint; intros. apply empty_notin; auto. +Qed. + +Lemma empty_disjoint_l: + forall i j, empty i -> disjoint i j. +Proof. + intros. apply disjoint_sym. apply empty_disjoint_r; auto. +Qed. + +Lemma disjoint_range: + forall i j, + snd i <= fst j \/ snd j <= fst i -> disjoint i j. +Proof. + unfold disjoint, In; intros. omega. +Qed. + +Lemma range_disjoint: + forall i j, + disjoint i j -> + empty i \/ empty j \/ snd i <= fst j \/ snd j <= fst i. +Proof. + unfold disjoint, empty; intros. + destruct (zlt (fst i) (snd i)); auto. + destruct (zlt (fst j) (snd j)); auto. + right; right. + destruct (zlt (fst i) (fst j)). +(* Case 1: i starts to the left of j. *) + destruct (zle (snd i) (fst j)). +(* Case 1.1: i ends to the left of j, OK *) + auto. +(* Case 1.2: i ends to the right of j's start, not disjoint. *) + elim (H (fst j)). red; omega. red; omega. +(* Case 2: j starts to the left of i *) + destruct (zle (snd j) (fst i)). +(* Case 2.1: j ends to the left of i, OK *) + auto. +(* Case 2.2: j ends to the right of i's start, not disjoint. *) + elim (H (fst i)). red; omega. red; omega. +Qed. + +Lemma range_disjoint': + forall i j, + disjoint i j -> fst i < snd i -> fst j < snd j -> + snd i <= fst j \/ snd j <= fst i. +Proof. + intros. exploit range_disjoint; eauto. unfold empty; intuition omega. +Qed. + +Lemma disjoint_dec: + forall i j, {disjoint i j} + {~disjoint i j}. +Proof. + intros. + destruct (empty_dec i). left; apply empty_disjoint_l; auto. + destruct (empty_dec j). left; apply empty_disjoint_r; auto. + destruct (zle (snd i) (fst j)). left; apply disjoint_range; auto. + destruct (zle (snd j) (fst i)). left; apply disjoint_range; auto. + right; red; intro. exploit range_disjoint; eauto. intuition. +Qed. + +(** * Shifting an interval by some amount *) + +Definition shift (i: interv) (delta: Z) : interv := (fst i + delta, snd i + delta). + +Lemma in_shift: + forall x i delta, + In x i -> In (x + delta) (shift i delta). +Proof. + unfold shift, In; intros. simpl. omega. +Qed. + +Lemma in_shift_inv: + forall x i delta, + In x (shift i delta) -> In (x - delta) i. +Proof. + unfold shift, In; simpl; intros. omega. +Qed. + +(** * Enumerating the elements of an interval *) + +Section ELEMENTS. + +Variable lo: Z. + +Function elements_rec (hi: Z) {wf (Zwf lo) hi} : list Z := + if zlt lo hi then (hi-1) :: elements_rec (hi-1) else nil. +Proof. + intros. red. omega. + apply Zwf_well_founded. +Qed. + +Lemma In_elements_rec: + forall hi x, + List.In x (elements_rec hi) <-> lo <= x < hi. +Proof. + intros. functional induction (elements_rec hi). + simpl; split; intros. + destruct H. clear IHl. omega. rewrite IHl in H. clear IHl. omega. + destruct (zeq (hi - 1) x); auto. right. rewrite IHl. clear IHl. omega. + simpl; intuition. +Qed. + +End ELEMENTS. + +Definition elements (i: interv) : list Z := + elements_rec (fst i) (snd i). + +Lemma in_elements: + forall x i, + In x i -> List.In x (elements i). +Proof. + intros. unfold elements. rewrite In_elements_rec. auto. +Qed. + +Lemma elements_in: + forall x i, + List.In x (elements i) -> In x i. +Proof. + unfold elements; intros. + rewrite In_elements_rec in H. auto. +Qed. + +(** * Checking properties on all elements of an interval *) + +Section FORALL. + +Variables P Q: Z -> Prop. +Variable f: forall (x: Z), {P x} + {Q x}. +Variable lo: Z. + +Program Fixpoint forall_rec (hi: Z) {wf (Zwf lo) hi}: + {forall x, lo <= x < hi -> P x} + + {exists x, lo <= x < hi /\ Q x} := + if zlt lo hi then + match f (hi - 1) with + | left _ => + match forall_rec (hi - 1) with + | left _ => left _ _ + | right _ => right _ _ + end + | right _ => right _ _ + end + else + left _ _ +. +Next Obligation. + red. omega. +Qed. +Next Obligation. + assert (x = hi - 1 \/ x < hi - 1) by omega. + destruct H2. congruence. auto. +Qed. +Next Obligation. + elim wildcard'0. intros y [A B]. exists y; split; auto. omega. +Qed. +Next Obligation. + exists (hi - 1); split; auto. omega. +Qed. +Next Obligation. + omegaContradiction. +Qed. +Next Obligation. + apply Zwf_well_founded. +Defined. + +End FORALL. + +Definition forall_dec + (P Q: Z -> Prop) (f: forall (x: Z), {P x} + {Q x}) (i: interv) : + {forall x, In x i -> P x} + {exists x, In x i /\ Q x} := + forall_rec P Q f (fst i) (snd i). + +(** * Folding a function over all elements of an interval *) + +Section FOLD. + +Variable A: Type. +Variable f: Z -> A -> A. +Variable lo: Z. +Variable a: A. + +Function fold_rec (hi: Z) {wf (Zwf lo) hi} : A := + if zlt lo hi then f (hi - 1) (fold_rec (hi - 1)) else a. +Proof. + intros. red. omega. + apply Zwf_well_founded. +Qed. + +Lemma fold_rec_elements: + forall hi, fold_rec hi = List.fold_right f a (elements_rec lo hi). +Proof. + intros. functional induction (fold_rec hi). + rewrite elements_rec_equation. rewrite zlt_true; auto. + simpl. congruence. + rewrite elements_rec_equation. rewrite zlt_false; auto. +Qed. + +End FOLD. + +Definition fold {A: Type} (f: Z -> A -> A) (a: A) (i: interv) : A := + fold_rec A f (fst i) a (snd i). + +Lemma fold_elements: + forall (A: Type) (f: Z -> A -> A) a i, + fold f a i = List.fold_right f a (elements i). +Proof. + intros. unfold fold, elements. apply fold_rec_elements. +Qed. + +(** Hints *) + +Hint Resolve + notin_range range_notin + is_notempty empty_notin in_notempty + disjoint_sym empty_disjoint_r empty_disjoint_l + disjoint_range + in_shift in_shift_inv + in_elements elements_in : intv. + + + + @@ -124,6 +124,17 @@ Module Type TREE. Hypothesis elements_keys_norepet: forall (A: Type) (m: t A), list_norepet (List.map (@fst elt A) (elements m)). + Hypothesis elements_canonical_order: + forall (A B: Type) (R: A -> B -> Prop) (m: t A) (n: t B), + (forall i x, get i m = Some x -> exists y, get i n = Some y /\ R x y) -> + (forall i y, get i n = Some y -> exists x, get i m = Some x /\ R x y) -> + list_forall2 + (fun i_x i_y => fst i_x = fst i_y /\ R (snd i_x) (snd i_y)) + (elements m) (elements n). + Hypothesis elements_extensional: + forall (A: Type) (m n: t A), + (forall i, get i m = get i n) -> + elements m = elements n. (** Folding a function over all bindings of a tree. *) Variable fold: @@ -901,6 +912,72 @@ Module PTree <: TREE. intros. change (list_norepet (xkeys m 1)). apply xelements_keys_norepet. Qed. + Theorem elements_canonical_order: + forall (A B: Type) (R: A -> B -> Prop) (m: t A) (n: t B), + (forall i x, get i m = Some x -> exists y, get i n = Some y /\ R x y) -> + (forall i y, get i n = Some y -> exists x, get i m = Some x /\ R x y) -> + list_forall2 + (fun i_x i_y => fst i_x = fst i_y /\ R (snd i_x) (snd i_y)) + (elements m) (elements n). + Proof. + intros until R. + assert (forall m n j, + (forall i x, get i m = Some x -> exists y, get i n = Some y /\ R x y) -> + (forall i y, get i n = Some y -> exists x, get i m = Some x /\ R x y) -> + list_forall2 + (fun i_x i_y => fst i_x = fst i_y /\ R (snd i_x) (snd i_y)) + (xelements m j) (xelements n j)). + induction m; induction n; intros; simpl. + constructor. + destruct o. exploit (H0 xH). simpl. reflexivity. simpl. intros [x [P Q]]. congruence. + change (@nil (positive*A)) with ((@nil (positive * A))++nil). + apply list_forall2_app. + apply IHn1. + intros. rewrite gleaf in H1. congruence. + intros. exploit (H0 (xO i)). simpl; eauto. rewrite gleaf. intros [x [P Q]]. congruence. + apply IHn2. + intros. rewrite gleaf in H1. congruence. + intros. exploit (H0 (xI i)). simpl; eauto. rewrite gleaf. intros [x [P Q]]. congruence. + destruct o. exploit (H xH). simpl. reflexivity. simpl. intros [x [P Q]]. congruence. + change (@nil (positive*B)) with (xelements (@Leaf B) (append j 2) ++ (xelements (@Leaf B) (append j 3))). + apply list_forall2_app. + apply IHm1. + intros. exploit (H (xO i)). simpl; eauto. rewrite gleaf. intros [y [P Q]]. congruence. + intros. rewrite gleaf in H1. congruence. + apply IHm2. + intros. exploit (H (xI i)). simpl; eauto. rewrite gleaf. intros [y [P Q]]. congruence. + intros. rewrite gleaf in H1. congruence. + exploit (IHm1 n1 (append j 2)). + intros. exploit (H (xO i)). simpl; eauto. simpl. auto. + intros. exploit (H0 (xO i)). simpl; eauto. simpl; auto. + intro REC1. + exploit (IHm2 n2 (append j 3)). + intros. exploit (H (xI i)). simpl; eauto. simpl. auto. + intros. exploit (H0 (xI i)). simpl; eauto. simpl; auto. + intro REC2. + destruct o; destruct o0. + apply list_forall2_app; auto. constructor; auto. + simpl; split; auto. exploit (H xH). simpl; eauto. simpl. intros [y [P Q]]. congruence. + exploit (H xH). simpl; eauto. simpl. intros [y [P Q]]; congruence. + exploit (H0 xH). simpl; eauto. simpl. intros [x [P Q]]; congruence. + apply list_forall2_app; auto. + + unfold elements; auto. + Qed. + + Theorem elements_extensional: + forall (A: Type) (m n: t A), + (forall i, get i m = get i n) -> + elements m = elements n. + Proof. + intros. + exploit (elements_canonical_order (fun (x y: A) => x = y) m n). + intros. rewrite H in H0. exists x; auto. + intros. rewrite <- H in H0. exists y; auto. + induction 1. auto. destruct a1 as [a2 a3]; destruct b1 as [b2 b3]; simpl in *. + destruct H0. congruence. + Qed. + (* Definition fold (A B : Type) (f: B -> positive -> A -> B) (tr: t A) (v: B) := List.fold_left (fun a p => f a (fst p) (snd p)) (elements tr) v. diff --git a/powerpc/Asm.v b/powerpc/Asm.v index 60c3d34..fe6cf86 100644 --- a/powerpc/Asm.v +++ b/powerpc/Asm.v @@ -18,7 +18,7 @@ Require Import AST. Require Import Integers. Require Import Floats. Require Import Values. -Require Import Mem. +Require Import Memory. Require Import Events. Require Import Globalenvs. Require Import Smallstep. @@ -126,7 +126,7 @@ Inductive instruction : Type := | Peqv: ireg -> ireg -> ireg -> instruction (**r bitwise not-xor *) | Pextsb: ireg -> ireg -> instruction (**r 8-bit sign extension *) | Pextsh: ireg -> ireg -> instruction (**r 16-bit sign extension *) - | Pfreeframe: int -> instruction (**r deallocate stack frame and restore previous frame *) + | Pfreeframe: Z -> Z -> int -> instruction (**r deallocate stack frame and restore previous frame *) | Pfabs: freg -> freg -> instruction (**r float absolute value *) | Pfadd: freg -> freg -> freg -> instruction (**r float addition *) | Pfcmpu: freg -> freg -> instruction (**r float comparison *) @@ -285,7 +285,7 @@ lbl: .long 0x43300000, 0x00000000 This cannot be expressed in our memory model, which does not reflect the fact that stack frames are adjacent and allocated/freed following a stack discipline. -- [Pfreeframe ofs]: in the formal semantics, this pseudo-instruction +- [Pfreeframe lo hi ofs]: in the formal semantics, this pseudo-instruction reads the word at offset [ofs] in the block pointed by [r1] (the stack pointer), frees this block, and sets [r1] to the value of the word at offset [ofs]. In the printed PowerPC assembly code, this @@ -349,7 +349,7 @@ Module Pregmap := EMap(PregEq). [Vzero] or [Vone]. *) Definition regset := Pregmap.t val. -Definition genv := Genv.t fundef. +Definition genv := Genv.t fundef unit. Notation "a # b" := (a b) (at level 1, only parsing). Notation "a # b <- c" := (Pregmap.set b c a) (at level 1, b at next level). @@ -651,12 +651,16 @@ Definition exec_instr (c: code) (i: instruction) (rs: regset) (m: mem) : outcome OK (nextinstr (rs#rd <- (Val.sign_ext 8 rs#r1))) m | Pextsh rd r1 => OK (nextinstr (rs#rd <- (Val.sign_ext 16 rs#r1))) m - | Pfreeframe ofs => + | Pfreeframe lo hi ofs => match Mem.loadv Mint32 m (Val.add rs#GPR1 (Vint ofs)) with | None => Error | Some v => match rs#GPR1 with - | Vptr stk ofs => OK (nextinstr (rs#GPR1 <- v)) (Mem.free m stk) + | Vptr stk ofs => + match Mem.free m stk lo hi with + | None => Error + | Some m' => OK (nextinstr (rs#GPR1 <- v)) m' + end | _ => Error end end @@ -874,23 +878,23 @@ Inductive step: state -> trace -> state -> Prop := exec_instr c i rs m = OK rs' m' -> step (State rs m) E0 (State rs' m') | exec_step_external: - forall b ef args res rs m t rs', + forall b ef args res rs m t rs' m', rs PC = Vptr b Int.zero -> Genv.find_funct_ptr ge b = Some (External ef) -> - event_match ef args t res -> + external_call ef args m t res m' -> extcall_arguments rs m ef.(ef_sig) args -> rs' = (rs#(loc_external_result ef.(ef_sig)) <- res #PC <- (rs LR)) -> - step (State rs m) t (State rs' m). + step (State rs m) t (State rs' m'). End RELSEM. (** Execution of whole programs. *) Inductive initial_state (p: program): state -> Prop := - | initial_state_intro: + | initial_state_intro: forall m0, + Genv.init_mem p = Some m0 -> let ge := Genv.globalenv p in - let m0 := Genv.init_mem p in let rs0 := (Pregmap.init Vundef) # PC <- (symbol_offset ge p.(prog_main) Int.zero) diff --git a/powerpc/Asmgen.v b/powerpc/Asmgen.v index 2c65ca4..ca42d56 100644 --- a/powerpc/Asmgen.v +++ b/powerpc/Asmgen.v @@ -19,7 +19,7 @@ Require Import AST. Require Import Integers. Require Import Floats. Require Import Values. -Require Import Mem. +Require Import Memory. Require Import Globalenvs. Require Import Op. Require Import Locations. @@ -487,12 +487,12 @@ Definition transl_instr (f: Mach.function) (i: Mach.instruction) (k: code) := Pmtctr (ireg_of r) :: Plwz GPR12 (Cint f.(fn_retaddr_ofs)) GPR1 :: Pmtlr GPR12 :: - Pfreeframe f.(fn_link_ofs) :: + Pfreeframe (-f .(fn_framesize)) f.(fn_stacksize) f.(fn_link_ofs) :: Pbctr :: k | Mtailcall sig (inr symb) => Plwz GPR12 (Cint f.(fn_retaddr_ofs)) GPR1 :: Pmtlr GPR12 :: - Pfreeframe f.(fn_link_ofs) :: + Pfreeframe (-f .(fn_framesize)) f.(fn_stacksize) f.(fn_link_ofs) :: Pbs symb :: k | Mlabel lbl => Plabel lbl :: k @@ -508,7 +508,7 @@ Definition transl_instr (f: Mach.function) (i: Mach.instruction) (k: code) := | Mreturn => Plwz GPR12 (Cint f.(fn_retaddr_ofs)) GPR1 :: Pmtlr GPR12 :: - Pfreeframe f.(fn_link_ofs) :: + Pfreeframe (-f .(fn_framesize)) f.(fn_stacksize) f.(fn_link_ofs) :: Pblr :: k end. diff --git a/powerpc/Asmgenproof.v b/powerpc/Asmgenproof.v index a2fc610..5be4734 100644 --- a/powerpc/Asmgenproof.v +++ b/powerpc/Asmgenproof.v @@ -19,7 +19,7 @@ Require Import AST. Require Import Integers. Require Import Floats. Require Import Values. -Require Import Mem. +Require Import Memory. Require Import Events. Require Import Globalenvs. Require Import Smallstep. @@ -55,7 +55,7 @@ Lemma functions_translated: Genv.find_funct_ptr ge b = Some f -> exists tf, Genv.find_funct_ptr tge b = Some tf /\ transf_fundef f = Errors.OK tf. Proof - (Genv.find_funct_ptr_transf_partial transf_fundef TRANSF). + (Genv.find_funct_ptr_transf_partial transf_fundef _ TRANSF). Lemma functions_transl: forall f b, @@ -776,13 +776,25 @@ Proof. rewrite <- H. apply eval_operation_preserved. exact symbols_preserved. Qed. +Remark loadv_8_signed_unsigned: + forall m a v, + Mem.loadv Mint8signed m a = Some v -> + exists v', Mem.loadv Mint8unsigned m a = Some v' /\ v = Val.sign_ext 8 v'. +Proof. + unfold Mem.loadv; intros. destruct a; try congruence. + generalize (Mem.load_int8_signed_unsigned m b (Int.signed i)). + rewrite H. destruct (Mem.load Mint8unsigned m b (Int.signed i)). + simpl; intros. exists v0; split; congruence. + simpl; congruence. +Qed. + Lemma exec_Mload_prop: forall (s : list stackframe) (fb : block) (sp : val) (chunk : memory_chunk) (addr : addressing) (args : list mreg) (dst : mreg) (c : list Mach.instruction) (ms : mreg -> val) (m : mem) (a v : val), eval_addressing ge sp addr ms ## args = Some a -> - loadv chunk m a = Some v -> + Mem.loadv chunk m a = Some v -> exec_instr_prop (Machconcr.State s fb sp (Mload chunk addr args dst :: c) ms m) E0 (Machconcr.State s fb sp c (Regmap.set dst v ms) m). Proof. @@ -797,11 +809,7 @@ Proof. try (eapply transl_load_correct; eauto; intros; simpl; unfold preg_of; rewrite H6; auto). (* Mint8signed *) - generalize (loadv_8_signed_unsigned m a). - rewrite H0. - caseEq (loadv Mint8unsigned m a); - [idtac | simpl;intros;discriminate]. - intros v' LOAD' EQ. simpl in EQ. injection EQ. intro EQ1. clear EQ. + exploit loadv_8_signed_unsigned; eauto. intros [v' [LOAD EQ]]. assert (X1: forall (cst : constant) (r1 : ireg) (rs1 : regset), exec_instr tge (transl_function f) (Plbz (ireg_of dst) cst r1) rs1 m = load1 tge Mint8unsigned (preg_of dst) cst r1 rs1 m). @@ -815,30 +823,46 @@ Proof. Mint8unsigned addr args (Pextsb (ireg_of dst) (ireg_of dst) :: transl_code f c) ms sp rs m dst a v' - X1 X2 AG H3 H7 LOAD'). + X1 X2 AG H3 H7 LOAD). intros [rs2 [EX1 AG1]]. exists (nextinstr (rs2#(ireg_of dst) <- v)). split. eapply exec_straight_trans. eexact EX1. apply exec_straight_one. simpl. rewrite <- (ireg_val _ _ _ dst AG1);auto. rewrite Regmap.gss. - rewrite EQ1. reflexivity. reflexivity. + rewrite EQ. reflexivity. reflexivity. eauto with ppcgen. Qed. +Lemma storev_8_signed_unsigned: + forall m a v, + Mem.storev Mint8signed m a v = Mem.storev Mint8unsigned m a v. +Proof. + intros. unfold Mem.storev. destruct a; auto. + apply Mem.store_signed_unsigned_8. +Qed. + +Lemma storev_16_signed_unsigned: + forall m a v, + Mem.storev Mint16signed m a v = Mem.storev Mint16unsigned m a v. +Proof. + intros. unfold Mem.storev. destruct a; auto. + apply Mem.store_signed_unsigned_16. +Qed. + Lemma exec_Mstore_prop: forall (s : list stackframe) (fb : block) (sp : val) (chunk : memory_chunk) (addr : addressing) (args : list mreg) (src : mreg) (c : list Mach.instruction) (ms : mreg -> val) (m m' : mem) (a : val), eval_addressing ge sp addr ms ## args = Some a -> - storev chunk m a (ms src) = Some m' -> + Mem.storev chunk m a (ms src) = Some m' -> exec_instr_prop (Machconcr.State s fb sp (Mstore chunk addr args src :: c) ms m) E0 (Machconcr.State s fb sp c ms m'). Proof. intros; red; intros; inv MS. generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). intro WTI; inversion WTI. - rewrite <- (eval_addressing_preserved symbols_preserved) in H. + rewrite <- (eval_addressing_preserved _ _ symbols_preserved) in H. left; eapply exec_straight_steps; eauto with coqlib. destruct chunk; simpl; simpl in H6; try (rewrite storev_8_signed_unsigned in H0); @@ -928,14 +952,15 @@ Qed. Lemma exec_Mtailcall_prop: forall (s : list stackframe) (fb stk : block) (soff : int) (sig : signature) (ros : mreg + ident) (c : list Mach.instruction) - (ms : Mach.regset) (m : mem) (f: Mach.function) (f' : block), + (ms : Mach.regset) (m : mem) (f: Mach.function) (f' : block) m', find_function_ptr ge ros ms = Some f' -> Genv.find_funct_ptr ge fb = Some (Internal f) -> load_stack m (Vptr stk soff) Tint f.(fn_link_ofs) = Some (parent_sp s) -> load_stack m (Vptr stk soff) Tint f.(fn_retaddr_ofs) = Some (parent_ra s) -> + Mem.free m stk (- f.(fn_framesize)) f.(fn_stacksize) = Some m' -> exec_instr_prop (Machconcr.State s fb (Vptr stk soff) (Mtailcall sig ros :: c) ms m) E0 - (Callstate s f' ms (free m stk)). + (Callstate s f' ms m'). Proof. intros; red; intros; inv MS. assert (f0 = f) by congruence. subst f0. @@ -953,9 +978,9 @@ Proof. set (rs6 := rs5#PC <- (rs5 CTR)). assert (exec_straight tge (transl_function f) (transl_code f (Mtailcall sig (inl ident m0) :: c)) rs m - (Pbctr :: transl_code f c) rs5 (free m stk)). + (Pbctr :: transl_code f c) rs5 m'). simpl. apply exec_straight_step with rs2 m. - simpl. rewrite <- (ireg_val _ _ _ _ AG H6). reflexivity. reflexivity. + simpl. rewrite <- (ireg_val _ _ _ _ AG H7). reflexivity. reflexivity. apply exec_straight_step with rs3 m. simpl. unfold load1. rewrite gpr_or_zero_not_zero. unfold const_low. change (rs2 GPR1) with (rs GPR1). rewrite <- (sp_val _ _ _ AG). @@ -966,13 +991,13 @@ Proof. apply exec_straight_one. simpl. change (rs4 GPR1) with (rs GPR1). rewrite <- (sp_val _ _ _ AG). unfold load_stack in H1; simpl in H1. - simpl. rewrite H1. reflexivity. reflexivity. - left; exists (State rs6 (free m stk)); split. + simpl. rewrite H1. rewrite H3. reflexivity. reflexivity. + left; exists (State rs6 m'); split. (* execution *) eapply plus_right'. eapply exec_straight_exec; eauto. econstructor. change (rs5 PC) with (Val.add (Val.add (Val.add (Val.add (rs PC) Vone) Vone) Vone) Vone). - rewrite <- H7; simpl. eauto. + rewrite <- H8; simpl. eauto. eapply functions_transl; eauto. eapply find_instr_tail. repeat (eapply code_tail_next_int; auto). eauto. @@ -983,7 +1008,7 @@ Proof. unfold rs4, rs3, rs2; auto 10 with ppcgen. assert (AG5: agree ms (parent_sp s) rs5). unfold rs5. apply agree_nextinstr. - split. reflexivity. intros. inv AG4. rewrite H12. + split. reflexivity. intros. inv AG4. rewrite H13. rewrite Pregmap.gso; auto with ppcgen. unfold rs6; auto with ppcgen. change (rs6 PC) with (ms m0). @@ -996,7 +1021,7 @@ Proof. set (rs5 := rs4#PC <- (Vptr f' Int.zero)). assert (exec_straight tge (transl_function f) (transl_code f (Mtailcall sig (inr mreg i) :: c)) rs m - (Pbs i :: transl_code f c) rs4 (free m stk)). + (Pbs i :: transl_code f c) rs4 m'). simpl. apply exec_straight_step with rs2 m. simpl. unfold load1. rewrite gpr_or_zero_not_zero. unfold const_low. rewrite <- (sp_val _ _ _ AG). @@ -1007,13 +1032,13 @@ Proof. apply exec_straight_one. simpl. change (rs3 GPR1) with (rs GPR1). rewrite <- (sp_val _ _ _ AG). unfold load_stack in H1; simpl in H1. - simpl. rewrite H1. reflexivity. reflexivity. - left; exists (State rs5 (free m stk)); split. + simpl. rewrite H1. rewrite H3. reflexivity. reflexivity. + left; exists (State rs5 m'); split. (* execution *) eapply plus_right'. eapply exec_straight_exec; eauto. econstructor. change (rs4 PC) with (Val.add (Val.add (Val.add (rs PC) Vone) Vone) Vone). - rewrite <- H7; simpl. eauto. + rewrite <- H8; simpl. eauto. eapply functions_transl; eauto. eapply find_instr_tail. repeat (eapply code_tail_next_int; auto). eauto. @@ -1025,7 +1050,7 @@ Proof. unfold rs3, rs2; auto 10 with ppcgen. assert (AG4: agree ms (parent_sp s) rs4). unfold rs4. apply agree_nextinstr. - split. reflexivity. intros. inv AG3. rewrite H12. + split. reflexivity. intros. inv AG3. rewrite H13. rewrite Pregmap.gso; auto with ppcgen. unfold rs5; auto with ppcgen. Qed. @@ -1191,12 +1216,13 @@ Qed. Lemma exec_Mreturn_prop: forall (s : list stackframe) (fb stk : block) (soff : int) - (c : list Mach.instruction) (ms : Mach.regset) (m : mem) (f: Mach.function), + (c : list Mach.instruction) (ms : Mach.regset) (m : mem) (f: Mach.function) m', Genv.find_funct_ptr ge fb = Some (Internal f) -> load_stack m (Vptr stk soff) Tint f.(fn_link_ofs) = Some (parent_sp s) -> load_stack m (Vptr stk soff) Tint f.(fn_retaddr_ofs) = Some (parent_ra s) -> + Mem.free m stk (- f.(fn_framesize)) f.(fn_stacksize) = Some m' -> exec_instr_prop (Machconcr.State s fb (Vptr stk soff) (Mreturn :: c) ms m) E0 - (Returnstate s ms (free m stk)). + (Returnstate s ms m'). Proof. intros; red; intros; inv MS. assert (f0 = f) by congruence. subst f0. @@ -1206,7 +1232,7 @@ Proof. set (rs5 := rs4#PC <- (parent_ra s)). assert (exec_straight tge (transl_function f) (transl_code f (Mreturn :: c)) rs m - (Pblr :: transl_code f c) rs4 (free m stk)). + (Pblr :: transl_code f c) rs4 m'). simpl. apply exec_straight_three with rs2 m rs3 m. simpl. unfold load1. rewrite gpr_or_zero_not_zero. unfold const_low. unfold load_stack in H1. simpl in H1. @@ -1216,18 +1242,18 @@ Proof. simpl. change (rs3 GPR1) with (rs GPR1). rewrite <- (sp_val _ _ _ AG). simpl. unfold load_stack in H0. simpl in H0. - rewrite H0. reflexivity. + rewrite H0. rewrite H2. reflexivity. reflexivity. reflexivity. reflexivity. - left; exists (State rs5 (free m stk)); split. + left; exists (State rs5 m'); split. (* execution *) - apply plus_right' with E0 (State rs4 (free m stk)) E0. + apply plus_right' with E0 (State rs4 m') E0. eapply exec_straight_exec; eauto. inv AT. econstructor. change (rs4 PC) with (Val.add (Val.add (Val.add (rs PC) Vone) Vone) Vone). - rewrite <- H3. simpl. eauto. + rewrite <- H4. simpl. eauto. apply functions_transl; eauto. - generalize (functions_transl_no_overflow _ _ H4); intro NOOV. - simpl in H5. eapply find_instr_tail. + generalize (functions_transl_no_overflow _ _ H5); intro NOOV. + simpl in H6. eapply find_instr_tail. eapply code_tail_next_int; auto. eapply code_tail_next_int; auto. eapply code_tail_next_int; eauto. @@ -1249,7 +1275,7 @@ Lemma exec_function_internal_prop: forall (s : list stackframe) (fb : block) (ms : Mach.regset) (m : mem) (f : function) (m1 m2 m3 : mem) (stk : block), Genv.find_funct_ptr ge fb = Some (Internal f) -> - alloc m (- fn_framesize f) (fn_stacksize f) = (m1, stk) -> + Mem.alloc m (- fn_framesize f) (fn_stacksize f) = (m1, stk) -> let sp := Vptr stk (Int.repr (- fn_framesize f)) in store_stack m1 sp Tint f.(fn_link_ofs) (parent_sp s) = Some m2 -> store_stack m2 sp Tint f.(fn_retaddr_ofs) (parent_ra s) = Some m3 -> @@ -1258,7 +1284,7 @@ Lemma exec_function_internal_prop: Proof. intros; red; intros; inv MS. assert (WTF: wt_function f). - generalize (Genv.find_funct_ptr_prop wt_fundef wt_prog H); intro TY. + generalize (Genv.find_funct_ptr_prop wt_fundef _ _ wt_prog H); intro TY. inversion TY; auto. exploit functions_transl; eauto. intro TFIND. generalize (functions_transl_no_overflow _ _ H); intro NOOV. @@ -1307,19 +1333,19 @@ Qed. Lemma exec_function_external_prop: forall (s : list stackframe) (fb : block) (ms : Mach.regset) (m : mem) (t0 : trace) (ms' : RegEq.t -> val) - (ef : external_function) (args : list val) (res : val), + (ef : external_function) (args : list val) (res : val) (m': mem), Genv.find_funct_ptr ge fb = Some (External ef) -> - event_match ef args t0 res -> + external_call ef args m t0 res m' -> Machconcr.extcall_arguments ms m (parent_sp s) (ef_sig ef) args -> ms' = Regmap.set (Conventions.loc_result (ef_sig ef)) res ms -> exec_instr_prop (Machconcr.Callstate s fb ms m) - t0 (Machconcr.Returnstate s ms' m). + t0 (Machconcr.Returnstate s ms' m'). Proof. intros; red; intros; inv MS. exploit functions_translated; eauto. intros [tf [A B]]. simpl in B. inv B. left; exists (State (rs#(loc_external_result (ef_sig ef)) <- res #PC <- (rs LR)) - m); split. + m'); split. apply plus_one. eapply exec_step_external; eauto. eapply extcall_arguments_match; eauto. econstructor; eauto. @@ -1367,14 +1393,14 @@ Proof. intros. inversion H. unfold ge0 in *. econstructor; split. econstructor. + eapply Genv.init_mem_transf_partial; eauto. replace (symbol_offset (Genv.globalenv tprog) (prog_main tprog) Int.zero) with (Vptr fb Int.zero). - rewrite (Genv.init_mem_transf_partial _ _ TRANSF). econstructor; eauto. constructor. split. auto. intros. repeat rewrite Pregmap.gso; auto with ppcgen. unfold symbol_offset. rewrite (transform_partial_program_main _ _ TRANSF). - rewrite symbols_preserved. unfold ge; rewrite H0. auto. + rewrite symbols_preserved. unfold ge; rewrite H1. auto. Qed. Lemma transf_final_states: diff --git a/powerpc/Asmgenproof1.v b/powerpc/Asmgenproof1.v index 7329e53..60c4969 100644 --- a/powerpc/Asmgenproof1.v +++ b/powerpc/Asmgenproof1.v @@ -18,7 +18,7 @@ Require Import AST. Require Import Integers. Require Import Floats. Require Import Values. -Require Import Mem. +Require Import Memory. Require Import Globalenvs. Require Import Op. Require Import Locations. diff --git a/powerpc/Asmgenretaddr.v b/powerpc/Asmgenretaddr.v index d414752..d55635b 100644 --- a/powerpc/Asmgenretaddr.v +++ b/powerpc/Asmgenretaddr.v @@ -22,7 +22,7 @@ Require Import AST. Require Import Integers. Require Import Floats. Require Import Values. -Require Import Mem. +Require Import Memory. Require Import Globalenvs. Require Import Op. Require Import Locations. diff --git a/powerpc/ConstpropOpproof.v b/powerpc/ConstpropOpproof.v index 2e28d23..b5e2e8e 100644 --- a/powerpc/ConstpropOpproof.v +++ b/powerpc/ConstpropOpproof.v @@ -17,7 +17,7 @@ Require Import AST. Require Import Integers. Require Import Floats. Require Import Values. -Require Import Mem. +Require Import Memory. Require Import Globalenvs. Require Import Op. Require Import Registers. diff --git a/powerpc/Op.v b/powerpc/Op.v index c6e196f..7a9aa50 100644 --- a/powerpc/Op.v +++ b/powerpc/Op.v @@ -29,7 +29,8 @@ Require Import AST. Require Import Integers. Require Import Floats. Require Import Values. -Require Import Mem. +Require Import Memdata. +Require Import Memory. Require Import Globalenvs. Set Implicit Arguments. @@ -182,7 +183,7 @@ Definition offset_sp (sp: val) (delta: int) : option val := end. Definition eval_operation - (F: Type) (genv: Genv.t F) (sp: val) + (F V: Type) (genv: Genv.t F V) (sp: val) (op: operation) (vl: list val): option val := match op, vl with | Omove, v1::nil => Some v1 @@ -265,7 +266,7 @@ Definition eval_operation end. Definition eval_addressing - (F: Type) (genv: Genv.t F) (sp: val) + (F V: Type) (genv: Genv.t F V) (sp: val) (addr: addressing) (vl: list val) : option val := match addr, vl with | Aindexed n, Vptr b1 n1 :: nil => @@ -360,9 +361,9 @@ Qed. Section GENV_TRANSF. -Variable F1 F2: Type. -Variable ge1: Genv.t F1. -Variable ge2: Genv.t F2. +Variable F1 F2 V1 V2: Type. +Variable ge1: Genv.t F1 V1. +Variable ge2: Genv.t F2 V2. Hypothesis agree_on_symbols: forall (s: ident), Genv.find_symbol ge2 s = Genv.find_symbol ge1 s. @@ -480,25 +481,14 @@ Definition type_of_addressing (addr: addressing) : list typ := | Ainstack _ => nil end. -Definition type_of_chunk (c: memory_chunk) : typ := - match c with - | Mint8signed => Tint - | Mint8unsigned => Tint - | Mint16signed => Tint - | Mint16unsigned => Tint - | Mint32 => Tint - | Mfloat32 => Tfloat - | Mfloat64 => Tfloat - end. - (** Weak type soundness results for [eval_operation]: the result values, when defined, are always of the type predicted by [type_of_operation]. *) Section SOUNDNESS. -Variable A: Type. -Variable genv: Genv.t A. +Variable A V: Type. +Variable genv: Genv.t A V. Lemma type_of_operation_sound: forall op vl sp v, @@ -548,8 +538,7 @@ Proof. destruct v; destruct chunk; exact I. intros until v. unfold Mem.loadv. destruct addr; intros; try discriminate. - generalize (Mem.load_inv _ _ _ _ _ H0). - intros [X Y]. subst v. apply H. + eapply Mem.load_type; eauto. Qed. End SOUNDNESS. @@ -560,8 +549,8 @@ End SOUNDNESS. Section EVAL_OP_TOTAL. -Variable F: Type. -Variable genv: Genv.t F. +Variable F V: Type. +Variable genv: Genv.t F V. Definition find_symbol_offset (id: ident) (ofs: int) : val := match Genv.find_symbol genv id with @@ -746,8 +735,8 @@ End EVAL_OP_TOTAL. Section EVAL_LESSDEF. -Variable F: Type. -Variable genv: Genv.t F. +Variable F V: Type. +Variable genv: Genv.t F V. Ltac InvLessdef := match goal with @@ -834,7 +823,7 @@ End EVAL_LESSDEF. Definition op_for_binary_addressing (addr: addressing) : operation := Oadd. Lemma eval_op_for_binary_addressing: - forall (F: Type) (ge: Genv.t F) sp addr args v, + forall (F V: Type) (ge: Genv.t F V) sp addr args v, (length args >= 2)%nat -> eval_addressing ge sp addr args = Some v -> eval_operation ge sp (op_for_binary_addressing addr) args = Some v. diff --git a/powerpc/PrintAsm.ml b/powerpc/PrintAsm.ml index 10170f9..a1e5afe 100644 --- a/powerpc/PrintAsm.ml +++ b/powerpc/PrintAsm.ml @@ -288,7 +288,8 @@ let print_instruction oc labels = function fprintf oc " extsb %a, %a\n" ireg r1 ireg r2 | Pextsh(r1, r2) -> fprintf oc " extsh %a, %a\n" ireg r1 ireg r2 - | Pfreeframe ofs -> + | Pfreeframe(lo, hi, ofs) -> + (* Note: could also do an add on GPR1 using lo and hi *) fprintf oc " lwz %a, %ld(%a)\n" ireg GPR1 (camlint_of_coqint ofs) ireg GPR1 | Pfabs(r1, r2) -> fprintf oc " fabs %a, %a\n" freg r1 freg r2 diff --git a/powerpc/SelectOp.v b/powerpc/SelectOp.v index 2f4d76e..d03645e 100644 --- a/powerpc/SelectOp.v +++ b/powerpc/SelectOp.v @@ -42,7 +42,7 @@ Require Import AST. Require Import Integers. Require Import Floats. Require Import Values. -Require Import Mem. +Require Import Memory. Require Import Globalenvs. Require Cminor. Require Import Op. diff --git a/powerpc/SelectOpproof.v b/powerpc/SelectOpproof.v index 2736e9e..d4a45da 100644 --- a/powerpc/SelectOpproof.v +++ b/powerpc/SelectOpproof.v @@ -18,7 +18,7 @@ Require Import AST. Require Import Integers. Require Import Floats. Require Import Values. -Require Import Mem. +Require Import Memory. Require Import Events. Require Import Globalenvs. Require Import Smallstep. @@ -657,25 +657,18 @@ Qed. Lemma loadv_cast: forall chunk addr v, - loadv chunk m addr = Some v -> + Mem.loadv chunk m addr = Some v -> match chunk with - | Mint8signed => loadv chunk m addr = Some(Val.sign_ext 8 v) - | Mint8unsigned => loadv chunk m addr = Some(Val.zero_ext 8 v) - | Mint16signed => loadv chunk m addr = Some(Val.sign_ext 16 v) - | Mint16unsigned => loadv chunk m addr = Some(Val.zero_ext 16 v) - | Mfloat32 => loadv chunk m addr = Some(Val.singleoffloat v) + | Mint8signed => v = Val.sign_ext 8 v + | Mint8unsigned => v = Val.zero_ext 8 v + | Mint16signed => v = Val.sign_ext 16 v + | Mint16unsigned => v = Val.zero_ext 16 v + | Mfloat32 => v = Val.singleoffloat v | _ => True end. Proof. - intros. rewrite H. destruct addr; simpl in H; try discriminate. - exploit Mem.load_inv; eauto. - set (v' := (getN (pred_size_chunk chunk) (Int.signed i) (contents (blocks m b)))). - intros [A B]. subst v. destruct chunk; auto; destruct v'; simpl; auto. - rewrite Int.sign_ext_idem; auto. compute; auto. - rewrite Int.zero_ext_idem; auto. compute; auto. - rewrite Int.sign_ext_idem; auto. compute; auto. - rewrite Int.zero_ext_idem; auto. compute; auto. - rewrite Float.singleoffloat_idem; auto. + intros. destruct addr; simpl in H; try discriminate. + eapply Mem.load_cast. eauto. Qed. Theorem eval_cast8signed: @@ -686,7 +679,7 @@ Proof. intros until v; unfold cast8signed; case (cast8signed_match a); intros; InvEval. EvalOp. simpl. subst v. destruct v1; simpl; auto. rewrite Int.sign_ext_idem. reflexivity. compute; auto. - inv H. econstructor; eauto. apply (loadv_cast _ _ _ H7). + inv H. econstructor; eauto. rewrite H7. decEq. apply (loadv_cast _ _ _ H7). EvalOp. Qed. @@ -698,7 +691,7 @@ Proof. intros until v; unfold cast8unsigned; case (cast8unsigned_match a); intros; InvEval. EvalOp. simpl. subst v. destruct v1; simpl; auto. rewrite Int.zero_ext_idem. reflexivity. compute; auto. - inv H. econstructor; eauto. apply (loadv_cast _ _ _ H7). + inv H. econstructor; eauto. rewrite H7. decEq. apply (loadv_cast _ _ _ H7). EvalOp. Qed. @@ -710,7 +703,7 @@ Proof. intros until v; unfold cast16signed; case (cast16signed_match a); intros; InvEval. EvalOp. simpl. subst v. destruct v1; simpl; auto. rewrite Int.sign_ext_idem. reflexivity. compute; auto. - inv H. econstructor; eauto. apply (loadv_cast _ _ _ H7). + inv H. econstructor; eauto. rewrite H7. decEq. apply (loadv_cast _ _ _ H7). EvalOp. Qed. @@ -722,7 +715,7 @@ Proof. intros until v; unfold cast16unsigned; case (cast16unsigned_match a); intros; InvEval. EvalOp. simpl. subst v. destruct v1; simpl; auto. rewrite Int.zero_ext_idem. reflexivity. compute; auto. - inv H. econstructor; eauto. apply (loadv_cast _ _ _ H7). + inv H. econstructor; eauto. rewrite H7. decEq. apply (loadv_cast _ _ _ H7). EvalOp. Qed. @@ -733,7 +726,7 @@ Theorem eval_singleoffloat: Proof. intros until v; unfold singleoffloat; case (singleoffloat_match a); intros; InvEval. EvalOp. simpl. subst v. destruct v1; simpl; auto. rewrite Float.singleoffloat_idem. reflexivity. - inv H. econstructor; eauto. apply (loadv_cast _ _ _ H7). + inv H. econstructor; eauto. rewrite H7. decEq. apply (loadv_cast _ _ _ H7). EvalOp. Qed. diff --git a/runtime/stdio.h b/runtime/stdio.h index de573a3..9aa3ae1 100644 --- a/runtime/stdio.h +++ b/runtime/stdio.h @@ -58,22 +58,39 @@ extern int compcert_ungetc(int, compcert_FILE *); #define stdout compcert_stdout #undef stderr #define stderr compcert_stderr +#undef clearerr #define clearerr compcert_clearerr +#undef fclose #define fclose compcert_fclose +#undef feof #define feof compcert_feof +#undef ferror #define ferror compcert_ferror +#undef fflush #define fflush compcert_fflush +#undef fgetc #define fgetc compcert_fgetc +#undef fgets #define fgets compcert_fgets +#undef fopen #define fopen compcert_fopen +#undef fprintf #define fprintf compcert_fprintf +#undef fputc #define fputc compcert_fputc +#undef fputs #define fputs compcert_fputs +#undef fread #define fread compcert_fread +#undef freopen #define freopen compcert_freopen +#undef fscanf #define fscanf compcert_fscanf +#undef fseek #define fseek compcert_fseek +#undef ftell #define ftell compcert_ftell +#undef fwrite #define fwrite compcert_fwrite #undef getc #define getc compcert_getc @@ -83,7 +100,9 @@ extern int compcert_ungetc(int, compcert_FILE *); #define putc compcert_putc #undef putchar #define putchar(c) compcert_putc(c, compcert_stdout) +#undef rewind #define rewind compcert_rewind +#undef ungetc #define ungetc compcert_ungetc #endif |