diff options
73 files changed, 5836 insertions, 5026 deletions
@@ -17,9 +17,10 @@ lib/Postorder.vo lib/Postorder.glob lib/Postorder.v.beautified: lib/Postorder.v lib/FSetAVLplus.vo lib/FSetAVLplus.glob lib/FSetAVLplus.v.beautified: lib/FSetAVLplus.v lib/Coqlib.vo lib/IntvSets.vo lib/IntvSets.glob lib/IntvSets.v.beautified: lib/IntvSets.v lib/Coqlib.vo common/Errors.vo common/Errors.glob common/Errors.v.beautified: common/Errors.v lib/Coqlib.vo -common/AST.vo common/AST.glob common/AST.v.beautified: common/AST.v lib/Coqlib.vo common/Errors.vo lib/Integers.vo lib/Floats.vo +common/AST.vo common/AST.glob common/AST.v.beautified: common/AST.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo lib/Integers.vo lib/Floats.vo +common/Linking.vo common/Linking.glob common/Linking.v.beautified: common/Linking.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo common/AST.vo common/Events.vo common/Events.glob common/Events.v.beautified: 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.vo common/Globalenvs.glob common/Globalenvs.v.beautified: 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/Globalenvs.vo common/Globalenvs.glob common/Globalenvs.v.beautified: common/Globalenvs.v lib/Axioms.vo lib/Coqlib.vo common/Errors.vo lib/Maps.vo common/AST.vo common/Linking.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Memdata.vo common/Memdata.glob common/Memdata.v.beautified: common/Memdata.v lib/Coqlib.vo $(ARCH)/Archi.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memtype.vo common/Memtype.glob common/Memtype.v.beautified: common/Memtype.v lib/Coqlib.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memdata.vo common/Memory.vo common/Memory.glob common/Memory.v.beautified: common/Memory.v lib/Axioms.vo lib/Coqlib.vo lib/Intv.vo lib/Maps.vo $(ARCH)/Archi.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memdata.vo common/Memtype.vo @@ -34,45 +35,45 @@ $(ARCH)/Op.vo $(ARCH)/Op.glob $(ARCH)/Op.v.beautified: $(ARCH)/Op.v lib/Coqlib.v backend/CminorSel.vo backend/CminorSel.glob backend/CminorSel.v.beautified: backend/CminorSel.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Events.vo common/Values.vo common/Memory.vo backend/Cminor.vo $(ARCH)/Op.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/SelectOp.vo $(ARCH)/SelectOp.glob $(ARCH)/SelectOp.v.beautified: $(ARCH)/SelectOp.v lib/Coqlib.vo driver/Compopts.vo common/AST.vo lib/Integers.vo lib/Floats.vo $(ARCH)/Op.vo backend/CminorSel.vo backend/SelectDiv.vo backend/SelectDiv.glob backend/SelectDiv.v.beautified: backend/SelectDiv.v lib/Coqlib.vo driver/Compopts.vo common/AST.vo lib/Integers.vo lib/Floats.vo $(ARCH)/Op.vo backend/CminorSel.vo $(ARCH)/SelectOp.vo -backend/SelectLong.vo backend/SelectLong.glob backend/SelectLong.v.beautified: backend/SelectLong.v lib/Coqlib.vo common/AST.vo lib/Integers.vo lib/Floats.vo $(ARCH)/Op.vo backend/CminorSel.vo $(ARCH)/SelectOp.vo common/Errors.vo common/Globalenvs.vo -backend/Selection.vo backend/Selection.glob backend/Selection.v.beautified: backend/Selection.v lib/Coqlib.vo common/AST.vo common/Errors.vo lib/Integers.vo common/Globalenvs.vo common/Switch.vo backend/Cminor.vo $(ARCH)/Op.vo backend/CminorSel.vo $(ARCH)/SelectOp.vo backend/SelectDiv.vo backend/SelectLong.vo $(ARCH)/Machregs.vo +backend/SelectLong.vo backend/SelectLong.glob backend/SelectLong.v.beautified: backend/SelectLong.v lib/Coqlib.vo common/AST.vo lib/Integers.vo lib/Floats.vo $(ARCH)/Op.vo backend/CminorSel.vo $(ARCH)/SelectOp.vo +backend/Selection.vo backend/Selection.glob backend/Selection.v.beautified: backend/Selection.v lib/Coqlib.vo lib/Maps.vo common/AST.vo common/Errors.vo lib/Integers.vo common/Globalenvs.vo common/Switch.vo backend/Cminor.vo $(ARCH)/Op.vo backend/CminorSel.vo $(ARCH)/SelectOp.vo backend/SelectDiv.vo backend/SelectLong.vo $(ARCH)/Machregs.vo $(ARCH)/SelectOpproof.vo $(ARCH)/SelectOpproof.glob $(ARCH)/SelectOpproof.v.beautified: $(ARCH)/SelectOpproof.v lib/Coqlib.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/SelectDivproof.vo backend/SelectDivproof.glob backend/SelectDivproof.v.beautified: backend/SelectDivproof.v lib/Coqlib.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Globalenvs.vo common/Events.vo backend/Cminor.vo $(ARCH)/Op.vo backend/CminorSel.vo $(ARCH)/SelectOp.vo $(ARCH)/SelectOpproof.vo backend/SelectDiv.vo -backend/SelectLongproof.vo backend/SelectLongproof.glob backend/SelectLongproof.v.beautified: backend/SelectLongproof.v lib/Coqlib.vo common/AST.vo common/Errors.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Globalenvs.vo common/Events.vo backend/Cminor.vo $(ARCH)/Op.vo backend/CminorSel.vo $(ARCH)/SelectOp.vo $(ARCH)/SelectOpproof.vo backend/SelectLong.vo -backend/Selectionproof.vo backend/Selectionproof.glob backend/Selectionproof.v.beautified: backend/Selectionproof.v lib/Coqlib.vo lib/Maps.vo common/AST.vo common/Errors.vo lib/Integers.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo common/Switch.vo backend/Cminor.vo $(ARCH)/Op.vo backend/CminorSel.vo $(ARCH)/SelectOp.vo backend/SelectDiv.vo backend/SelectLong.vo backend/Selection.vo $(ARCH)/SelectOpproof.vo backend/SelectDivproof.vo backend/SelectLongproof.vo +backend/SelectLongproof.vo backend/SelectLongproof.glob backend/SelectLongproof.v.beautified: backend/SelectLongproof.v lib/Coqlib.vo lib/Maps.vo common/AST.vo common/Errors.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Globalenvs.vo common/Events.vo backend/Cminor.vo $(ARCH)/Op.vo backend/CminorSel.vo $(ARCH)/SelectOp.vo $(ARCH)/SelectOpproof.vo backend/SelectLong.vo +backend/Selectionproof.vo backend/Selectionproof.glob backend/Selectionproof.v.beautified: backend/Selectionproof.v lib/Coqlib.vo lib/Maps.vo common/AST.vo common/Linking.vo common/Errors.vo lib/Integers.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo common/Switch.vo backend/Cminor.vo $(ARCH)/Op.vo backend/CminorSel.vo $(ARCH)/SelectOp.vo backend/SelectDiv.vo backend/SelectLong.vo backend/Selection.vo $(ARCH)/SelectOpproof.vo backend/SelectDivproof.vo backend/SelectLongproof.vo backend/Registers.vo backend/Registers.glob backend/Registers.v.beautified: backend/Registers.v lib/Coqlib.vo common/AST.vo lib/Maps.vo lib/Ordered.vo common/Values.vo backend/RTL.vo backend/RTL.glob backend/RTL.v.beautified: 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/RTLgen.vo backend/RTLgen.glob backend/RTLgen.v.beautified: backend/RTLgen.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Switch.vo $(ARCH)/Op.vo backend/Registers.vo backend/CminorSel.vo backend/RTL.vo backend/RTLgenspec.vo backend/RTLgenspec.glob backend/RTLgenspec.v.beautified: backend/RTLgenspec.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Switch.vo $(ARCH)/Op.vo backend/Registers.vo backend/CminorSel.vo backend/RTL.vo backend/RTLgen.vo -backend/RTLgenproof.vo backend/RTLgenproof.glob backend/RTLgenproof.v.beautified: 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/RTLgenproof.vo backend/RTLgenproof.glob backend/RTLgenproof.v.beautified: backend/RTLgenproof.v lib/Coqlib.vo lib/Maps.vo common/AST.vo common/Linking.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/Tailcall.vo backend/Tailcall.glob backend/Tailcall.v.beautified: backend/Tailcall.v lib/Coqlib.vo lib/Maps.vo common/AST.vo backend/Registers.vo $(ARCH)/Op.vo backend/RTL.vo backend/Conventions.vo -backend/Tailcallproof.vo backend/Tailcallproof.glob backend/Tailcallproof.v.beautified: 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 backend/Conventions.vo backend/Tailcall.vo -backend/Inlining.vo backend/Inlining.glob backend/Inlining.v.beautified: backend/Inlining.v lib/Coqlib.vo lib/Wfsimpl.vo common/Errors.vo lib/Maps.vo common/AST.vo lib/Integers.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo -backend/Inliningspec.vo backend/Inliningspec.glob backend/Inliningspec.v.beautified: backend/Inliningspec.v lib/Coqlib.vo lib/Wfsimpl.vo common/Errors.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Globalenvs.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo backend/Inlining.vo -backend/Inliningproof.vo backend/Inliningproof.glob backend/Inliningproof.v.beautified: backend/Inliningproof.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Memory.vo common/Globalenvs.vo common/Events.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Registers.vo backend/Inlining.vo backend/Inliningspec.vo backend/RTL.vo +backend/Tailcallproof.vo backend/Tailcallproof.glob backend/Tailcallproof.v.beautified: backend/Tailcallproof.v lib/Coqlib.vo lib/Maps.vo lib/Integers.vo common/AST.vo common/Linking.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo backend/Conventions.vo backend/Tailcall.vo +backend/Inlining.vo backend/Inlining.glob backend/Inlining.v.beautified: backend/Inlining.v lib/Coqlib.vo lib/Wfsimpl.vo lib/Maps.vo common/Errors.vo lib/Integers.vo common/AST.vo common/Linking.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo +backend/Inliningspec.vo backend/Inliningspec.glob backend/Inliningspec.v.beautified: backend/Inliningspec.v lib/Coqlib.vo lib/Wfsimpl.vo lib/Maps.vo common/Errors.vo lib/Integers.vo common/AST.vo common/Linking.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo backend/Inlining.vo +backend/Inliningproof.vo backend/Inliningproof.glob backend/Inliningproof.v.beautified: backend/Inliningproof.v lib/Coqlib.vo lib/Wfsimpl.vo lib/Maps.vo common/Errors.vo lib/Integers.vo common/AST.vo common/Linking.vo common/Values.vo common/Memory.vo common/Globalenvs.vo common/Events.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo backend/Inlining.vo backend/Inliningspec.vo backend/Renumber.vo backend/Renumber.glob backend/Renumber.v.beautified: backend/Renumber.v lib/Coqlib.vo lib/Maps.vo lib/Postorder.vo backend/RTL.vo backend/Renumberproof.vo backend/Renumberproof.glob backend/Renumberproof.v.beautified: backend/Renumberproof.v lib/Coqlib.vo lib/Maps.vo lib/Postorder.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo backend/Renumber.vo backend/RTLtyping.vo backend/RTLtyping.glob backend/RTLtyping.v.beautified: backend/RTLtyping.v lib/Coqlib.vo common/Errors.vo common/Unityping.vo lib/Maps.vo common/AST.vo $(ARCH)/Op.vo backend/Registers.vo common/Globalenvs.vo common/Values.vo lib/Integers.vo common/Memory.vo common/Events.vo backend/RTL.vo backend/Conventions.vo backend/Kildall.vo backend/Kildall.glob backend/Kildall.v.beautified: backend/Kildall.v lib/Coqlib.vo lib/Iteration.vo lib/Maps.vo lib/Lattice.vo lib/Heaps.vo backend/Liveness.vo backend/Liveness.glob backend/Liveness.v.beautified: backend/Liveness.v lib/Coqlib.vo lib/Maps.vo lib/Lattice.vo common/AST.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo backend/Kildall.vo -backend/ValueDomain.vo backend/ValueDomain.glob backend/ValueDomain.v.beautified: backend/ValueDomain.v lib/Coqlib.vo lib/Maps.vo driver/Compopts.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Globalenvs.vo common/Events.vo lib/Lattice.vo backend/Kildall.vo backend/Registers.vo backend/RTL.vo +backend/ValueDomain.vo backend/ValueDomain.glob backend/ValueDomain.v.beautified: backend/ValueDomain.v lib/Coqlib.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo lib/Lattice.vo driver/Compopts.vo common/AST.vo common/Values.vo common/Memory.vo common/Globalenvs.vo common/Events.vo backend/Registers.vo backend/RTL.vo $(ARCH)/ValueAOp.vo $(ARCH)/ValueAOp.glob $(ARCH)/ValueAOp.v.beautified: $(ARCH)/ValueAOp.v lib/Coqlib.vo driver/Compopts.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Globalenvs.vo $(ARCH)/Op.vo backend/ValueDomain.vo backend/RTL.vo -backend/ValueAnalysis.vo backend/ValueAnalysis.glob backend/ValueAnalysis.v.beautified: backend/ValueAnalysis.v lib/Coqlib.vo lib/Maps.vo driver/Compopts.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Globalenvs.vo common/Events.vo lib/Lattice.vo backend/Kildall.vo backend/Registers.vo $(ARCH)/Op.vo backend/RTL.vo backend/ValueDomain.vo $(ARCH)/ValueAOp.vo backend/Liveness.vo lib/Axioms.vo +backend/ValueAnalysis.vo backend/ValueAnalysis.glob backend/ValueAnalysis.v.beautified: backend/ValueAnalysis.v lib/Coqlib.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo lib/Lattice.vo backend/Kildall.vo driver/Compopts.vo common/AST.vo common/Linking.vo common/Values.vo common/Memory.vo common/Globalenvs.vo common/Events.vo backend/Registers.vo $(ARCH)/Op.vo backend/RTL.vo backend/ValueDomain.vo $(ARCH)/ValueAOp.vo backend/Liveness.vo lib/Axioms.vo $(ARCH)/ConstpropOp.vo $(ARCH)/ConstpropOp.glob $(ARCH)/ConstpropOp.v.beautified: $(ARCH)/ConstpropOp.v lib/Coqlib.vo driver/Compopts.vo common/AST.vo lib/Integers.vo lib/Floats.vo $(ARCH)/Op.vo backend/Registers.vo backend/ValueDomain.vo -backend/Constprop.vo backend/Constprop.glob backend/Constprop.v.beautified: backend/Constprop.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo $(ARCH)/Op.vo $(ARCH)/Machregs.vo backend/Registers.vo backend/RTL.vo lib/Lattice.vo backend/Kildall.vo backend/Liveness.vo backend/ValueDomain.vo $(ARCH)/ValueAOp.vo backend/ValueAnalysis.vo $(ARCH)/ConstpropOp.vo +backend/Constprop.vo backend/Constprop.glob backend/Constprop.v.beautified: backend/Constprop.v lib/Coqlib.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo lib/Lattice.vo backend/Kildall.vo common/AST.vo common/Linking.vo driver/Compopts.vo $(ARCH)/Machregs.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo backend/Liveness.vo backend/ValueDomain.vo $(ARCH)/ValueAOp.vo backend/ValueAnalysis.vo $(ARCH)/ConstpropOp.vo $(ARCH)/ConstpropOpproof.vo $(ARCH)/ConstpropOpproof.glob $(ARCH)/ConstpropOpproof.v.beautified: $(ARCH)/ConstpropOpproof.v lib/Coqlib.vo driver/Compopts.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Globalenvs.vo common/Events.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo backend/ValueDomain.vo $(ARCH)/ConstpropOp.vo -backend/Constpropproof.vo backend/Constpropproof.glob backend/Constpropproof.v.beautified: backend/Constpropproof.v lib/Coqlib.vo lib/Maps.vo driver/Compopts.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/RTL.vo lib/Lattice.vo backend/Kildall.vo backend/ValueDomain.vo $(ARCH)/ValueAOp.vo backend/ValueAnalysis.vo $(ARCH)/ConstpropOp.vo backend/Constprop.vo $(ARCH)/ConstpropOpproof.vo +backend/Constpropproof.vo backend/Constpropproof.glob backend/Constpropproof.v.beautified: backend/Constpropproof.v lib/Coqlib.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo lib/Lattice.vo backend/Kildall.vo common/AST.vo common/Linking.vo common/Values.vo common/Events.vo common/Memory.vo common/Globalenvs.vo common/Smallstep.vo driver/Compopts.vo $(ARCH)/Machregs.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo backend/Liveness.vo backend/ValueDomain.vo $(ARCH)/ValueAOp.vo backend/ValueAnalysis.vo $(ARCH)/ConstpropOp.vo $(ARCH)/ConstpropOpproof.vo backend/Constprop.vo backend/CSEdomain.vo backend/CSEdomain.glob backend/CSEdomain.v.beautified: backend/CSEdomain.v lib/Coqlib.vo lib/Maps.vo common/AST.vo common/Values.vo common/Memory.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo $(ARCH)/CombineOp.vo $(ARCH)/CombineOp.glob $(ARCH)/CombineOp.v.beautified: $(ARCH)/CombineOp.v lib/Coqlib.vo common/AST.vo lib/Integers.vo $(ARCH)/Op.vo backend/CSEdomain.vo -backend/CSE.vo backend/CSE.glob backend/CSE.v.beautified: backend/CSE.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 $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo backend/ValueDomain.vo backend/ValueAnalysis.vo backend/CSEdomain.vo backend/Kildall.vo $(ARCH)/CombineOp.vo +backend/CSE.vo backend/CSE.glob backend/CSE.v.beautified: backend/CSE.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo lib/Integers.vo lib/Floats.vo lib/Lattice.vo backend/Kildall.vo common/AST.vo common/Linking.vo common/Values.vo common/Memory.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo backend/ValueDomain.vo backend/ValueAnalysis.vo backend/CSEdomain.vo $(ARCH)/CombineOp.vo $(ARCH)/CombineOpproof.vo $(ARCH)/CombineOpproof.glob $(ARCH)/CombineOpproof.v.beautified: $(ARCH)/CombineOpproof.v lib/Coqlib.vo lib/Integers.vo common/Values.vo common/Memory.vo $(ARCH)/Op.vo backend/RTL.vo backend/CSEdomain.vo $(ARCH)/CombineOp.vo -backend/CSEproof.vo backend/CSEproof.glob backend/CSEproof.v.beautified: backend/CSEproof.v lib/Coqlib.vo lib/Maps.vo common/AST.vo common/Errors.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/ValueDomain.vo $(ARCH)/ValueAOp.vo backend/ValueAnalysis.vo backend/CSEdomain.vo $(ARCH)/CombineOp.vo $(ARCH)/CombineOpproof.vo backend/CSE.vo +backend/CSEproof.vo backend/CSEproof.glob backend/CSEproof.v.beautified: backend/CSEproof.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo lib/Integers.vo lib/Floats.vo lib/Lattice.vo backend/Kildall.vo common/AST.vo common/Linking.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo backend/ValueDomain.vo $(ARCH)/ValueAOp.vo backend/ValueAnalysis.vo backend/CSEdomain.vo $(ARCH)/CombineOp.vo $(ARCH)/CombineOpproof.vo backend/CSE.vo backend/NeedDomain.vo backend/NeedDomain.glob backend/NeedDomain.v.beautified: backend/NeedDomain.v lib/Coqlib.vo lib/Maps.vo lib/IntvSets.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Globalenvs.vo common/Events.vo lib/Lattice.vo backend/Registers.vo backend/ValueDomain.vo $(ARCH)/Op.vo backend/RTL.vo $(ARCH)/NeedOp.vo $(ARCH)/NeedOp.glob $(ARCH)/NeedOp.v.beautified: $(ARCH)/NeedOp.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/NeedDomain.vo backend/RTL.vo -backend/Deadcode.vo backend/Deadcode.glob backend/Deadcode.v.beautified: backend/Deadcode.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Memory.vo backend/Registers.vo $(ARCH)/Op.vo backend/RTL.vo lib/Lattice.vo backend/Kildall.vo backend/ValueDomain.vo backend/ValueAnalysis.vo backend/NeedDomain.vo $(ARCH)/NeedOp.vo -backend/Deadcodeproof.vo backend/Deadcodeproof.glob backend/Deadcodeproof.v.beautified: backend/Deadcodeproof.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo lib/IntvSets.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Globalenvs.vo common/Events.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo lib/Lattice.vo backend/Kildall.vo backend/ValueDomain.vo backend/ValueAnalysis.vo backend/NeedDomain.vo $(ARCH)/NeedOp.vo backend/Deadcode.vo -backend/Unusedglob.vo backend/Unusedglob.glob backend/Unusedglob.v.beautified: backend/Unusedglob.v lib/Coqlib.vo lib/Ordered.vo lib/Maps.vo lib/Iteration.vo common/AST.vo common/Errors.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo -backend/Unusedglobproof.vo backend/Unusedglobproof.glob backend/Unusedglobproof.v.beautified: backend/Unusedglobproof.v lib/Coqlib.vo lib/Ordered.vo lib/Maps.vo lib/Iteration.vo common/AST.vo common/Errors.vo lib/Integers.vo common/Values.vo common/Memory.vo common/Globalenvs.vo common/Events.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo backend/Unusedglob.vo +backend/Deadcode.vo backend/Deadcode.glob backend/Deadcode.v.beautified: backend/Deadcode.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo lib/Integers.vo lib/Floats.vo lib/Lattice.vo backend/Kildall.vo common/AST.vo common/Linking.vo common/Memory.vo backend/Registers.vo $(ARCH)/Op.vo backend/RTL.vo backend/ValueDomain.vo backend/ValueAnalysis.vo backend/NeedDomain.vo $(ARCH)/NeedOp.vo +backend/Deadcodeproof.vo backend/Deadcodeproof.glob backend/Deadcodeproof.v.beautified: backend/Deadcodeproof.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo lib/Integers.vo lib/Floats.vo lib/Lattice.vo backend/Kildall.vo common/AST.vo common/Linking.vo common/Values.vo common/Memory.vo common/Globalenvs.vo common/Events.vo common/Smallstep.vo backend/Registers.vo $(ARCH)/Op.vo backend/RTL.vo backend/ValueDomain.vo backend/ValueAnalysis.vo backend/NeedDomain.vo $(ARCH)/NeedOp.vo backend/Deadcode.vo +backend/Unusedglob.vo backend/Unusedglob.glob backend/Unusedglob.v.beautified: backend/Unusedglob.v lib/Coqlib.vo lib/Maps.vo lib/Ordered.vo lib/Iteration.vo common/Errors.vo common/AST.vo common/Linking.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo +backend/Unusedglobproof.vo backend/Unusedglobproof.glob backend/Unusedglobproof.v.beautified: backend/Unusedglobproof.v lib/Coqlib.vo lib/Maps.vo lib/Ordered.vo lib/Iteration.vo common/Errors.vo common/AST.vo common/Linking.vo lib/Integers.vo common/Values.vo common/Memory.vo common/Globalenvs.vo common/Events.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo backend/Unusedglob.vo $(ARCH)/Machregs.vo $(ARCH)/Machregs.glob $(ARCH)/Machregs.v.beautified: $(ARCH)/Machregs.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo $(ARCH)/Op.vo backend/Locations.vo backend/Locations.glob backend/Locations.v.beautified: backend/Locations.v lib/Coqlib.vo lib/Maps.vo lib/Ordered.vo common/AST.vo common/Values.vo $(ARCH)/Machregs.vo $(ARCH)/Conventions1.vo $(ARCH)/Conventions1.glob $(ARCH)/Conventions1.v.beautified: $(ARCH)/Conventions1.v lib/Coqlib.vo common/AST.vo common/Events.vo backend/Locations.vo @@ -100,9 +101,9 @@ $(ARCH)/Asmgen.vo $(ARCH)/Asmgen.glob $(ARCH)/Asmgen.v.beautified: $(ARCH)/Asmge backend/Asmgenproof0.vo backend/Asmgenproof0.glob backend/Asmgenproof0.v.beautified: backend/Asmgenproof0.v lib/Coqlib.vo lib/Intv.vo common/AST.vo common/Errors.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Globalenvs.vo common/Events.vo common/Smallstep.vo backend/Locations.vo backend/Mach.vo $(ARCH)/Asm.vo $(ARCH)/Asmgen.vo backend/Conventions.vo $(ARCH)/Asmgenproof1.vo $(ARCH)/Asmgenproof1.glob $(ARCH)/Asmgenproof1.v.beautified: $(ARCH)/Asmgenproof1.v lib/Coqlib.vo common/AST.vo common/Errors.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Globalenvs.vo $(ARCH)/Op.vo backend/Locations.vo backend/Mach.vo $(ARCH)/Asm.vo $(ARCH)/Asmgen.vo backend/Asmgenproof0.vo backend/Conventions.vo $(ARCH)/Asmgenproof.vo $(ARCH)/Asmgenproof.glob $(ARCH)/Asmgenproof.v.beautified: $(ARCH)/Asmgenproof.v lib/Coqlib.vo common/Errors.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Locations.vo backend/Mach.vo backend/Conventions.vo $(ARCH)/Asm.vo $(ARCH)/Asmgen.vo backend/Asmgenproof0.vo $(ARCH)/Asmgenproof1.vo -cfrontend/Ctypes.vo cfrontend/Ctypes.glob cfrontend/Ctypes.v.beautified: cfrontend/Ctypes.v lib/Coqlib.vo lib/Maps.vo common/AST.vo common/Errors.vo $(ARCH)/Archi.vo +cfrontend/Ctypes.vo cfrontend/Ctypes.glob cfrontend/Ctypes.v.beautified: cfrontend/Ctypes.v lib/Axioms.vo lib/Coqlib.vo lib/Maps.vo common/Errors.vo common/AST.vo common/Linking.vo $(ARCH)/Archi.vo cfrontend/Cop.vo cfrontend/Cop.glob cfrontend/Cop.v.beautified: cfrontend/Cop.v lib/Coqlib.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo cfrontend/Ctypes.vo -cfrontend/Csyntax.vo cfrontend/Csyntax.glob cfrontend/Csyntax.v.beautified: cfrontend/Csyntax.v lib/Coqlib.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/AST.vo common/Errors.vo cfrontend/Ctypes.vo cfrontend/Cop.vo +cfrontend/Csyntax.vo cfrontend/Csyntax.glob cfrontend/Csyntax.v.beautified: cfrontend/Csyntax.v lib/Coqlib.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/Errors.vo common/AST.vo common/Linking.vo common/Values.vo cfrontend/Ctypes.vo cfrontend/Cop.vo cfrontend/Csem.vo cfrontend/Csem.glob cfrontend/Csem.v.beautified: cfrontend/Csem.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/AST.vo common/Memory.vo common/Events.vo common/Globalenvs.vo cfrontend/Ctypes.vo cfrontend/Cop.vo cfrontend/Csyntax.vo common/Smallstep.vo cfrontend/Ctyping.vo cfrontend/Ctyping.glob cfrontend/Ctyping.v.beautified: cfrontend/Ctyping.v lib/Coqlib.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Globalenvs.vo common/Events.vo common/AST.vo cfrontend/Ctypes.vo cfrontend/Cop.vo cfrontend/Csyntax.vo cfrontend/Csem.vo common/Errors.vo cfrontend/Cstrategy.vo cfrontend/Cstrategy.glob cfrontend/Cstrategy.v.beautified: cfrontend/Cstrategy.v lib/Axioms.vo lib/Coqlib.vo common/Errors.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/AST.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo cfrontend/Ctypes.vo cfrontend/Cop.vo cfrontend/Csyntax.vo cfrontend/Csem.vo @@ -110,17 +111,17 @@ cfrontend/Cexec.vo cfrontend/Cexec.glob cfrontend/Cexec.v.beautified: cfrontend/ cfrontend/Initializers.vo cfrontend/Initializers.glob cfrontend/Initializers.v.beautified: cfrontend/Initializers.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/AST.vo common/Memory.vo common/Globalenvs.vo cfrontend/Ctypes.vo cfrontend/Cop.vo cfrontend/Csyntax.vo cfrontend/Initializersproof.vo cfrontend/Initializersproof.glob cfrontend/Initializersproof.v.beautified: cfrontend/Initializersproof.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/Globalenvs.vo common/Events.vo common/Smallstep.vo cfrontend/Ctypes.vo cfrontend/Cop.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Initializers.vo cfrontend/SimplExpr.vo cfrontend/SimplExpr.glob cfrontend/SimplExpr.v.beautified: cfrontend/SimplExpr.v lib/Coqlib.vo common/Errors.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/AST.vo cfrontend/Ctypes.vo cfrontend/Cop.vo cfrontend/Csyntax.vo cfrontend/Clight.vo -cfrontend/SimplExprspec.vo cfrontend/SimplExprspec.glob cfrontend/SimplExprspec.v.beautified: cfrontend/SimplExprspec.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/Memory.vo common/AST.vo cfrontend/Ctypes.vo cfrontend/Cop.vo cfrontend/Csyntax.vo cfrontend/Clight.vo cfrontend/SimplExpr.vo -cfrontend/SimplExprproof.vo cfrontend/SimplExprproof.glob cfrontend/SimplExprproof.v.beautified: cfrontend/SimplExprproof.v lib/Coqlib.vo lib/Maps.vo common/AST.vo common/Errors.vo lib/Integers.vo common/Values.vo common/Memory.vo common/Events.vo common/Smallstep.vo common/Globalenvs.vo cfrontend/Ctypes.vo cfrontend/Cop.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Cstrategy.vo cfrontend/Clight.vo cfrontend/SimplExpr.vo cfrontend/SimplExprspec.vo +cfrontend/SimplExprspec.vo cfrontend/SimplExprspec.glob cfrontend/SimplExprspec.v.beautified: cfrontend/SimplExprspec.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo lib/Integers.vo lib/Floats.vo common/AST.vo common/Linking.vo common/Memory.vo cfrontend/Ctypes.vo cfrontend/Cop.vo cfrontend/Csyntax.vo cfrontend/Clight.vo cfrontend/SimplExpr.vo +cfrontend/SimplExprproof.vo cfrontend/SimplExprproof.glob cfrontend/SimplExprproof.v.beautified: cfrontend/SimplExprproof.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo lib/Integers.vo common/AST.vo common/Linking.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo cfrontend/Ctypes.vo cfrontend/Cop.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Cstrategy.vo cfrontend/Clight.vo cfrontend/SimplExpr.vo cfrontend/SimplExprspec.vo cfrontend/Clight.vo cfrontend/Clight.glob cfrontend/Clight.v.beautified: cfrontend/Clight.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 common/Smallstep.vo cfrontend/Ctypes.vo cfrontend/Cop.vo cfrontend/ClightBigstep.vo cfrontend/ClightBigstep.glob cfrontend/ClightBigstep.v.beautified: cfrontend/ClightBigstep.v lib/Coqlib.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/AST.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo cfrontend/Ctypes.vo cfrontend/Cop.vo cfrontend/Clight.vo -cfrontend/SimplLocals.vo cfrontend/SimplLocals.glob cfrontend/SimplLocals.v.beautified: cfrontend/SimplLocals.v lib/Coqlib.vo lib/Ordered.vo common/Errors.vo common/AST.vo cfrontend/Ctypes.vo cfrontend/Cop.vo cfrontend/Clight.vo driver/Compopts.vo -cfrontend/SimplLocalsproof.vo cfrontend/SimplLocalsproof.glob cfrontend/SimplLocalsproof.v.beautified: cfrontend/SimplLocalsproof.v lib/Coqlib.vo common/Errors.vo lib/Ordered.vo common/AST.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Memory.vo common/Globalenvs.vo common/Events.vo common/Smallstep.vo cfrontend/Ctypes.vo cfrontend/Cop.vo cfrontend/Clight.vo cfrontend/SimplLocals.vo -cfrontend/Cshmgen.vo cfrontend/Cshmgen.glob cfrontend/Cshmgen.v.beautified: cfrontend/Cshmgen.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo lib/Integers.vo lib/Floats.vo common/AST.vo cfrontend/Ctypes.vo cfrontend/Cop.vo cfrontend/Clight.vo backend/Cminor.vo cfrontend/Csharpminor.vo -cfrontend/Cshmgenproof.vo cfrontend/Cshmgenproof.glob cfrontend/Cshmgenproof.v.beautified: cfrontend/Cshmgenproof.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/Ctypes.vo cfrontend/Cop.vo cfrontend/Clight.vo backend/Cminor.vo cfrontend/Csharpminor.vo cfrontend/Cshmgen.vo +cfrontend/SimplLocals.vo cfrontend/SimplLocals.glob cfrontend/SimplLocals.v.beautified: cfrontend/SimplLocals.v lib/Coqlib.vo lib/Ordered.vo common/Errors.vo common/AST.vo common/Linking.vo cfrontend/Ctypes.vo cfrontend/Cop.vo cfrontend/Clight.vo driver/Compopts.vo +cfrontend/SimplLocalsproof.vo cfrontend/SimplLocalsproof.glob cfrontend/SimplLocalsproof.v.beautified: cfrontend/SimplLocalsproof.v lib/Coqlib.vo common/Errors.vo lib/Ordered.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/AST.vo common/Linking.vo common/Values.vo common/Memory.vo common/Globalenvs.vo common/Events.vo common/Smallstep.vo cfrontend/Ctypes.vo cfrontend/Cop.vo cfrontend/Clight.vo cfrontend/SimplLocals.vo +cfrontend/Cshmgen.vo cfrontend/Cshmgen.glob cfrontend/Cshmgen.v.beautified: cfrontend/Cshmgen.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo lib/Integers.vo lib/Floats.vo common/AST.vo common/Linking.vo cfrontend/Ctypes.vo cfrontend/Cop.vo cfrontend/Clight.vo backend/Cminor.vo cfrontend/Csharpminor.vo +cfrontend/Cshmgenproof.vo cfrontend/Cshmgenproof.glob cfrontend/Cshmgenproof.v.beautified: cfrontend/Cshmgenproof.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/AST.vo common/Linking.vo common/Values.vo common/Events.vo common/Memory.vo common/Globalenvs.vo common/Smallstep.vo cfrontend/Ctypes.vo cfrontend/Cop.vo cfrontend/Clight.vo backend/Cminor.vo cfrontend/Csharpminor.vo cfrontend/Cshmgen.vo cfrontend/Csharpminor.vo cfrontend/Csharpminor.glob cfrontend/Csharpminor.v.beautified: 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 common/Switch.vo backend/Cminor.vo common/Smallstep.vo -cfrontend/Cminorgen.vo cfrontend/Cminorgen.glob cfrontend/Cminorgen.v.beautified: cfrontend/Cminorgen.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo lib/Ordered.vo common/AST.vo lib/Integers.vo lib/Floats.vo cfrontend/Csharpminor.vo backend/Cminor.vo -cfrontend/Cminorgenproof.vo cfrontend/Cminorgenproof.glob cfrontend/Cminorgenproof.v.beautified: 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/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.glob cfrontend/Cminorgen.v.beautified: cfrontend/Cminorgen.v lib/Coqlib.vo lib/Maps.vo lib/Ordered.vo common/Errors.vo lib/Integers.vo lib/Floats.vo common/AST.vo common/Linking.vo cfrontend/Csharpminor.vo backend/Cminor.vo +cfrontend/Cminorgenproof.vo cfrontend/Cminorgenproof.glob cfrontend/Cminorgenproof.v.beautified: cfrontend/Cminorgenproof.v lib/Coqlib.vo lib/Maps.vo lib/Ordered.vo common/Errors.vo lib/Integers.vo lib/Floats.vo lib/Intv.vo common/AST.vo common/Linking.vo common/Values.vo common/Memory.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo cfrontend/Csharpminor.vo common/Switch.vo backend/Cminor.vo cfrontend/Cminorgen.vo driver/Compopts.vo driver/Compopts.glob driver/Compopts.v.beautified: driver/Compopts.v driver/Compiler.vo driver/Compiler.glob driver/Compiler.v.beautified: driver/Compiler.v lib/Coqlib.vo common/Errors.vo common/AST.vo common/Smallstep.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Cstrategy.vo cfrontend/Cexec.vo cfrontend/Clight.vo cfrontend/Csharpminor.vo backend/Cminor.vo backend/CminorSel.vo backend/RTL.vo backend/LTL.vo backend/Linear.vo backend/Mach.vo $(ARCH)/Asm.vo cfrontend/Initializers.vo cfrontend/SimplExpr.vo cfrontend/SimplLocals.vo cfrontend/Cshmgen.vo cfrontend/Cminorgen.vo backend/Selection.vo backend/RTLgen.vo backend/Tailcall.vo backend/Inlining.vo backend/Renumber.vo backend/Constprop.vo backend/CSE.vo backend/Deadcode.vo backend/Unusedglob.vo backend/Allocation.vo backend/Tunneling.vo backend/Linearize.vo backend/CleanupLabels.vo backend/Debugvar.vo backend/Stacking.vo $(ARCH)/Asmgen.vo cfrontend/SimplExprproof.vo cfrontend/SimplLocalsproof.vo cfrontend/Cshmgenproof.vo cfrontend/Cminorgenproof.vo backend/Selectionproof.vo backend/RTLgenproof.vo backend/Tailcallproof.vo backend/Inliningproof.vo backend/Renumberproof.vo backend/Constpropproof.vo backend/CSEproof.vo backend/Deadcodeproof.vo backend/Unusedglobproof.vo backend/Allocproof.vo backend/Tunnelingproof.vo backend/Linearizeproof.vo backend/CleanupLabelsproof.vo backend/Debugvarproof.vo backend/Stackingproof.vo $(ARCH)/Asmgenproof.vo driver/Compopts.vo driver/Complements.vo driver/Complements.glob driver/Complements.v.beautified: driver/Complements.v lib/Coqlib.vo common/AST.vo lib/Integers.vo common/Values.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo common/Behaviors.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Cstrategy.vo cfrontend/Clight.vo backend/Cminor.vo backend/RTL.vo $(ARCH)/Asm.vo driver/Compiler.vo common/Errors.vo @@ -56,7 +56,8 @@ VLIB=Axioms.v Coqlib.v Intv.v Maps.v Heaps.v Lattice.v Ordered.v \ # Parts common to the front-ends and the back-end (in common/) -COMMON=Errors.v AST.v Events.v Globalenvs.v Memdata.v Memtype.v Memory.v \ +COMMON=Errors.v AST.v Linking.v \ + Events.v Globalenvs.v Memdata.v Memtype.v Memory.v \ Values.v Smallstep.v Behaviors.v Switch.v Determinism.v Unityping.v # Back-end modules (in backend/, $(ARCH)/) diff --git a/arm/Asmexpand.ml b/arm/Asmexpand.ml index 5415f78e..47269f8f 100644 --- a/arm/Asmexpand.ml +++ b/arm/Asmexpand.ml @@ -440,4 +440,4 @@ let expand_fundef id = function Errors.OK (External ef) let expand_program (p: Asm.program) : Asm.program Errors.res = - AST.transform_partial_ident_program expand_fundef p + AST.transform_partial_program2 expand_fundef (fun id v -> Errors.OK v) p diff --git a/arm/Asmgenproof.v b/arm/Asmgenproof.v index 7a29e4a5..eb52d16e 100644 --- a/arm/Asmgenproof.v +++ b/arm/Asmgenproof.v @@ -12,76 +12,52 @@ (** Correctness proof for ARM code generation: main proof. *) -Require Import Coqlib. -Require Import Maps. -Require Import Errors. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import Memory. -Require Import Events. -Require Import Globalenvs. -Require Import Smallstep. -Require Import Op. -Require Import Locations. -Require Import Conventions. -Require Import Mach. -Require Import Compopts. -Require Import Asm. -Require Import Asmgen. -Require Import Asmgenproof0. -Require Import Asmgenproof1. +Require Import Coqlib Errors. +Require Import Integers Floats AST Linking Compopts. +Require Import Values Memory Events Globalenvs Smallstep. +Require Import Op Locations Mach Conventions Asm. +Require Import Asmgen Asmgenproof0 Asmgenproof1. + +Definition match_prog (p: Mach.program) (tp: Asm.program) := + match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp. + +Lemma transf_program_match: + forall p tp, transf_program p = OK tp -> match_prog p tp. +Proof. + intros. eapply match_transform_partial_program; eauto. +Qed. Section PRESERVATION. Variable prog: Mach.program. Variable tprog: Asm.program. -Hypothesis TRANSF: transf_program prog = Errors.OK tprog. - +Hypothesis TRANSF: match_prog prog tprog. Let ge := Genv.globalenv prog. Let tge := Genv.globalenv tprog. Lemma symbols_preserved: - forall id, Genv.find_symbol tge id = Genv.find_symbol ge id. -Proof. - intros. unfold ge, tge. - apply Genv.find_symbol_transf_partial with transf_fundef. - exact TRANSF. -Qed. + forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. +Proof (Genv.find_symbol_match TRANSF). -Lemma public_preserved: - forall id, Genv.public_symbol tge id = Genv.public_symbol ge id. -Proof. - intros. unfold ge, tge. - apply Genv.public_symbol_transf_partial with transf_fundef. - exact TRANSF. -Qed. +Lemma senv_preserved: + Senv.equiv ge tge. +Proof (Genv.senv_match TRANSF). Lemma functions_translated: forall b f, 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). + exists tf, + Genv.find_funct_ptr tge b = Some tf /\ transf_fundef f = OK tf. +Proof (Genv.find_funct_ptr_transf_partial TRANSF). Lemma functions_transl: - forall f b tf, - Genv.find_funct_ptr ge b = Some (Internal f) -> + forall fb f tf, + Genv.find_funct_ptr ge fb = Some (Internal f) -> transf_function f = OK tf -> - Genv.find_funct_ptr tge b = Some (Internal tf). -Proof. - intros. - destruct (functions_translated _ _ H) as [tf' [A B]]. - rewrite A. monadInv B. f_equal. congruence. -Qed. - -Lemma varinfo_preserved: - forall b, Genv.find_var_info tge b = Genv.find_var_info ge b. + Genv.find_funct_ptr tge fb = Some (Internal tf). Proof. - intros. unfold ge, tge. - apply Genv.find_var_info_transf_partial with transf_fundef. - exact TRANSF. + intros. exploit functions_translated; eauto. intros [tf' [A B]]. + monadInv B. rewrite H0 in EQ; inv EQ; auto. Qed. (** * Properties of control flow *) @@ -758,8 +734,7 @@ Opaque loadind. eapply find_instr_tail; eauto. erewrite <- sp_val by eauto. eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. - eapply external_call_symbols_preserved; eauto. - exact symbols_preserved. exact public_preserved. exact varinfo_preserved. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. eauto. econstructor; eauto. instantiate (2 := tf); instantiate (1 := x). @@ -921,8 +896,7 @@ Opaque loadind. intros [res' [m2' [P [Q [R S]]]]]. left; econstructor; split. apply plus_one. eapply exec_step_external; eauto. - eapply external_call_symbols_preserved'; eauto. - exact symbols_preserved. exact public_preserved. exact varinfo_preserved. + eapply external_call_symbols_preserved'; eauto. apply senv_preserved. econstructor; eauto. apply agree_set_other; auto with asmgen. eapply agree_set_mregs; eauto. @@ -940,7 +914,7 @@ Proof. intros. inversion H. unfold ge0 in *. econstructor; split. econstructor. - eapply Genv.init_mem_transf_partial; eauto. + eapply (Genv.init_mem_transf_partial TRANSF); eauto. replace (Genv.symbol_address (Genv.globalenv tprog) (prog_main tprog) Int.zero) with (Vptr fb Int.zero). econstructor; eauto. @@ -948,7 +922,7 @@ Proof. apply Mem.extends_refl. split. auto. simpl. unfold Vzero; congruence. intros. rewrite Regmap.gi. auto. unfold Genv.symbol_address. - rewrite (transform_partial_program_main _ _ TRANSF). + rewrite (match_program_main TRANSF). rewrite symbols_preserved. unfold ge; rewrite H1. auto. Qed. @@ -967,7 +941,7 @@ Theorem transf_program_correct: forward_simulation (Mach.semantics return_address_offset prog) (Asm.semantics tprog). Proof. eapply forward_simulation_star with (measure := measure). - eexact public_preserved. + apply senv_preserved. eexact transf_initial_states. eexact transf_final_states. exact step_simulation. diff --git a/backend/Allocation.v b/backend/Allocation.v index 7534e23f..6a6c1eb6 100644 --- a/backend/Allocation.v +++ b/backend/Allocation.v @@ -12,26 +12,11 @@ (** Register allocation by external oracle and a posteriori validation. *) -Require Import FSets. -Require FSetAVLplus. +Require Import FSets FSetAVLplus. +Require Import Coqlib Ordered Maps Errors Integers Floats. +Require Import AST Lattice Kildall Memdata. Require Archi. -Require Import Coqlib. -Require Import Ordered. -Require Import Errors. -Require Import Maps. -Require Import Lattice. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Memdata. -Require Import Op. -Require Import Registers. -Require Import RTL. -Require Import Kildall. -Require Import Locations. -Require Import Conventions. -Require Import RTLtyping. -Require Import LTL. +Require Import Op Registers RTL Locations Conventions RTLtyping LTL. (** The validation algorithm used here is described in "Validating register allocation and spilling", diff --git a/backend/Allocproof.v b/backend/Allocproof.v index 2bcc038c..84d4bdd5 100644 --- a/backend/Allocproof.v +++ b/backend/Allocproof.v @@ -14,29 +14,22 @@ RTL to LTL). *) Require Import FSets. +Require Import Coqlib Ordered Maps Errors Integers Floats. +Require Import AST Linking Lattice Kildall. +Require Import Values Memory Globalenvs Events Smallstep. Require Archi. -Require Import Coqlib. -Require Import Ordered. -Require Import Errors. -Require Import Maps. -Require Import Lattice. -Require Import AST. -Require Import Integers. -Require Import Values. -Require Import Memory. -Require Import Events. -Require Import Globalenvs. -Require Import Smallstep. -Require Import Op. -Require Import Registers. -Require Import RTL. -Require Import RTLtyping. -Require Import Kildall. -Require Import Locations. -Require Import Conventions. -Require Import LTL. +Require Import Op Registers RTL Locations Conventions RTLtyping LTL. Require Import Allocation. +Definition match_prog (p: RTL.program) (tp: LTL.program) := + match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp. + +Lemma transf_program_match: + forall p tp, transf_program p = OK tp -> match_prog p tp. +Proof. + intros. eapply match_transform_partial_program; eauto. +Qed. + (** * Soundness of structural checks *) Definition expand_move (sd: loc * loc) : instruction := @@ -1608,48 +1601,32 @@ Section PRESERVATION. Variable prog: RTL.program. Variable tprog: LTL.program. -Hypothesis TRANSF: transf_program prog = OK tprog. +Hypothesis TRANSF: match_prog prog tprog. Let ge := Genv.globalenv prog. Let tge := Genv.globalenv tprog. Lemma symbols_preserved: forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. -Proof. - intro. unfold ge, tge. - apply Genv.find_symbol_transf_partial with transf_fundef. - exact TRANSF. -Qed. +Proof (Genv.find_symbol_match TRANSF). -Lemma public_preserved: - forall (s: ident), Genv.public_symbol tge s = Genv.public_symbol ge s. -Proof. - intro. unfold ge, tge. - apply Genv.public_symbol_transf_partial with transf_fundef. - exact TRANSF. -Qed. - -Lemma varinfo_preserved: - forall b, Genv.find_var_info tge b = Genv.find_var_info ge b. -Proof. - intro. unfold ge, tge. - apply Genv.find_var_info_transf_partial with transf_fundef. - exact TRANSF. -Qed. +Lemma senv_preserved: + Senv.equiv ge tge. +Proof (Genv.senv_match TRANSF). Lemma functions_translated: forall (v: val) (f: RTL.fundef), 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). 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). Lemma sig_function_translated: forall f tf, @@ -2185,8 +2162,7 @@ Proof. eapply star_trans. eexact A1. eapply star_left. econstructor. eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. - eapply external_call_symbols_preserved. eauto. - exact symbols_preserved. exact public_preserved. exact varinfo_preserved. + eapply external_call_symbols_preserved. apply senv_preserved. eauto. instantiate (1 := ls2); auto. eapply star_right. eexact A3. econstructor. @@ -2278,8 +2254,7 @@ Proof. econstructor; split. apply plus_one. econstructor; eauto. eapply external_call_symbols_preserved' with (ge1 := ge). - econstructor; eauto. - exact symbols_preserved. exact public_preserved. exact varinfo_preserved. + econstructor; eauto. apply senv_preserved. econstructor; eauto. simpl. replace (map (Locmap.setlist (map R (loc_result (ef_sig ef))) @@ -2314,9 +2289,9 @@ Proof. exploit sig_function_translated; eauto. intros SIG. exists (LTL.Callstate nil tf (Locmap.init Vundef) m0); split. econstructor; eauto. - eapply Genv.init_mem_transf_partial; eauto. + eapply (Genv.init_mem_transf_partial TRANSF); eauto. rewrite symbols_preserved. - rewrite (transform_partial_program_main _ _ TRANSF). auto. + rewrite (match_program_main TRANSF). auto. congruence. constructor; auto. constructor. rewrite SIG; rewrite H3; auto. @@ -2334,12 +2309,15 @@ Proof. econstructor. simpl; reflexivity. unfold loc_result in RES; rewrite H in RES. simpl in RES. inv RES. inv H3; auto. Qed. - + Lemma wt_prog: wt_program prog. Proof. - red; intros. exploit transform_partial_program_succeeds; eauto. - intros [tfd TF]. destruct f; simpl in *. -- monadInv TF. unfold transf_function in EQ. + red; intros. + exploit list_forall2_in_left. eexact (proj1 TRANSF). eauto. + intros ([i' gd] & A & B & C). simpl in *; subst i'. + inv C. destruct f; simpl in *. +- monadInv H2. + unfold transf_function in EQ. destruct (type_function f) as [env|] eqn:TF; try discriminate. econstructor. eapply type_function_correct; eauto. - constructor. @@ -2350,7 +2328,7 @@ Theorem transf_program_correct: Proof. set (ms := fun s s' => wt_state s /\ match_states s s'). eapply forward_simulation_plus with (match_states := ms). -- exact public_preserved. +- apply senv_preserved. - intros. exploit initial_states_simulation; eauto. intros [st2 [A B]]. exists st2; split; auto. split; auto. apply wt_initial_state with (p := prog); auto. exact wt_prog. diff --git a/backend/CSE.v b/backend/CSE.v index 63dadbc7..d6b89557 100644 --- a/backend/CSE.v +++ b/backend/CSE.v @@ -13,22 +13,11 @@ (** Common subexpression elimination over RTL. This optimization proceeds by value numbering over extended basic blocks. *) -Require Import Coqlib. -Require Import Maps. -Require Import Errors. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import Memory. -Require Import Op. -Require Import Registers. -Require Import RTL. -Require Import ValueDomain. -Require Import ValueAnalysis. -Require Import CSEdomain. -Require Import Kildall. -Require Import CombineOp. +Require Import Coqlib Maps Errors Integers Floats Lattice Kildall. +Require Import AST Linking. +Require Import Values Memory. +Require Import Op Registers RTL. +Require Import ValueDomain ValueAnalysis CSEdomain CombineOp. (** The idea behind value numbering algorithms is to associate abstract identifiers (``value numbers'') to the contents of registers @@ -451,7 +440,8 @@ Module Solver := BBlock_solver(Numbering). For builtin invocations [Ibuiltin], we have three strategies: - Forget all equations. This is appropriate for builtins that can be - turned into function calls ([EF_external], [EF_malloc], [EF_free]). + turned into function calls + ([EF_external], [EF_runtime], [EF_malloc], [EF_free]). - Forget equations involving loads but keep equations over registers. This is appropriate for builtins that can modify memory, e.g. volatile stores, or [EF_builtin] @@ -481,7 +471,7 @@ Definition transfer (f: function) (approx: PMap.t VA.t) (pc: node) (before: numb empty_numbering | Ibuiltin ef args res s => match ef with - | EF_external _ _ | EF_malloc | EF_free | EF_inline_asm _ _ _ => + | EF_external _ _ | EF_runtime _ _ | EF_malloc | EF_free | EF_inline_asm _ _ _ => empty_numbering | EF_builtin _ _ | EF_vstore _ => set_res_unknown (kill_all_loads before) res @@ -582,5 +572,5 @@ Definition transf_fundef (rm: romem) (f: fundef) : res fundef := AST.transf_partial_fundef (transf_function rm) f. Definition transf_program (p: program) : res program := - transform_partial_program (transf_fundef (romem_for_program p)) p. + transform_partial_program (transf_fundef (romem_for p)) p. diff --git a/backend/CSEproof.v b/backend/CSEproof.v index 07c7008d..2c144249 100644 --- a/backend/CSEproof.v +++ b/backend/CSEproof.v @@ -12,28 +12,21 @@ (** Correctness proof for common subexpression elimination. *) -Require Import Coqlib. -Require Import Maps. -Require Import AST. -Require Import Errors. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import Memory. -Require Import Events. -Require Import Globalenvs. -Require Import Smallstep. -Require Import Op. -Require Import Registers. -Require Import RTL. -Require Import Kildall. -Require Import ValueDomain. -Require Import ValueAOp. -Require Import ValueAnalysis. -Require Import CSEdomain. -Require Import CombineOp. -Require Import CombineOpproof. -Require Import CSE. +Require Import Coqlib Maps Errors Integers Floats Lattice Kildall. +Require Import AST Linking. +Require Import Values Memory Events Globalenvs Smallstep. +Require Import Op Registers RTL. +Require Import ValueDomain ValueAOp ValueAnalysis. +Require Import CSEdomain CombineOp CombineOpproof CSE. + +Definition match_prog (prog tprog: RTL.program) := + match_program (fun cu f tf => transf_fundef (romem_for cu) f = OK tf) eq prog tprog. + +Lemma transf_program_match: + forall prog tprog, transf_program prog = OK tprog -> match_prog prog tprog. +Proof. + intros. eapply match_transform_partial_program_contextual; eauto. +Qed. (** * Soundness of operations over value numberings *) @@ -809,37 +802,32 @@ Section PRESERVATION. Variable prog: program. Variable tprog : program. -Hypothesis TRANSF: transf_program prog = OK tprog. +Hypothesis TRANSF: match_prog prog tprog. Let ge := Genv.globalenv prog. Let tge := Genv.globalenv tprog. -Let rm := romem_for_program prog. Lemma symbols_preserved: forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. -Proof (Genv.find_symbol_transf_partial (transf_fundef rm) prog TRANSF). +Proof (Genv.find_symbol_match TRANSF). -Lemma public_preserved: - forall (s: ident), Genv.public_symbol tge s = Genv.public_symbol ge s. -Proof (Genv.public_symbol_transf_partial (transf_fundef rm) prog TRANSF). - -Lemma varinfo_preserved: - forall b, Genv.find_var_info tge b = Genv.find_var_info ge b. -Proof (Genv.find_var_info_transf_partial (transf_fundef rm) prog TRANSF). +Lemma senv_preserved: + Senv.equiv ge tge. +Proof (Genv.senv_match TRANSF). Lemma functions_translated: forall (v: val) (f: RTL.fundef), Genv.find_funct ge v = Some f -> - exists tf, Genv.find_funct tge v = Some tf /\ transf_fundef rm f = OK tf. -Proof (Genv.find_funct_transf_partial (transf_fundef rm) prog TRANSF). + exists cu tf, Genv.find_funct tge v = Some tf /\ transf_fundef (romem_for cu) f = OK tf /\ linkorder cu prog. +Proof (Genv.find_funct_match TRANSF). Lemma funct_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 rm f = OK tf. -Proof (Genv.find_funct_ptr_transf_partial (transf_fundef rm) prog TRANSF). + exists cu tf, Genv.find_funct_ptr tge b = Some tf /\ transf_fundef (romem_for cu) f = OK tf /\ linkorder cu prog. +Proof (Genv.find_funct_ptr_match TRANSF). Lemma sig_preserved: - forall f tf, transf_fundef rm f = OK tf -> funsig tf = funsig f. + forall rm f tf, transf_fundef rm f = OK tf -> funsig tf = funsig f. Proof. unfold transf_fundef; intros. destruct f; monadInv H; auto. unfold transf_function in EQ. @@ -887,7 +875,9 @@ Lemma find_function_translated: forall ros rs fd rs', find_function ge ros rs = Some fd -> regs_lessdef rs rs' -> - exists tfd, find_function tge ros rs' = Some tfd /\ transf_fundef rm fd = OK tfd. + exists cu tfd, find_function tge ros rs' = Some tfd + /\ transf_fundef (romem_for cu) fd = OK tfd + /\ linkorder cu prog. Proof. unfold find_function; intros; destruct ros. - specialize (H0 r). inv H0. @@ -914,12 +904,16 @@ Qed. the numbering at [pc] (returned by the static analysis) is satisfiable. *) +Definition analyze (cu: program) (f: function) := + CSE.analyze f (vanalyze (romem_for cu) f). + Inductive match_stackframes: list stackframe -> list stackframe -> Prop := | match_stackframes_nil: match_stackframes nil nil | match_stackframes_cons: - forall res sp pc rs f approx s rs' s' - (ANALYZE: analyze f (vanalyze rm f) = Some approx) + forall res sp pc rs f s rs' s' cu approx + (LINK: linkorder cu prog) + (ANALYZE: analyze cu f = Some approx) (SAT: forall v m, exists valu, numbering_holds valu ge sp (rs#res <- v) m approx!!pc) (RLD: regs_lessdef rs rs') (STACKS: match_stackframes s s'), @@ -929,8 +923,9 @@ Inductive match_stackframes: list stackframe -> list stackframe -> Prop := Inductive match_states: state -> state -> Prop := | match_states_intro: - forall s sp pc rs m s' rs' m' f approx - (ANALYZE: analyze f (vanalyze rm f) = Some approx) + forall s sp pc rs m s' rs' m' f cu approx + (LINK: linkorder cu prog) + (ANALYZE: analyze cu f = Some approx) (SAT: exists valu, numbering_holds valu ge sp rs m approx!!pc) (RLD: regs_lessdef rs rs') (MEXT: Mem.extends m m') @@ -938,18 +933,19 @@ Inductive match_states: state -> state -> Prop := match_states (State s f sp pc rs m) (State s' (transf_function' f approx) sp pc rs' m') | match_states_call: - forall s f tf args m s' args' m', - match_stackframes s s' -> - transf_fundef rm f = OK tf -> - Val.lessdef_list args args' -> - Mem.extends m m' -> + forall s f tf args m s' args' m' cu + (LINK: linkorder cu prog) + (STACKS: match_stackframes s s') + (TFD: transf_fundef (romem_for cu) f = OK tf) + (ARGS: Val.lessdef_list args args') + (MEXT: Mem.extends m m'), match_states (Callstate s f args m) (Callstate s' tf args' m') | match_states_return: - forall s s' v v' m m', - match_stackframes s s' -> - Val.lessdef v v' -> - Mem.extends m m' -> + forall s s' v v' m m' + (STACK: match_stackframes s s') + (RES: Val.lessdef v v') + (MEXT: Mem.extends m m'), match_states (Returnstate s v m) (Returnstate s' v' m'). @@ -1076,28 +1072,28 @@ Proof. econstructor; eauto. eapply analysis_correct_1; eauto. simpl; auto. unfold transfer; rewrite H. - inv SOUND. + InvSoundState. eapply add_store_result_hold; eauto. eapply kill_loads_after_store_holds; eauto. - (* Icall *) - exploit find_function_translated; eauto. intros [tf [FIND' TRANSF']]. + exploit find_function_translated; eauto. intros (cu' & tf & FIND' & TRANSF' & LINK'). econstructor; split. eapply exec_Icall; eauto. - apply sig_preserved; auto. - econstructor; eauto. + eapply sig_preserved; eauto. econstructor; eauto. + eapply match_stackframes_cons with (cu := cu); eauto. intros. eapply analysis_correct_1; eauto. simpl; auto. unfold transfer; rewrite H. exists (fun _ => Vundef); apply empty_numbering_holds. apply regs_lessdef_regs; auto. - (* Itailcall *) - exploit find_function_translated; eauto. intros [tf [FIND' TRANSF']]. + exploit find_function_translated; eauto. intros (cu' & tf & FIND' & TRANSF' & LINK'). exploit Mem.free_parallel_extends; eauto. intros [m'' [A B]]. econstructor; split. eapply exec_Itailcall; eauto. - apply sig_preserved; auto. + eapply sig_preserved; eauto. econstructor; eauto. apply regs_lessdef_regs; auto. @@ -1109,8 +1105,7 @@ Proof. econstructor; split. eapply exec_Ibuiltin; eauto. eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. - eapply external_call_symbols_preserved; eauto. - exact symbols_preserved. exact public_preserved. exact varinfo_preserved. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. econstructor; eauto. eapply analysis_correct_1; eauto. simpl; auto. * unfold transfer; rewrite H. @@ -1125,6 +1120,7 @@ Proof. destruct ef. + apply CASE1. + apply CASE3. + + apply CASE1. + apply CASE2; inv H1; auto. + apply CASE3. + apply CASE1. @@ -1133,7 +1129,7 @@ Proof. simpl in H1. inv H1. exists valu. apply set_res_unknown_holds. - inv SOUND. unfold vanalyze, rm; rewrite AN. + InvSoundState. unfold vanalyze; rewrite AN. assert (pmatch bc bsrc osrc (aaddr_arg (VA.State ae am) a0)) by (eapply aaddr_arg_sound_1; eauto). assert (pmatch bc bdst odst (aaddr_arg (VA.State ae am) a1)) @@ -1179,8 +1175,8 @@ Proof. destruct or; simpl; auto. - (* internal function *) - monadInv H6. unfold transf_function in EQ. - destruct (analyze f (vanalyze rm f)) as [approx|] eqn:?; inv EQ. + monadInv TFD. unfold transf_function in EQ. fold (analyze cu f) in EQ. + destruct (analyze cu f) as [approx|] eqn:?; inv EQ. exploit Mem.alloc_extends; eauto. apply Zle_refl. apply Zle_refl. intros (m'' & A & B). econstructor; split. @@ -1190,17 +1186,16 @@ Proof. apply init_regs_lessdef; auto. - (* external function *) - monadInv H6. + monadInv TFD. exploit external_call_mem_extends; eauto. intros (v' & m1' & P & Q & R & S). econstructor; split. eapply exec_function_external; eauto. - eapply external_call_symbols_preserved; eauto. - exact symbols_preserved. exact public_preserved. exact varinfo_preserved. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. econstructor; eauto. - (* return *) - inv H2. + inv STACK. econstructor; split. eapply exec_return; eauto. econstructor; eauto. @@ -1212,22 +1207,22 @@ Lemma transf_initial_states: exists st2, initial_state tprog st2 /\ match_states st1 st2. Proof. intros. inversion H. - exploit funct_ptr_translated; eauto. intros [tf [A B]]. + exploit funct_ptr_translated; eauto. intros (cu & tf & A & B & C). exists (Callstate nil tf nil m0); split. econstructor; eauto. - eapply Genv.init_mem_transf_partial; eauto. + eapply (Genv.init_mem_match TRANSF); eauto. replace (prog_main tprog) with (prog_main prog). rewrite symbols_preserved. eauto. - symmetry. eapply transform_partial_program_main; eauto. - rewrite <- H3. apply sig_preserved; auto. - constructor. constructor. auto. auto. apply Mem.extends_refl. + symmetry. eapply match_program_main; eauto. + rewrite <- H3. eapply sig_preserved; eauto. + econstructor. eauto. constructor. auto. auto. apply Mem.extends_refl. Qed. Lemma transf_final_states: forall st1 st2 r, match_states st1 st2 -> final_state st1 r -> final_state st2 r. Proof. - intros. inv H0. inv H. inv H5. inv H3. constructor. + intros. inv H0. inv H. inv RES. inv STACK. constructor. Qed. Theorem transf_program_correct: @@ -1235,7 +1230,7 @@ Theorem transf_program_correct: Proof. eapply forward_simulation_step with (match_states := fun s1 s2 => sound_state prog s1 /\ match_states s1 s2). -- eexact public_preserved. +- apply senv_preserved. - intros. exploit transf_initial_states; eauto. intros [s2 [A B]]. exists s2. split. auto. split. apply sound_initial; auto. auto. - intros. destruct H. eapply transf_final_states; eauto. diff --git a/backend/CleanupLabels.v b/backend/CleanupLabels.v index 759201b2..303fcb64 100644 --- a/backend/CleanupLabels.v +++ b/backend/CleanupLabels.v @@ -20,10 +20,8 @@ better-looking, the present pass removes labels that cannot be branched to. *) -Require Import FSets. -Require FSetAVL. -Require Import Coqlib. -Require Import Ordered. +Require Import FSets FSetAVL. +Require Import Coqlib Ordered. Require Import Linear. Module Labelset := FSetAVL.Make(OrderedPositive). diff --git a/backend/CleanupLabelsproof.v b/backend/CleanupLabelsproof.v index 6f33c9c2..a498a654 100644 --- a/backend/CleanupLabelsproof.v +++ b/backend/CleanupLabelsproof.v @@ -12,68 +12,51 @@ (** Correctness proof for clean-up of labels *) -Require Import Coqlib. -Require Import Ordered. Require Import FSets. -Require Import AST. -Require Import Integers. -Require Import Values. -Require Import Memory. -Require Import Events. -Require Import Globalenvs. -Require Import Smallstep. -Require Import Op. -Require Import Locations. -Require Import Linear. +Require Import Coqlib Ordered Integers. +Require Import AST Linking. +Require Import Values Memory Events Globalenvs Smallstep. +Require Import Op Locations Linear. Require Import CleanupLabels. Module LabelsetFacts := FSetFacts.Facts(Labelset). +Definition match_prog (p tp: Linear.program) := + match_program (fun ctx f tf => tf = transf_fundef f) eq p tp. + +Lemma transf_program_match: + forall p, match_prog p (transf_program p). +Proof. + intros. eapply match_transform_program; eauto. +Qed. + Section CLEANUP. -Variable prog: program. -Let tprog := transf_program prog. +Variables prog tprog: program. +Hypothesis TRANSL: match_prog prog tprog. Let ge := Genv.globalenv prog. Let tge := Genv.globalenv tprog. Lemma symbols_preserved: - forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. -Proof. - intros; unfold ge, tge, tprog, transf_program. - apply Genv.find_symbol_transf. -Qed. + forall id, + Genv.find_symbol tge id = Genv.find_symbol ge id. +Proof (Genv.find_symbol_transf TRANSL). -Lemma public_preserved: - forall (s: ident), Genv.public_symbol tge s = Genv.public_symbol ge s. -Proof. - intros; unfold ge, tge, tprog, transf_program. - apply Genv.public_symbol_transf. -Qed. - -Lemma varinfo_preserved: - forall b, Genv.find_var_info tge b = Genv.find_var_info ge b. -Proof. - intros; unfold ge, tge, tprog, transf_program. - apply Genv.find_var_info_transf. -Qed. +Lemma senv_preserved: + Senv.equiv ge tge. +Proof (Genv.senv_transf TRANSL). Lemma functions_translated: - forall (v: val) (f: fundef), + forall v f, Genv.find_funct ge v = Some f -> Genv.find_funct tge v = Some (transf_fundef f). -Proof. - intros. - exact (Genv.find_funct_transf transf_fundef _ _ H). -Qed. +Proof (Genv.find_funct_transf TRANSL). Lemma function_ptr_translated: - forall (b: block) (f: fundef), - Genv.find_funct_ptr ge b = Some f -> - Genv.find_funct_ptr tge b = Some (transf_fundef f). -Proof. - intros. - exact (Genv.find_funct_ptr_transf transf_fundef _ _ H). -Qed. + forall v f, + Genv.find_funct_ptr ge v = Some f -> + Genv.find_funct_ptr tge v = Some (transf_fundef f). +Proof (Genv.find_funct_ptr_transf TRANSL). Lemma sig_function_translated: forall f, @@ -293,8 +276,7 @@ Proof. left; econstructor; split. econstructor. eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. - eapply external_call_symbols_preserved; eauto. - exact symbols_preserved. exact public_preserved. exact varinfo_preserved. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. eauto. econstructor; eauto with coqlib. (* Llabel *) @@ -333,8 +315,7 @@ Proof. econstructor; eauto with coqlib. (* external function *) left; econstructor; split. - econstructor; eauto. eapply external_call_symbols_preserved'; eauto. - exact symbols_preserved. exact public_preserved. exact varinfo_preserved. + econstructor; eauto. eapply external_call_symbols_preserved'; eauto. apply senv_preserved. econstructor; eauto with coqlib. (* return *) inv H3. inv H1. left; econstructor; split. @@ -349,8 +330,8 @@ Proof. intros. inv H. econstructor; split. eapply initial_state_intro with (f := transf_fundef f). - eapply Genv.init_mem_transf; eauto. - rewrite symbols_preserved; eauto. + eapply (Genv.init_mem_transf TRANSL); eauto. + rewrite (match_program_main TRANSL), symbols_preserved; eauto. apply function_ptr_translated; auto. rewrite sig_function_translated. auto. constructor; auto. constructor. @@ -367,7 +348,7 @@ Theorem transf_program_correct: forward_simulation (Linear.semantics prog) (Linear.semantics tprog). Proof. eapply forward_simulation_opt. - eexact public_preserved. + apply senv_preserved. eexact transf_initial_states. eexact transf_final_states. eexact transf_step_correct. diff --git a/backend/Constprop.v b/backend/Constprop.v index 5ca69183..4de80b7a 100644 --- a/backend/Constprop.v +++ b/backend/Constprop.v @@ -14,21 +14,11 @@ performed at RTL level. It proceeds by a standard dataflow analysis and the corresponding code rewriting. *) -Require Import Coqlib. -Require Import Maps. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Op. -Require Machregs. -Require Import Registers. -Require Import RTL. -Require Import Lattice. -Require Import Kildall. -Require Import Liveness. -Require Import ValueDomain. -Require Import ValueAOp. -Require Import ValueAnalysis. +Require Import Coqlib Maps Integers Floats Lattice Kildall. +Require Import AST Linking. +Require Compopts Machregs. +Require Import Op Registers RTL. +Require Import Liveness ValueDomain ValueAOp ValueAnalysis. Require Import ConstpropOp. (** The code transformation builds on the results of the static analysis @@ -231,5 +221,5 @@ Definition transf_fundef (rm: romem) (fd: fundef) : fundef := AST.transf_fundef (transf_function rm) fd. Definition transf_program (p: program) : program := - let rm := romem_for_program p in + let rm := romem_for p in transform_program (transf_fundef rm) p. diff --git a/backend/Constpropproof.v b/backend/Constpropproof.v index ad9068ab..4e76c641 100644 --- a/backend/Constpropproof.v +++ b/backend/Constpropproof.v @@ -12,35 +12,30 @@ (** Correctness proof for constant propagation. *) -Require Import Coqlib. -Require Import Maps. -Require Compopts. -Require Import AST. -Require Import Integers. -Require Import Values. -Require Import Events. -Require Import Memory. -Require Import Globalenvs. -Require Import Smallstep. -Require Import Op. -Require Import Registers. -Require Import RTL. -Require Import Lattice. -Require Import Kildall. -Require Import ValueDomain. -Require Import ValueAOp. -Require Import ValueAnalysis. -Require Import ConstpropOp. -Require Import Constprop. -Require Import ConstpropOpproof. +Require Import Coqlib Maps Integers Floats Lattice Kildall. +Require Import AST Linking. +Require Import Values Events Memory Globalenvs Smallstep. +Require Compopts Machregs. +Require Import Op Registers RTL. +Require Import Liveness ValueDomain ValueAOp ValueAnalysis. +Require Import ConstpropOp ConstpropOpproof Constprop. + +Definition match_prog (prog tprog: program) := + match_program (fun cu f tf => tf = transf_fundef (romem_for cu) f) eq prog tprog. + +Lemma transf_program_match: + forall prog, match_prog prog (transf_program prog). +Proof. + intros. eapply match_transform_program_contextual. auto. +Qed. Section PRESERVATION. Variable prog: program. -Let tprog := transf_program prog. +Variable tprog: program. +Hypothesis TRANSL: match_prog prog tprog. Let ge := Genv.globalenv prog. Let tge := Genv.globalenv tprog. -Let rm := romem_for_program prog. (** * Correctness of the code transformation *) @@ -49,45 +44,32 @@ Let rm := romem_for_program prog. Lemma symbols_preserved: forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. -Proof. - intros; unfold ge, tge, tprog, transf_program. - apply Genv.find_symbol_transf. -Qed. - -Lemma public_preserved: - forall (s: ident), Genv.public_symbol tge s = Genv.public_symbol ge s. -Proof. - intros; unfold ge, tge, tprog, transf_program. - apply Genv.public_symbol_transf. -Qed. +Proof (Genv.find_symbol_match TRANSL). -Lemma varinfo_preserved: - forall b, Genv.find_var_info tge b = Genv.find_var_info ge b. -Proof. - intros; unfold ge, tge, tprog, transf_program. - apply Genv.find_var_info_transf. -Qed. +Lemma senv_preserved: + Senv.equiv ge tge. +Proof (Genv.senv_match TRANSL). Lemma functions_translated: forall (v: val) (f: fundef), Genv.find_funct ge v = Some f -> - Genv.find_funct tge v = Some (transf_fundef rm f). + exists cunit, Genv.find_funct tge v = Some (transf_fundef (romem_for cunit) f) /\ linkorder cunit prog. Proof. - intros. - exact (Genv.find_funct_transf (transf_fundef rm) _ _ H). + intros. exploit (Genv.find_funct_match TRANSL); eauto. + intros (cu & tf & A & B & C). subst tf. exists cu; auto. Qed. Lemma function_ptr_translated: forall (b: block) (f: fundef), Genv.find_funct_ptr ge b = Some f -> - Genv.find_funct_ptr tge b = Some (transf_fundef rm f). + exists cunit, Genv.find_funct_ptr tge b = Some (transf_fundef (romem_for cunit) f) /\ linkorder cunit prog. Proof. - intros. - exact (Genv.find_funct_ptr_transf (transf_fundef rm) _ _ H). + intros. exploit (Genv.find_funct_ptr_match TRANSL); eauto. + intros (cu & tf & A & B & C). subst tf. exists cu; auto. Qed. Lemma sig_function_translated: - forall f, + forall rm f, funsig (transf_fundef rm f) = funsig f. Proof. intros. destruct f; reflexivity. @@ -110,12 +92,17 @@ Lemma transf_ros_correct: ematch bc rs ae -> find_function ge ros rs = Some f -> regs_lessdef rs rs' -> - find_function tge (transf_ros ae ros) rs' = Some (transf_fundef rm f). + exists cunit, + find_function tge (transf_ros ae ros) rs' = Some (transf_fundef (romem_for cunit) f) + /\ linkorder cunit prog. Proof. intros until rs'; intros GE EM FF RLD. destruct ros; simpl in *. - (* function pointer *) generalize (EM r); fold (areg ae r); intro VM. generalize (RLD r); intro LD. - assert (DEFAULT: find_function tge (inl _ r) rs' = Some (transf_fundef rm f)). + assert (DEFAULT: + exists cunit, + find_function tge (inl _ r) rs' = Some (transf_fundef (romem_for cunit) f) + /\ linkorder cunit prog). { simpl. inv LD. apply functions_translated; auto. rewrite <- H0 in FF; discriminate. } @@ -162,35 +149,45 @@ Proof. eapply vmatch_ptr_stk; eauto. Qed. -Inductive match_pc (f: function) (ae: AE.t): nat -> node -> node -> Prop := +Inductive match_pc (f: function) (rs: regset) (m: mem): nat -> node -> node -> Prop := | match_pc_base: forall n pc, - match_pc f ae n pc pc + match_pc f rs m n pc pc | match_pc_nop: forall n pc s pcx, f.(fn_code)!pc = Some (Inop s) -> - match_pc f ae n s pcx -> - match_pc f ae (S n) pc pcx - | match_pc_cond: forall n pc cond args s1 s2 b pcx, + match_pc f rs m n s pcx -> + match_pc f rs m (S n) pc pcx + | match_pc_cond: forall n pc cond args s1 s2 pcx, f.(fn_code)!pc = Some (Icond cond args s1 s2) -> - resolve_branch (eval_static_condition cond (aregs ae args)) = Some b -> - match_pc f ae n (if b then s1 else s2) pcx -> - match_pc f ae (S n) pc pcx. + (forall b, + eval_condition cond rs##args m = Some b -> + match_pc f rs m n (if b then s1 else s2) pcx) -> + match_pc f rs m (S n) pc pcx. Lemma match_successor_rec: - forall f ae n pc, match_pc f ae n pc (successor_rec n f ae pc). + forall f rs m bc ae, + ematch bc rs ae -> + forall n pc, + match_pc f rs m n pc (successor_rec n f ae pc). Proof. induction n; simpl; intros. - apply match_pc_base. - destruct (fn_code f)!pc as [[]|] eqn:INSTR; try apply match_pc_base. - eapply match_pc_nop; eauto. - destruct (resolve_branch (eval_static_condition c (aregs ae l))) as [b|] eqn:COND. - eapply match_pc_cond; eauto. - apply match_pc_base. ++ eapply match_pc_nop; eauto. ++ destruct (resolve_branch (eval_static_condition c (aregs ae l))) as [b|] eqn:STATIC; + try apply match_pc_base. + eapply match_pc_cond; eauto. intros b' DYNAMIC. + assert (b = b'). + { eapply resolve_branch_sound; eauto. + rewrite <- DYNAMIC. apply eval_static_condition_sound with bc. + apply aregs_sound; auto. } + subst b'. apply IHn. Qed. Lemma match_successor: - forall f ae pc, match_pc f ae num_iter pc (successor f ae pc). + forall f rs m bc ae pc, + ematch bc rs ae -> match_pc f rs m num_iter pc (successor f ae pc). Proof. - unfold successor; intros. apply match_successor_rec. + intros. eapply match_successor_rec; eauto. Qed. Lemma builtin_arg_reduction_correct: @@ -300,29 +297,31 @@ Qed. Inductive match_stackframes: stackframe -> stackframe -> Prop := match_stackframe_intro: - forall res sp pc rs f rs', + forall res sp pc rs f rs' cu, + linkorder cu prog -> regs_lessdef rs rs' -> match_stackframes (Stackframe res f sp pc rs) - (Stackframe res (transf_function rm f) sp pc rs'). + (Stackframe res (transf_function (romem_for cu) f) sp pc rs'). Inductive match_states: nat -> state -> state -> Prop := | match_states_intro: - forall s sp pc rs m f s' pc' rs' m' bc ae n - (MATCH: ematch bc rs ae) + forall s sp pc rs m f s' pc' rs' m' cu n + (LINK: linkorder cu prog) (STACKS: list_forall2 match_stackframes s s') - (PC: match_pc f ae n pc pc') + (PC: match_pc f rs m n pc pc') (REGS: regs_lessdef rs rs') (MEM: Mem.extends m m'), match_states n (State s f sp pc rs m) - (State s' (transf_function rm f) sp pc' rs' m') + (State s' (transf_function (romem_for cu) f) sp pc' rs' m') | match_states_call: - forall s f args m s' args' m' + forall s f args m s' args' m' cu + (LINK: linkorder cu prog) (STACKS: list_forall2 match_stackframes s s') (ARGS: Val.lessdef_list args args') (MEM: Mem.extends m m'), match_states O (Callstate s f args m) - (Callstate s' (transf_fundef rm f) args' m') + (Callstate s' (transf_fundef (romem_for cu) f) args' m') | match_states_return: forall s v m s' v' m' (STACKS: list_forall2 match_stackframes s s') @@ -333,21 +332,19 @@ Inductive match_states: nat -> state -> state -> Prop := (Returnstate s' v' m'). Lemma match_states_succ: - forall s f sp pc rs m s' rs' m', - sound_state prog (State s f sp pc rs m) -> + forall s f sp pc rs m s' rs' m' cu, + linkorder cu prog -> list_forall2 match_stackframes s s' -> regs_lessdef rs rs' -> Mem.extends m m' -> match_states O (State s f sp pc rs m) - (State s' (transf_function rm f) sp pc rs' m'). + (State s' (transf_function (romem_for cu) f) sp pc rs' m'). Proof. - intros. inv H. - apply match_states_intro with (bc := bc) (ae := ae); auto. - constructor. + intros. apply match_states_intro; auto. constructor. Qed. Lemma transf_instr_at: - forall f pc i, + forall rm f pc i, f.(fn_code)!pc = Some i -> (transf_function rm f).(fn_code)!pc = Some(transf_instr f (analyze rm f) rm pc i). Proof. @@ -357,8 +354,8 @@ Qed. Ltac TransfInstr := match goal with | H1: (PTree.get ?pc (fn_code ?f) = Some ?instr), - H2: (analyze (romem_for_program prog) ?f)#?pc = VA.State ?ae ?am |- _ => - fold rm in H2; generalize (transf_instr_at _ _ _ H1); unfold transf_instr; rewrite H2 + H2: (analyze ?rm ?f)#?pc = VA.State ?ae ?am |- _ => + generalize (transf_instr_at rm _ _ _ H1); unfold transf_instr; rewrite H2 end. (** The proof of simulation proceeds by case analysis on the transition @@ -367,38 +364,38 @@ Ltac TransfInstr := Lemma transf_step_correct: forall s1 t s2, step ge s1 t s2 -> - forall n1 s1' (SS1: sound_state prog s1) (SS2: sound_state prog s2) (MS: match_states n1 s1 s1'), + forall n1 s1' (SS: sound_state prog s1) (MS: match_states n1 s1 s1'), (exists n2, exists s2', step tge s1' t s2' /\ match_states n2 s2 s2') \/ (exists n2, n2 < n1 /\ t = E0 /\ match_states n2 s2 s1')%nat. Proof. - induction 1; intros; inv SS1; inv MS; try (inv PC; try congruence). + induction 1; intros; inv MS; try InvSoundState; try (inv PC; try congruence). - (* Inop, preserved *) +- (* Inop, preserved *) rename pc'0 into pc. TransfInstr; intros. left; econstructor; econstructor; split. eapply exec_Inop; eauto. eapply match_states_succ; eauto. - (* Inop, skipped over *) +- (* Inop, skipped over *) assert (s0 = pc') by congruence. subst s0. right; exists n; split. omega. split. auto. - apply match_states_intro with bc0 ae0; auto. + apply match_states_intro; auto. - (* Iop *) +- (* Iop *) rename pc'0 into pc. TransfInstr. set (a := eval_static_operation op (aregs ae args)). set (ae' := AE.set res a ae). assert (VMATCH: vmatch bc v a) by (eapply eval_static_operation_sound; eauto with va). assert (MATCH': ematch bc (rs#res <- v) ae') by (eapply ematch_update; eauto). destruct (const_for_result a) as [cop|] eqn:?; intros. - (* constant is propagated *) ++ (* constant is propagated *) exploit const_for_result_correct; eauto. intros (v' & A & B). left; econstructor; econstructor; split. eapply exec_Iop; eauto. - apply match_states_intro with bc ae'; auto. - apply match_successor. + apply match_states_intro; auto. + eapply match_successor; eauto. apply set_reg_lessdef; auto. - (* operator is strength-reduced *) ++ (* operator is strength-reduced *) assert(OP: let (op', args') := op_strength_reduction op args (aregs ae args) in exists v', @@ -413,24 +410,24 @@ Proof. left; econstructor; econstructor; split. eapply exec_Iop; eauto. erewrite eval_operation_preserved. eexact EV''. exact symbols_preserved. - apply match_states_intro with bc ae'; auto. - apply match_successor. + apply match_states_intro; auto. + eapply match_successor; eauto. apply set_reg_lessdef; auto. eapply Val.lessdef_trans; eauto. - (* Iload *) +- (* Iload *) rename pc'0 into pc. TransfInstr. set (aa := eval_static_addressing addr (aregs ae args)). assert (VM1: vmatch bc a aa) by (eapply eval_static_addressing_sound; eauto with va). - set (av := loadv chunk rm am aa). + set (av := loadv chunk (romem_for cu) am aa). assert (VM2: vmatch bc v av) by (eapply loadv_sound; eauto). destruct (const_for_result av) as [cop|] eqn:?; intros. - (* constant-propagated *) ++ (* constant-propagated *) exploit const_for_result_correct; eauto. intros (v' & A & B). left; econstructor; econstructor; split. eapply exec_Iop; eauto. eapply match_states_succ; eauto. apply set_reg_lessdef; auto. - (* strength-reduced *) ++ (* strength-reduced *) assert (ADDR: let (addr', args') := addr_strength_reduction addr args (aregs ae args) in exists a', @@ -449,7 +446,7 @@ Proof. eapply exec_Iload; eauto. eapply match_states_succ; eauto. apply set_reg_lessdef; auto. - (* Istore *) +- (* Istore *) rename pc'0 into pc. TransfInstr. assert (ADDR: let (addr', args') := addr_strength_reduction addr args (aregs ae args) in @@ -469,9 +466,9 @@ Proof. eapply exec_Istore; eauto. eapply match_states_succ; eauto. - (* Icall *) +- (* Icall *) rename pc'0 into pc. - exploit transf_ros_correct; eauto. intro FIND'. + exploit transf_ros_correct; eauto. intros (cu' & FIND & LINK'). TransfInstr; intro. left; econstructor; econstructor; split. eapply exec_Icall; eauto. apply sig_function_translated; auto. @@ -479,17 +476,17 @@ Proof. econstructor; eauto. apply regs_lessdef_regs; auto. - (* Itailcall *) +- (* Itailcall *) exploit Mem.free_parallel_extends; eauto. intros [m2' [A B]]. - exploit transf_ros_correct; eauto. intros FIND'. + exploit transf_ros_correct; eauto. intros (cu' & FIND & LINK'). TransfInstr; intro. left; econstructor; econstructor; split. eapply exec_Itailcall; eauto. apply sig_function_translated; auto. constructor; auto. apply regs_lessdef_regs; auto. - (* Ibuiltin *) - rename pc'0 into pc. clear MATCH. TransfInstr; intros. +- (* Ibuiltin *) + rename pc'0 into pc. TransfInstr; intros. Opaque builtin_strength_reduction. exploit builtin_strength_reduction_correct; eauto. intros (vargs' & P & Q). exploit (@eval_builtin_args_lessdef _ ge (fun r => rs#r) (fun r => rs'#r)). @@ -500,13 +497,12 @@ Opaque builtin_strength_reduction. left; econstructor; econstructor; split. eapply exec_Ibuiltin; eauto. eapply eval_builtin_args_preserved. eexact symbols_preserved. eauto. - eapply external_call_symbols_preserved; eauto. - exact symbols_preserved. exact public_preserved. exact varinfo_preserved. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. eapply match_states_succ; eauto. apply set_res_lessdef; auto. - (* Icond, preserved *) - rename pc' into pc. TransfInstr. +- (* Icond, preserved *) + rename pc'0 into pc. TransfInstr. set (ac := eval_static_condition cond (aregs ae args)). assert (C: cmatch (eval_condition cond rs ## args m) ac) by (eapply eval_static_condition_sound; eauto with va). @@ -514,7 +510,7 @@ Opaque builtin_strength_reduction. generalize (cond_strength_reduction_correct bc ae rs m EM cond args (aregs ae args) (refl_equal _)). destruct (cond_strength_reduction cond args (aregs ae args)) as [cond' args']. intros EV1 TCODE. - left; exists O; exists (State s' (transf_function rm f) (Vptr sp0 Int.zero) (if b then ifso else ifnot) rs' m'); split. + left; exists O; exists (State s' (transf_function (romem_for cu) f) (Vptr sp0 Int.zero) (if b then ifso else ifnot) rs' m'); split. destruct (resolve_branch ac) eqn: RB. assert (b0 = b) by (eapply resolve_branch_sound; eauto). subst b0. destruct b; eapply exec_Inop; eauto. @@ -522,20 +518,15 @@ Opaque builtin_strength_reduction. eapply eval_condition_lessdef with (vl1 := rs##args'); eauto. eapply regs_lessdef_regs; eauto. congruence. eapply match_states_succ; eauto. - (* Icond, skipped over *) +- (* Icond, skipped over *) rewrite H1 in H; inv H. - set (ac := eval_static_condition cond (aregs ae0 args)) in *. - assert (C: cmatch (eval_condition cond rs ## args m) ac) - by (eapply eval_static_condition_sound; eauto with va). - rewrite H0 in C. - assert (b0 = b) by (eapply resolve_branch_sound; eauto). subst b0. - right; exists n; split. omega. split. auto. + right; exists n; split. omega. split. auto. econstructor; eauto. - (* Ijumptable *) +- (* Ijumptable *) rename pc'0 into pc. - assert (A: (fn_code (transf_function rm f))!pc = Some(Ijumptable arg tbl) - \/ (fn_code (transf_function rm f))!pc = Some(Inop pc')). + assert (A: (fn_code (transf_function (romem_for cu) f))!pc = Some(Ijumptable arg tbl) + \/ (fn_code (transf_function (romem_for cu) f))!pc = Some(Inop pc')). { TransfInstr. destruct (areg ae arg) eqn:A; auto. generalize (EM arg). fold (areg ae arg); rewrite A. @@ -543,23 +534,20 @@ Opaque builtin_strength_reduction. rewrite H1. auto. } assert (rs'#arg = Vint n). { generalize (REGS arg). rewrite H0. intros LD; inv LD; auto. } - left; exists O; exists (State s' (transf_function rm f) (Vptr sp0 Int.zero) pc' rs' m'); split. + left; exists O; exists (State s' (transf_function (romem_for cu) f) (Vptr sp0 Int.zero) pc' rs' m'); split. destruct A. eapply exec_Ijumptable; eauto. eapply exec_Inop; eauto. eapply match_states_succ; eauto. - (* Ireturn *) +- (* Ireturn *) exploit Mem.free_parallel_extends; eauto. intros [m2' [A B]]. left; exists O; exists (Returnstate s' (regmap_optget or Vundef rs') m2'); split. eapply exec_Ireturn; eauto. TransfInstr; auto. constructor; auto. destruct or; simpl; auto. - (* internal function *) +- (* internal function *) exploit Mem.alloc_extends. eauto. eauto. apply Zle_refl. apply Zle_refl. intros [m2' [A B]]. - assert (X: exists bc ae, ematch bc (init_regs args (fn_params f)) ae). - { inv SS2. exists bc0; exists ae; auto. } - destruct X as (bc1 & ae1 & MATCH). simpl. unfold transf_function. left; exists O; econstructor; split. eapply exec_function_internal; simpl; eauto. @@ -567,19 +555,15 @@ Opaque builtin_strength_reduction. constructor. apply init_regs_lessdef; auto. - (* external function *) +- (* external function *) exploit external_call_mem_extends; eauto. intros [v' [m2' [A [B [C D]]]]]. simpl. left; econstructor; econstructor; split. eapply exec_function_external; eauto. - eapply external_call_symbols_preserved; eauto. - exact symbols_preserved. exact public_preserved. exact varinfo_preserved. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. constructor; auto. - (* return *) - assert (X: exists bc ae, ematch bc (rs#res <- vres) ae). - { inv SS2. exists bc0; exists ae; auto. } - destruct X as (bc1 & ae1 & MATCH). +- (* return *) inv H4. inv H1. left; exists O; econstructor; split. eapply exec_return; eauto. @@ -591,15 +575,15 @@ Lemma transf_initial_states: exists n, exists st2, initial_state tprog st2 /\ match_states n st1 st2. Proof. intros. inversion H. - exploit function_ptr_translated; eauto. intro FIND. - exists O; exists (Callstate nil (transf_fundef rm f) nil m0); split. + exploit function_ptr_translated; eauto. intros (cu & FIND & LINK). + exists O; exists (Callstate nil (transf_fundef (romem_for cu) f) nil m0); split. econstructor; eauto. - apply Genv.init_mem_transf; auto. + apply (Genv.init_mem_match TRANSL); auto. replace (prog_main tprog) with (prog_main prog). rewrite symbols_preserved. eauto. - reflexivity. + symmetry; eapply match_program_main; eauto. rewrite <- H3. apply sig_function_translated. - constructor. constructor. constructor. apply Mem.extends_refl. + constructor. auto. constructor. constructor. apply Mem.extends_refl. Qed. Lemma transf_final_states: @@ -615,9 +599,7 @@ Qed. Theorem transf_program_correct: forward_simulation (RTL.semantics prog) (RTL.semantics tprog). Proof. - apply Forward_simulation with - (fsim_order := lt) - (fsim_match_states := fun n s1 s2 => sound_state prog s1 /\ match_states n s1 s2). + apply Forward_simulation with lt (fun n s1 s2 => sound_state prog s1 /\ match_states n s1 s2); constructor. - apply lt_wf. - simpl; intros. exploit transf_initial_states; eauto. intros (n & st2 & A & B). exists n, st2; intuition. eapply sound_initial; eauto. @@ -629,7 +611,7 @@ Proof. intros [ [n2 [s2' [A B]]] | [n2 [A [B C]]]]. exists n2; exists s2'; split; auto. left; apply plus_one; auto. exists n2; exists s2; split; auto. right; split; auto. subst t; apply star_refl. -- eexact public_preserved. +- apply senv_preserved. Qed. End PRESERVATION. diff --git a/backend/Deadcode.v b/backend/Deadcode.v index fa99915d..e5b2ce3a 100644 --- a/backend/Deadcode.v +++ b/backend/Deadcode.v @@ -12,22 +12,10 @@ (** Elimination of unneeded computations over RTL. *) -Require Import Coqlib. -Require Import Errors. -Require Import Maps. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Memory. -Require Import Registers. -Require Import Op. -Require Import RTL. -Require Import Lattice. -Require Import Kildall. -Require Import ValueDomain. -Require Import ValueAnalysis. -Require Import NeedDomain. -Require Import NeedOp. +Require Import Coqlib Maps Errors Integers Floats Lattice Kildall. +Require Import AST Linking. +Require Import Memory Registers Op RTL. +Require Import ValueDomain ValueAnalysis NeedDomain NeedOp. (** * Part 1: the static analysis *) @@ -205,10 +193,8 @@ Definition transf_instr (approx: PMap.t VA.t) (an: PMap.t NA.t) instr end. -Definition vanalyze := ValueAnalysis.analyze. - Definition transf_function (rm: romem) (f: function) : res function := - let approx := vanalyze rm f in + let approx := ValueAnalysis.analyze rm f in match analyze approx f with | Some an => OK {| fn_sig := f.(fn_sig); @@ -220,10 +206,9 @@ Definition transf_function (rm: romem) (f: function) : res function := Error (msg "Neededness analysis failed") end. - Definition transf_fundef (rm: romem) (fd: fundef) : res fundef := AST.transf_partial_fundef (transf_function rm) fd. Definition transf_program (p: program) : res program := - transform_partial_program (transf_fundef (romem_for_program p)) p. + transform_partial_program (transf_fundef (romem_for p)) p. diff --git a/backend/Deadcodeproof.v b/backend/Deadcodeproof.v index 6bbf0ae7..72881b94 100644 --- a/backend/Deadcodeproof.v +++ b/backend/Deadcodeproof.v @@ -12,28 +12,20 @@ (** Elimination of unneeded computations over RTL: correctness proof. *) -Require Import Coqlib. -Require Import Errors. -Require Import Maps. -Require Import IntvSets. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import Memory. -Require Import Globalenvs. -Require Import Events. -Require Import Smallstep. -Require Import Op. -Require Import Registers. -Require Import RTL. -Require Import Lattice. -Require Import Kildall. -Require Import ValueDomain. -Require Import ValueAnalysis. -Require Import NeedDomain. -Require Import NeedOp. -Require Import Deadcode. +Require Import Coqlib Maps Errors Integers Floats Lattice Kildall. +Require Import AST Linking. +Require Import Values Memory Globalenvs Events Smallstep. +Require Import Registers Op RTL. +Require Import ValueDomain ValueAnalysis NeedDomain NeedOp Deadcode. + +Definition match_prog (prog tprog: RTL.program) := + match_program (fun cu f tf => transf_fundef (romem_for cu) f = OK tf) eq prog tprog. + +Lemma transf_program_match: + forall prog tprog, transf_program prog = OK tprog -> match_prog prog tprog. +Proof. + intros. eapply match_transform_partial_program_contextual; eauto. +Qed. (** * Relating the memory states *) @@ -378,75 +370,61 @@ Section PRESERVATION. Variable prog: program. Variable tprog: program. -Hypothesis TRANSF: transf_program prog = OK tprog. +Hypothesis TRANSF: match_prog prog tprog. Let ge := Genv.globalenv prog. Let tge := Genv.globalenv tprog. -Let rm := romem_for_program prog. Lemma symbols_preserved: forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. -Proof. - intro. unfold ge, tge. - apply Genv.find_symbol_transf_partial with (transf_fundef rm). - exact TRANSF. -Qed. - -Lemma public_preserved: - forall (s: ident), Genv.public_symbol tge s = Genv.public_symbol ge s. -Proof. - intro. unfold ge, tge. - apply Genv.public_symbol_transf_partial with (transf_fundef rm). - exact TRANSF. -Qed. +Proof (Genv.find_symbol_match TRANSF). -Lemma varinfo_preserved: - forall b, Genv.find_var_info tge b = Genv.find_var_info ge b. -Proof. - intro. unfold ge, tge. - apply Genv.find_var_info_transf_partial with (transf_fundef rm). - exact TRANSF. -Qed. +Lemma senv_preserved: + Senv.equiv ge tge. +Proof (Genv.senv_match TRANSF). Lemma functions_translated: forall (v: val) (f: RTL.fundef), Genv.find_funct ge v = Some f -> - exists tf, - Genv.find_funct tge v = Some tf /\ transf_fundef rm f = OK tf. -Proof (Genv.find_funct_transf_partial (transf_fundef rm) _ TRANSF). + exists cu tf, + Genv.find_funct tge v = Some tf /\ transf_fundef (romem_for cu) f = OK tf /\ linkorder cu prog. +Proof (Genv.find_funct_match 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 rm f = OK tf. -Proof (Genv.find_funct_ptr_transf_partial (transf_fundef rm) _ TRANSF). + exists cu tf, + Genv.find_funct_ptr tge b = Some tf /\ transf_fundef (romem_for cu) f = OK tf /\ linkorder cu prog. +Proof (Genv.find_funct_ptr_match TRANSF). Lemma sig_function_translated: - forall f tf, + forall rm f tf, transf_fundef rm f = OK tf -> funsig tf = funsig f. Proof. intros; destruct f; monadInv H. unfold transf_function in EQ. - destruct (analyze (vanalyze rm f) f); inv EQ; auto. + destruct (analyze (ValueAnalysis.analyze rm f) f); inv EQ; auto. auto. Qed. Lemma stacksize_translated: - forall f tf, + forall rm f tf, transf_function rm f = OK tf -> tf.(fn_stacksize) = f.(fn_stacksize). Proof. - unfold transf_function; intros. destruct (analyze (vanalyze rm f) f); inv H; auto. + unfold transf_function; intros. destruct (analyze (ValueAnalysis.analyze rm f) f); inv H; auto. Qed. +Definition vanalyze (cu: program) (f: function) := + ValueAnalysis.analyze (romem_for cu) f. + Lemma transf_function_at: - forall f tf an pc instr, - transf_function rm f = OK tf -> - analyze (vanalyze rm f) f = Some an -> + forall cu f tf an pc instr, + transf_function (romem_for cu) f = OK tf -> + analyze (vanalyze cu f) f = Some an -> f.(fn_code)!pc = Some instr -> - tf.(fn_code)!pc = Some(transf_instr (vanalyze rm f) an pc instr). + tf.(fn_code)!pc = Some(transf_instr (vanalyze cu f) an pc instr). Proof. - intros. unfold transf_function in H. rewrite H0 in H. inv H; simpl. + intros. unfold transf_function in H. unfold vanalyze in H0. rewrite H0 in H. inv H; simpl. rewrite PTree.gmap. rewrite H1; auto. Qed. @@ -475,7 +453,10 @@ Lemma find_function_translated: forall ros rs fd trs ne, find_function ge ros rs = Some fd -> eagree rs trs (add_ros_need_all ros ne) -> - exists tfd, find_function tge ros trs = Some tfd /\ transf_fundef rm fd = OK tfd. + exists cu tfd, + find_function tge ros trs = Some tfd + /\ transf_fundef (romem_for cu) fd = OK tfd + /\ linkorder cu prog. Proof. intros. destruct ros as [r|id]; simpl in *. - assert (LD: Val.lessdef rs#r trs#r) by eauto with na. inv LD. @@ -489,30 +470,33 @@ Qed. Inductive match_stackframes: stackframe -> stackframe -> Prop := | match_stackframes_intro: - forall res f sp pc e tf te an - (FUN: transf_function rm f = OK tf) - (ANL: analyze (vanalyze rm f) f = Some an) + forall res f sp pc e tf te cu an + (LINK: linkorder cu prog) + (FUN: transf_function (romem_for cu) f = OK tf) + (ANL: analyze (vanalyze cu f) f = Some an) (RES: forall v tv, Val.lessdef v tv -> eagree (e#res <- v) (te#res<- tv) - (fst (transfer f (vanalyze rm f) pc an!!pc))), + (fst (transfer f (vanalyze cu f) pc an!!pc))), match_stackframes (Stackframe res f (Vptr sp Int.zero) pc e) (Stackframe res tf (Vptr sp Int.zero) pc te). Inductive match_states: state -> state -> Prop := | match_regular_states: - forall s f sp pc e m ts tf te tm an + forall s f sp pc e m ts tf te tm cu an (STACKS: list_forall2 match_stackframes s ts) - (FUN: transf_function rm f = OK tf) - (ANL: analyze (vanalyze rm f) f = Some an) - (ENV: eagree e te (fst (transfer f (vanalyze rm f) pc an!!pc))) - (MEM: magree m tm (nlive ge sp (snd (transfer f (vanalyze rm f) pc an!!pc)))), + (LINK: linkorder cu prog) + (FUN: transf_function (romem_for cu) f = OK tf) + (ANL: analyze (vanalyze cu f) f = Some an) + (ENV: eagree e te (fst (transfer f (vanalyze cu f) pc an!!pc))) + (MEM: magree m tm (nlive ge sp (snd (transfer f (vanalyze cu f) pc an!!pc)))), match_states (State s f (Vptr sp Int.zero) pc e m) (State ts tf (Vptr sp Int.zero) pc te tm) | match_call_states: - forall s f args m ts tf targs tm + forall s f args m ts tf targs tm cu (STACKS: list_forall2 match_stackframes s ts) - (FUN: transf_fundef rm f = OK tf) + (LINK: linkorder cu prog) + (FUN: transf_fundef (romem_for cu) f = OK tf) (ARGS: Val.lessdef_list args targs) (MEM: Mem.extends m tm), match_states (Callstate s f args m) @@ -528,21 +512,22 @@ Inductive match_states: state -> state -> Prop := (** [match_states] and CFG successors *) Lemma analyze_successors: - forall f an pc instr pc', - analyze (vanalyze rm f) f = Some an -> + forall cu f an pc instr pc', + analyze (vanalyze cu f) f = Some an -> f.(fn_code)!pc = Some instr -> In pc' (successors_instr instr) -> - NA.ge an!!pc (transfer f (vanalyze rm f) pc' an!!pc'). + NA.ge an!!pc (transfer f (vanalyze cu f) pc' an!!pc'). Proof. intros. eapply DS.fixpoint_solution; eauto. intros. unfold transfer; rewrite H2. destruct a. apply DS.L.eq_refl. Qed. Lemma match_succ_states: - forall s f sp pc e m ts tf te tm an pc' instr ne nm + forall s f sp pc e m ts tf te tm an pc' cu instr ne nm + (LINK: linkorder cu prog) (STACKS: list_forall2 match_stackframes s ts) - (FUN: transf_function rm f = OK tf) - (ANL: analyze (vanalyze rm f) f = Some an) + (FUN: transf_function (romem_for cu) f = OK tf) + (ANL: analyze (vanalyze cu f) f = Some an) (INSTR: f.(fn_code)!pc = Some instr) (SUCC: In pc' (successors_instr instr)) (ANPC: an!!pc = (ne, nm)) @@ -720,7 +705,7 @@ Ltac TransfInstr := | [INSTR: (fn_code _)!_ = Some _, FUN: transf_function _ _ = OK _, ANL: analyze _ _ = Some _ |- _ ] => - generalize (transf_function_at _ _ _ _ _ FUN ANL INSTR); + generalize (transf_function_at _ _ _ _ _ _ FUN ANL INSTR); intro TI; unfold transf_instr in TI end. @@ -825,7 +810,7 @@ Ltac UseTransfer := - (* store *) TransfInstr; UseTransfer. - destruct (nmem_contains nm (aaddressing (vanalyze rm f) # pc addr args) + destruct (nmem_contains nm (aaddressing (vanalyze cu f) # pc addr args) (size_chunk chunk)) eqn:CONTAINS. + (* preserved *) simpl in *. @@ -854,39 +839,41 @@ Ltac UseTransfer := - (* call *) TransfInstr; UseTransfer. - exploit find_function_translated; eauto 2 with na. intros (tfd & A & B). + exploit find_function_translated; eauto 2 with na. intros (cu' & tfd & A & B & C). econstructor; split. - eapply exec_Icall; eauto. apply sig_function_translated; auto. - constructor. - constructor; auto. econstructor; eauto. + eapply exec_Icall; eauto. eapply sig_function_translated; eauto. + eapply match_call_states with (cu := cu'); eauto. + constructor; auto. eapply match_stackframes_intro with (cu := cu); eauto. intros. edestruct analyze_successors; eauto. simpl; eauto. eapply eagree_ge; eauto. rewrite ANPC. simpl. apply eagree_update; eauto with na. - auto. eauto 2 with na. eapply magree_extends; eauto. apply nlive_all. + eauto 2 with na. + eapply magree_extends; eauto. apply nlive_all. - (* tailcall *) TransfInstr; UseTransfer. - exploit find_function_translated; eauto 2 with na. intros (tfd & A & B). + exploit find_function_translated; eauto 2 with na. intros (cu' & tfd & A & B & L). exploit magree_free. eauto. eauto. instantiate (1 := nlive ge stk nmem_all). intros; eapply nlive_dead_stack; eauto. intros (tm' & C & D). econstructor; split. - eapply exec_Itailcall; eauto. apply sig_function_translated; auto. + eapply exec_Itailcall; eauto. eapply sig_function_translated; eauto. erewrite stacksize_translated by eauto. eexact C. - constructor; eauto 2 with na. eapply magree_extends; eauto. apply nlive_all. + eapply match_call_states with (cu := cu'); eauto 2 with na. + eapply magree_extends; eauto. apply nlive_all. - (* builtin *) TransfInstr; UseTransfer. revert ENV MEM TI. - functional induction (transfer_builtin (vanalyze rm f)#pc ef args res ne nm); + functional induction (transfer_builtin (vanalyze cu f)#pc ef args res ne nm); simpl in *; intros. + (* volatile load *) inv H0. inv H6. rename b1 into v1. destruct (transfer_builtin_arg All (kill_builtin_res res ne, - nmem_add nm (aaddr_arg (vanalyze rm f) # pc a1) + nmem_add nm (aaddr_arg (vanalyze cu f) # pc a1) (size_chunk chunk)) a1) as (ne1, nm1) eqn: TR. - inversion SS; subst. exploit transfer_builtin_arg_sound; eauto. + InvSoundState. exploit transfer_builtin_arg_sound; eauto. intros (tv1 & A & B & C & D). inv H1. simpl in B. inv B. assert (X: exists tvres, volatile_load ge chunk tm b ofs t tvres /\ Val.lessdef vres tvres). @@ -904,9 +891,8 @@ Ltac UseTransfer := eapply exec_Ibuiltin; eauto. apply eval_builtin_args_preserved with (ge1 := ge). exact symbols_preserved. constructor. eauto. constructor. - eapply external_call_symbols_preserved. + eapply external_call_symbols_preserved. apply senv_preserved. constructor. simpl. eauto. - exact symbols_preserved. exact public_preserved. exact varinfo_preserved. eapply match_succ_states; eauto. simpl; auto. apply eagree_set_res; auto. eapply magree_monotone; eauto. intros. apply incl_nmem_add; auto. @@ -915,7 +901,7 @@ Ltac UseTransfer := destruct (transfer_builtin_arg (store_argument chunk) (kill_builtin_res res ne, nm) a2) as (ne2, nm2) eqn: TR2. destruct (transfer_builtin_arg All (ne2, nm2) a1) as (ne1, nm1) eqn: TR1. - inversion SS; subst. + InvSoundState. exploit transfer_builtin_arg_sound. eexact H4. eauto. eauto. eauto. eauto. eauto. intros (tv1 & A1 & B1 & C1 & D1). exploit transfer_builtin_arg_sound. eexact H3. eauto. eauto. eauto. eauto. eauto. @@ -926,21 +912,21 @@ Ltac UseTransfer := eapply exec_Ibuiltin; eauto. apply eval_builtin_args_preserved with (ge1 := ge). exact symbols_preserved. constructor. eauto. constructor. eauto. constructor. - eapply external_call_symbols_preserved. simpl; eauto. - exact symbols_preserved. exact public_preserved. exact varinfo_preserved. + eapply external_call_symbols_preserved. apply senv_preserved. + simpl; eauto. eapply match_succ_states; eauto. simpl; auto. apply eagree_set_res; auto. + (* memcpy *) rewrite e1 in TI. inv H0. inv H6. inv H7. rename b1 into v1. rename b0 into v2. - set (adst := aaddr_arg (vanalyze rm f) # pc dst) in *. - set (asrc := aaddr_arg (vanalyze rm f) # pc src) in *. + set (adst := aaddr_arg (vanalyze cu f) # pc dst) in *. + set (asrc := aaddr_arg (vanalyze cu f) # pc src) in *. destruct (transfer_builtin_arg All (kill_builtin_res res ne, nmem_add (nmem_remove nm adst sz) asrc sz) dst) as (ne2, nm2) eqn: TR2. destruct (transfer_builtin_arg All (ne2, nm2) src) as (ne1, nm1) eqn: TR1. - inversion SS; subst. + InvSoundState. exploit transfer_builtin_arg_sound. eexact H3. eauto. eauto. eauto. eauto. eauto. intros (tv1 & A1 & B1 & C1 & D1). exploit transfer_builtin_arg_sound. eexact H4. eauto. eauto. eauto. eauto. eauto. @@ -948,7 +934,7 @@ Ltac UseTransfer := inv H1. exploit magree_loadbytes. eauto. eauto. intros. eapply nlive_add; eauto. - unfold asrc, vanalyze, rm; rewrite AN; eapply aaddr_arg_sound_1; eauto. + unfold asrc, vanalyze; rewrite AN; eapply aaddr_arg_sound_1; eauto. intros (tbytes & P & Q). exploit magree_storebytes_parallel. eapply magree_monotone. eexact D2. @@ -957,7 +943,7 @@ Ltac UseTransfer := eauto. instantiate (1 := nlive ge sp0 nm). intros. eapply nlive_remove; eauto. - unfold adst, vanalyze, rm; rewrite AN; eapply aaddr_arg_sound_1; eauto. + unfold adst, vanalyze; rewrite AN; eapply aaddr_arg_sound_1; eauto. erewrite Mem.loadbytes_length in H1 by eauto. rewrite nat_of_Z_eq in H1 by omega. auto. eauto. @@ -966,51 +952,49 @@ Ltac UseTransfer := eapply exec_Ibuiltin; eauto. apply eval_builtin_args_preserved with (ge1 := ge). exact symbols_preserved. constructor. eauto. constructor. eauto. constructor. - eapply external_call_symbols_preserved. simpl. + eapply external_call_symbols_preserved. apply senv_preserved. simpl in B1; inv B1. simpl in B2; inv B2. econstructor; eauto. - exact symbols_preserved. exact public_preserved. exact varinfo_preserved. eapply match_succ_states; eauto. simpl; auto. apply eagree_set_res; auto. + (* memcpy eliminated *) rewrite e1 in TI. inv H0. inv H6. inv H7. rename b1 into v1. rename b0 into v2. - set (adst := aaddr_arg (vanalyze rm f) # pc dst) in *. - set (asrc := aaddr_arg (vanalyze rm f) # pc src) in *. + set (adst := aaddr_arg (vanalyze cu f) # pc dst) in *. + set (asrc := aaddr_arg (vanalyze cu f) # pc src) in *. inv H1. econstructor; split. eapply exec_Inop; eauto. eapply match_succ_states; eauto. simpl; auto. destruct res; auto. apply eagree_set_undef; auto. eapply magree_storebytes_left; eauto. - exploit aaddr_arg_sound. eauto. eauto. + exploit aaddr_arg_sound; eauto. intros (bc & A & B & C). intros. eapply nlive_contains; eauto. erewrite Mem.loadbytes_length in H0 by eauto. rewrite nat_of_Z_eq in H0 by omega. auto. + (* annot *) destruct (transfer_builtin_args (kill_builtin_res res ne, nm) _x1) as (ne1, nm1) eqn:TR. - inversion SS; subst. + InvSoundState. exploit transfer_builtin_args_sound; eauto. intros (tvl & A & B & C & D). inv H1. econstructor; split. eapply exec_Ibuiltin; eauto. apply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. - eapply external_call_symbols_preserved. simpl; constructor. - eapply eventval_list_match_lessdef; eauto 2 with na. - exact symbols_preserved. exact public_preserved. exact varinfo_preserved. + eapply external_call_symbols_preserved. apply senv_preserved. + constructor. eapply eventval_list_match_lessdef; eauto 2 with na. eapply match_succ_states; eauto. simpl; auto. apply eagree_set_res; auto. + (* annot val *) destruct (transfer_builtin_args (kill_builtin_res res ne, nm) _x1) as (ne1, nm1) eqn:TR. - inversion SS; subst. + InvSoundState. exploit transfer_builtin_args_sound; eauto. intros (tvl & A & B & C & D). inv H1. inv B. inv H6. econstructor; split. eapply exec_Ibuiltin; eauto. apply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. - eapply external_call_symbols_preserved. simpl; constructor. + eapply external_call_symbols_preserved. apply senv_preserved. + constructor. eapply eventval_match_lessdef; eauto 2 with na. - exact symbols_preserved. exact public_preserved. exact varinfo_preserved. eapply match_succ_states; eauto. simpl; auto. apply eagree_set_res; auto. + (* debug *) @@ -1027,7 +1011,7 @@ Ltac UseTransfer := } clear y TI. destruct (transfer_builtin_args (kill_builtin_res res ne, nmem_all) _x0) as (ne1, nm1) eqn:TR. - inversion SS; subst. + InvSoundState. exploit transfer_builtin_args_sound; eauto. intros (tvl & A & B & C & D). exploit external_call_mem_extends; eauto 2 with na. eapply magree_extends; eauto. intros. apply nlive_all. @@ -1035,8 +1019,7 @@ Ltac UseTransfer := econstructor; split. eapply exec_Ibuiltin; eauto. apply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. - eapply external_call_symbols_preserved. eauto. - exact symbols_preserved. exact public_preserved. exact varinfo_preserved. + eapply external_call_symbols_preserved. apply senv_preserved. eauto. eapply match_succ_states; eauto. simpl; auto. apply eagree_set_res; auto. eapply mextends_agree; eauto. @@ -1071,8 +1054,8 @@ Ltac UseTransfer := eapply magree_extends; eauto. apply nlive_all. - (* internal function *) - monadInv FUN. generalize EQ. unfold transf_function. intros EQ'. - destruct (analyze (vanalyze rm f) f) as [an|] eqn:AN; inv EQ'. + monadInv FUN. generalize EQ. unfold transf_function. fold (vanalyze cu f). intros EQ'. + destruct (analyze (vanalyze cu f) f) as [an|] eqn:AN; inv EQ'. exploit Mem.alloc_extends; eauto. apply Zle_refl. apply Zle_refl. intros (tm' & A & B). econstructor; split. @@ -1087,8 +1070,7 @@ Ltac UseTransfer := simpl in FUN. inv FUN. econstructor; split. econstructor; eauto. - eapply external_call_symbols_preserved; eauto. - exact symbols_preserved. exact public_preserved. exact varinfo_preserved. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. econstructor; eauto. - (* return *) @@ -1103,14 +1085,15 @@ Lemma transf_initial_states: exists st2, initial_state tprog st2 /\ match_states st1 st2. Proof. intros. inversion H. - exploit function_ptr_translated; eauto. intros (tf & A & B). + exploit function_ptr_translated; eauto. intros (cu & tf & A & B & C). exists (Callstate nil tf nil m0); split. econstructor; eauto. - eapply Genv.init_mem_transf_partial; eauto. - rewrite (transform_partial_program_main _ _ TRANSF). + eapply (Genv.init_mem_match TRANSF); eauto. + replace (prog_main tprog) with (prog_main prog). rewrite symbols_preserved. eauto. - rewrite <- H3. apply sig_function_translated; auto. - constructor. constructor. auto. constructor. apply Mem.extends_refl. + symmetry; eapply match_program_main; eauto. + rewrite <- H3. eapply sig_function_translated; eauto. + econstructor; eauto. constructor. apply Mem.extends_refl. Qed. Lemma transf_final_states: @@ -1128,7 +1111,7 @@ Proof. intros. apply forward_simulation_step with (match_states := fun s1 s2 => sound_state prog s1 /\ match_states s1 s2). -- exact public_preserved. +- apply senv_preserved. - simpl; intros. exploit transf_initial_states; eauto. intros [st2 [A B]]. exists st2; intuition. eapply sound_initial; eauto. - simpl; intros. destruct H. eapply transf_final_states; eauto. diff --git a/backend/Debugvar.v b/backend/Debugvar.v index dcc4327a..5d31831a 100644 --- a/backend/Debugvar.v +++ b/backend/Debugvar.v @@ -13,18 +13,9 @@ (** Computation of live ranges for local variables that carry debugging information. *) -Require Import Coqlib. -Require Import Axioms. -Require Import Maps. -Require Import Iteration. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Errors. -Require Import Machregs. -Require Import Locations. -Require Import Conventions. -Require Import Linear. +Require Import Axioms Coqlib Maps Iteration Errors. +Require Import Integers Floats AST. +Require Import Machregs Locations Conventions Linear. (** A debug info is a [builtin_arg loc] expression that safely evaluates in any context. *) diff --git a/backend/Debugvarproof.v b/backend/Debugvarproof.v index 73e32103..110c0f26 100644 --- a/backend/Debugvarproof.v +++ b/backend/Debugvarproof.v @@ -12,28 +12,23 @@ (** Correctness proof for the [Debugvar] pass. *) -Require Import Coqlib. -Require Import Axioms. -Require Import Maps. -Require Import Iteration. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import Memory. -Require Import Events. -Require Import Globalenvs. -Require Import Smallstep. -Require Import Op. -Require Import Errors. -Require Import Machregs. -Require Import Locations. -Require Import Conventions. -Require Import Linear. +Require Import Axioms Coqlib Maps Iteration Errors. +Require Import Integers Floats AST Linking. +Require Import Values Memory Events Globalenvs Smallstep. +Require Import Machregs Locations Conventions Op Linear. Require Import Debugvar. (** * Relational characterization of the transformation *) +Definition match_prog (p tp: program) := + match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp. + +Lemma transf_program_match: + forall p tp, transf_program p = OK tp -> match_prog p tp. +Proof. + intros. eapply match_transform_partial_program; eauto. +Qed. + Inductive match_code: code -> code -> Prop := | match_code_nil: match_code nil nil @@ -294,38 +289,32 @@ Section PRESERVATION. Variable prog: program. Variable tprog: program. -Hypothesis TRANSF: transf_program prog = OK tprog. +Hypothesis TRANSF: match_prog prog tprog. Let ge := Genv.globalenv prog. Let tge := Genv.globalenv tprog. +Lemma symbols_preserved: + forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. +Proof (Genv.find_symbol_match TRANSF). + +Lemma senv_preserved: + Senv.equiv ge tge. +Proof (Genv.senv_match TRANSF). + Lemma functions_translated: - forall v f, + forall (v: val) (f: fundef), 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). Lemma function_ptr_translated: - forall v f, - Genv.find_funct_ptr ge v = Some f -> + forall (b: block) (f: fundef), + Genv.find_funct_ptr ge b = 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). - -Lemma symbols_preserved: - forall id, - Genv.find_symbol tge id = Genv.find_symbol ge id. -Proof (Genv.find_symbol_transf_partial transf_fundef _ TRANSF). - -Lemma public_preserved: - forall id, - Genv.public_symbol tge id = Genv.public_symbol ge id. -Proof (Genv.public_symbol_transf_partial transf_fundef _ TRANSF). - -Lemma varinfo_preserved: - forall b, Genv.find_var_info tge b = Genv.find_var_info ge b. -Proof (Genv.find_var_info_transf_partial transf_fundef _ TRANSF). + Genv.find_funct_ptr tge b = Some tf /\ transf_fundef f = OK tf. +Proof (Genv.find_funct_ptr_transf_partial TRANSF). Lemma sig_preserved: forall f tf, @@ -488,8 +477,7 @@ Proof. eapply plus_left. econstructor; eauto. eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. - eapply external_call_symbols_preserved. eauto. - exact symbols_preserved. exact public_preserved. exact varinfo_preserved. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. apply eval_add_delta_ranges. traceEq. constructor; auto. - (* label *) @@ -530,8 +518,7 @@ Proof. - (* external function *) monadInv H8. econstructor; split. apply plus_one. econstructor; eauto. - eapply external_call_symbols_preserved'. eauto. - exact symbols_preserved. exact public_preserved. exact varinfo_preserved. + eapply external_call_symbols_preserved'; eauto. apply senv_preserved. constructor; auto. - (* return *) inv H3. inv H1. @@ -547,10 +534,8 @@ Proof. intros. inversion H. exploit function_ptr_translated; eauto. intros [tf [A B]]. exists (Callstate nil tf (Locmap.init Vundef) 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). + econstructor; eauto. eapply (Genv.init_mem_transf_partial TRANSF); eauto. + rewrite (match_program_main TRANSF), symbols_preserved. auto. rewrite <- H3. apply sig_preserved. auto. constructor. constructor. auto. Qed. @@ -566,7 +551,7 @@ Theorem transf_program_correct: forward_simulation (semantics prog) (semantics tprog). Proof. eapply forward_simulation_plus. - eexact public_preserved. + apply senv_preserved. eexact transf_initial_states. eexact transf_final_states. eexact transf_step_correct. diff --git a/backend/Inlining.v b/backend/Inlining.v index 566ab27c..5c8f4419 100644 --- a/backend/Inlining.v +++ b/backend/Inlining.v @@ -12,15 +12,9 @@ (** RTL function inlining *) -Require Import Coqlib. -Require Import Wfsimpl. -Require Import Errors. -Require Import Maps. -Require Import AST. -Require Import Integers. -Require Import Op. -Require Import Registers. -Require Import RTL. +Require Import Coqlib Wfsimpl Maps Errors Integers. +Require Import AST Linking. +Require Import Op Registers RTL. (** ** Environment of inlinable functions *) diff --git a/backend/Inliningproof.v b/backend/Inliningproof.v index ad861543..91f4a3f5 100644 --- a/backend/Inliningproof.v +++ b/backend/Inliningproof.v @@ -12,63 +12,50 @@ (** RTL function inlining: semantic preservation *) -Require Import Coqlib. -Require Import Errors. -Require Import Maps. -Require Import AST. -Require Import Integers. -Require Import Values. -Require Import Memory. -Require Import Globalenvs. -Require Import Events. -Require Import Smallstep. -Require Import Op. -Require Import Registers. -Require Import Inlining. -Require Import Inliningspec. -Require Import RTL. +Require Import Coqlib Wfsimpl Maps Errors Integers. +Require Import AST Linking Values Memory Globalenvs Events Smallstep. +Require Import Op Registers RTL. +Require Import Inlining Inliningspec. + +Definition match_prog (prog tprog: program) := + match_program (fun cunit f tf => transf_fundef (funenv_program cunit) f = OK tf) eq prog tprog. + +Lemma transf_program_match: + forall prog tprog, transf_program prog = OK tprog -> match_prog prog tprog. +Proof. + intros. eapply match_transform_partial_program_contextual; eauto. +Qed. Section INLINING. Variable prog: program. Variable tprog: program. -Hypothesis TRANSF: transf_program prog = OK tprog. +Hypothesis TRANSF: match_prog prog tprog. Let ge := Genv.globalenv prog. Let tge := Genv.globalenv tprog. -Let fenv := funenv_program prog. Lemma symbols_preserved: forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. -Proof. - intros. apply Genv.find_symbol_transf_partial with (transf_fundef fenv); auto. -Qed. +Proof (Genv.find_symbol_match TRANSF). -Lemma public_preserved: - forall (s: ident), Genv.public_symbol tge s = Genv.public_symbol ge s. -Proof. - intros. apply Genv.public_symbol_transf_partial with (transf_fundef fenv); auto. -Qed. - -Lemma varinfo_preserved: - forall b, Genv.find_var_info tge b = Genv.find_var_info ge b. -Proof. - intros. apply Genv.find_var_info_transf_partial with (transf_fundef fenv); auto. -Qed. +Lemma senv_preserved: + Senv.equiv ge tge. +Proof (Genv.senv_match TRANSF). Lemma functions_translated: forall (v: val) (f: fundef), Genv.find_funct ge v = Some f -> - exists f', Genv.find_funct tge v = Some f' /\ transf_fundef fenv f = OK f'. -Proof (Genv.find_funct_transf_partial (transf_fundef fenv) _ TRANSF). + exists cu f', Genv.find_funct tge v = Some f' /\ transf_fundef (funenv_program cu) f = OK f' /\ linkorder cu prog. +Proof (Genv.find_funct_match TRANSF). Lemma function_ptr_translated: forall (b: block) (f: fundef), Genv.find_funct_ptr ge b = Some f -> - exists f', Genv.find_funct_ptr tge b = Some f' /\ transf_fundef fenv f = OK f'. -Proof (Genv.find_funct_ptr_transf_partial (transf_fundef fenv) _ TRANSF). + exists cu f', Genv.find_funct_ptr tge b = Some f' /\ transf_fundef (funenv_program cu) f = OK f' /\ linkorder cu prog. +Proof (Genv.find_funct_ptr_match TRANSF). Lemma sig_function_translated: - forall f f', transf_fundef fenv f = OK f' -> funsig f' = funsig f. + forall cu f f', transf_fundef (funenv_program cu) f = OK f' -> funsig f' = funsig f. Proof. intros. destruct f; Errors.monadInv H. exploit transf_function_spec; eauto. intros SP; inv SP. auto. @@ -382,24 +369,39 @@ Lemma find_function_agree: find_function ge ros rs = Some fd -> agree_regs F ctx rs rs' -> match_globalenvs F bound -> - exists fd', - find_function tge (sros ctx ros) rs' = Some fd' /\ transf_fundef fenv fd = OK fd'. + exists cu fd', + find_function tge (sros ctx ros) rs' = Some fd' /\ transf_fundef (funenv_program cu) fd = OK fd' /\ linkorder cu prog. Proof. intros. destruct ros as [r | id]; simpl in *. - (* register *) - assert (rs'#(sreg ctx r) = rs#r). - exploit Genv.find_funct_inv; eauto. intros [b EQ]. +- (* register *) + assert (EQ: rs'#(sreg ctx r) = rs#r). + { exploit Genv.find_funct_inv; eauto. intros [b EQ]. assert (A: Val.inject F rs#r rs'#(sreg ctx r)). eapply agree_val_reg; eauto. rewrite EQ in A; inv A. inv H1. rewrite DOMAIN in H5. inv H5. auto. apply FUNCTIONS with fd. rewrite EQ in H; rewrite Genv.find_funct_find_funct_ptr in H. auto. - rewrite H2. eapply functions_translated; eauto. - (* symbol *) + } + rewrite EQ. eapply functions_translated; eauto. +- (* symbol *) rewrite symbols_preserved. destruct (Genv.find_symbol ge id); try discriminate. eapply function_ptr_translated; eauto. Qed. +Lemma find_inlined_function: + forall fenv id rs fd f, + fenv_compat prog fenv -> + find_function ge (inr id) rs = Some fd -> + fenv!id = Some f -> + fd = Internal f. +Proof. + intros. + apply H in H1. apply Genv.find_def_symbol in H1. destruct H1 as (b & A & B). + simpl in H0. unfold ge, fundef in H0. rewrite A in H0. + rewrite <- Genv.find_funct_ptr_iff in B. + congruence. +Qed. + (** Translation of builtin arguments. *) Lemma tr_builtin_arg: @@ -465,8 +467,9 @@ Inductive match_stacks (F: meminj) (m m': mem): (MG: match_globalenvs F bound1) (BELOW: Ple bound1 bound), match_stacks F m m' nil nil bound - | match_stacks_cons: forall res f sp pc rs stk f' sp' rs' stk' bound ctx + | match_stacks_cons: forall res f sp pc rs stk f' sp' rs' stk' bound fenv ctx (MS: match_stacks_inside F m m' stk stk' f' ctx sp' rs') + (COMPAT: fenv_compat prog fenv) (FB: tr_funbody fenv f'.(fn_stacksize) ctx f f'.(fn_code)) (AG: agree_regs F ctx rs rs') (SP: F sp = Some(sp', ctx.(dstk))) @@ -498,8 +501,9 @@ with match_stacks_inside (F: meminj) (m m': mem): (RET: ctx.(retinfo) = None) (DSTK: ctx.(dstk) = 0), match_stacks_inside F m m' stk stk' f' ctx sp' rs' - | match_stacks_inside_inlined: forall res f sp pc rs stk stk' f' ctx sp' rs' ctx' + | match_stacks_inside_inlined: forall res f sp pc rs stk stk' f' fenv ctx sp' rs' ctx' (MS: match_stacks_inside F m m' stk stk' f' ctx' sp' rs') + (COMPAT: fenv_compat prog fenv) (FB: tr_funbody fenv f'.(fn_stacksize) ctx' f f'.(fn_code)) (AG: agree_regs F ctx' rs rs') (SP: F sp = Some(sp', ctx'.(dstk))) @@ -597,7 +601,7 @@ Proof. intros. apply IMAGE with delta. eapply INJ; eauto. eapply Plt_le_trans; eauto. auto. auto. (* cons *) - apply match_stacks_cons with (ctx := ctx); auto. + apply match_stacks_cons with (fenv := fenv) (ctx := ctx); auto. eapply match_stacks_inside_invariant; eauto. intros; eapply INJ; eauto; xomega. intros; eapply PERM1; eauto; xomega. @@ -623,7 +627,7 @@ Proof. intros; eapply PERM2; eauto; xomega. intros; eapply PERM3; eauto; xomega. (* inlined *) - apply match_stacks_inside_inlined with (ctx' := ctx'); auto. + apply match_stacks_inside_inlined with (fenv := fenv) (ctx' := ctx'); auto. apply IHmatch_stacks_inside; auto. intros. apply RS. red in BELOW. xomega. apply agree_regs_incr with F; auto. @@ -825,7 +829,7 @@ Proof. Qed. Lemma match_stacks_inside_inlined_tailcall: - forall F m m' stk stk' f' ctx sp' rs' ctx' f, + forall fenv F m m' stk stk' f' ctx sp' rs' ctx' f, match_stacks_inside F m m' stk stk' f' ctx sp' rs' -> context_below ctx ctx' -> context_stack_tailcall ctx f ctx' -> @@ -849,9 +853,10 @@ Qed. (** ** Relating states *) -Inductive match_states: state -> state -> Prop := - | match_regular_states: forall stk f sp pc rs m stk' f' sp' rs' m' F ctx +Inductive match_states: RTL.state -> RTL.state -> Prop := + | match_regular_states: forall stk f sp pc rs m stk' f' sp' rs' m' F fenv ctx (MS: match_stacks_inside F m m' stk stk' f' ctx sp' rs') + (COMPAT: fenv_compat prog fenv) (FB: tr_funbody fenv f'.(fn_stacksize) ctx f f'.(fn_code)) (AG: agree_regs F ctx rs rs') (SP: F sp = Some(sp', ctx.(dstk))) @@ -862,15 +867,17 @@ Inductive match_states: state -> state -> Prop := (SSZ2: forall ofs, Mem.perm m' sp' ofs Max Nonempty -> 0 <= ofs <= f'.(fn_stacksize)), match_states (State stk f (Vptr sp Int.zero) pc rs m) (State stk' f' (Vptr sp' Int.zero) (spc ctx pc) rs' m') - | match_call_states: forall stk fd args m stk' fd' args' m' F + | match_call_states: forall stk fd args m stk' fd' args' m' cunit F (MS: match_stacks F m m' stk stk' (Mem.nextblock m')) - (FD: transf_fundef fenv fd = OK fd') + (LINK: linkorder cunit prog) + (FD: transf_fundef (funenv_program cunit) fd = OK fd') (VINJ: Val.inject_list F args args') (MINJ: Mem.inject F m m'), match_states (Callstate stk fd args m) (Callstate stk' fd' args' m') - | match_call_regular_states: forall stk f vargs m stk' f' sp' rs' m' F ctx ctx' pc' pc1' rargs + | match_call_regular_states: forall stk f vargs m stk' f' sp' rs' m' F fenv ctx ctx' pc' pc1' rargs (MS: match_stacks_inside F m m' stk stk' f' ctx sp' rs') + (COMPAT: fenv_compat prog fenv) (FB: tr_funbody fenv f'.(fn_stacksize) ctx f f'.(fn_code)) (BELOW: context_below ctx' ctx) (NOP: f'.(fn_code)!pc' = Some(Inop pc1')) @@ -904,7 +911,7 @@ Inductive match_states: state -> state -> Prop := (** ** Forward simulation *) -Definition measure (S: state) : nat := +Definition measure (S: RTL.state) : nat := match S with | State _ _ _ _ _ _ => 1%nat | Callstate _ _ _ _ => 0%nat @@ -912,7 +919,7 @@ Definition measure (S: state) : nat := end. Lemma tr_funbody_inv: - forall sz cts f c pc i, + forall fenv sz cts f c pc i, tr_funbody fenv sz cts f c -> f.(fn_code)!pc = Some i -> tr_instr fenv sz cts pc i c. Proof. intros. inv H. eauto. @@ -927,13 +934,13 @@ Theorem step_simulation: Proof. induction 1; intros; inv MS. -(* nop *) +- (* nop *) exploit tr_funbody_inv; eauto. intros TR; inv TR. left; econstructor; split. eapply plus_one. eapply exec_Inop; eauto. econstructor; eauto. -(* op *) +- (* op *) exploit tr_funbody_inv; eauto. intros TR; inv TR. exploit eval_operation_inject. eapply match_stacks_inside_globals; eauto. @@ -948,7 +955,7 @@ Proof. apply match_stacks_inside_set_reg; auto. apply agree_set_reg; auto. -(* load *) +- (* load *) exploit tr_funbody_inv; eauto. intros TR; inv TR. exploit eval_addressing_inject. eapply match_stacks_inside_globals; eauto. @@ -965,7 +972,7 @@ Proof. apply match_stacks_inside_set_reg; auto. apply agree_set_reg; auto. -(* store *) +- (* store *) exploit tr_funbody_inv; eauto. intros TR; inv TR. exploit eval_addressing_inject. eapply match_stacks_inside_globals; eauto. @@ -989,22 +996,19 @@ Proof. intros; eapply Mem.perm_store_1; eauto. intros. eapply SSZ2. eapply Mem.perm_store_2; eauto. -(* call *) +- (* call *) exploit match_stacks_inside_globalenvs; eauto. intros [bound G]. - exploit find_function_agree; eauto. intros [fd' [A B]]. + exploit find_function_agree; eauto. intros (cu & fd' & A & B & C). exploit tr_funbody_inv; eauto. intros TR; inv TR. -(* not inlined *) ++ (* not inlined *) left; econstructor; split. eapply plus_one. eapply exec_Icall; eauto. eapply sig_function_translated; eauto. econstructor; eauto. eapply match_stacks_cons; eauto. eapply agree_val_regs; eauto. -(* inlined *) - assert (fd = Internal f0). - simpl in H0. destruct (Genv.find_symbol ge id) as [b|] eqn:?; try discriminate. - exploit (funenv_program_compat prog); eauto. intros. - unfold ge in H0. congruence. ++ (* inlined *) + assert (EQ: fd = Internal f0) by (eapply find_inlined_function; eauto). subst fd. right; split. simpl; omega. split. auto. econstructor; eauto. @@ -1013,13 +1017,13 @@ Proof. apply agree_val_regs_gen; auto. red; intros; apply PRIV. destruct H16. omega. -(* tailcall *) +- (* tailcall *) exploit match_stacks_inside_globalenvs; eauto. intros [bound G]. - exploit find_function_agree; eauto. intros [fd' [A B]]. + exploit find_function_agree; eauto. intros (cu & fd' & A & B & C). assert (PRIV': range_private F m' m'0 sp' (dstk ctx) f'.(fn_stacksize)). - eapply range_private_free_left; eauto. inv FB. rewrite <- H4. auto. + { eapply range_private_free_left; eauto. inv FB. rewrite <- H4. auto. } exploit tr_funbody_inv; eauto. intros TR; inv TR. -(* within the original function *) ++ (* within the original function *) inv MS0; try congruence. assert (X: { m1' | Mem.free m'0 sp' 0 (fn_stacksize f') = Some m1'}). apply Mem.range_perm_free. red; intros. @@ -1044,7 +1048,7 @@ Proof. intros. rewrite DSTK in PRIV'. exploit (PRIV' (ofs + delta)). omega. intros [P Q]. eelim Q; eauto. replace (ofs + delta - delta) with ofs by omega. apply Mem.perm_max with k. apply Mem.perm_implies with p; auto with mem. -(* turned into a call *) ++ (* turned into a call *) left; econstructor; split. eapply plus_one. eapply exec_Icall; eauto. eapply sig_function_translated; eauto. @@ -1054,11 +1058,8 @@ Proof. intros. eapply Mem.perm_free_3; eauto. eapply agree_val_regs; eauto. eapply Mem.free_left_inject; eauto. -(* inlined *) - assert (fd = Internal f0). - simpl in H0. destruct (Genv.find_symbol ge id) as [b|] eqn:?; try discriminate. - exploit (funenv_program_compat prog); eauto. intros. - unfold ge in H0. congruence. ++ (* inlined *) + assert (EQ: fd = Internal f0) by (eapply find_inlined_function; eauto). subst fd. right; split. simpl; omega. split. auto. econstructor; eauto. @@ -1071,7 +1072,7 @@ Proof. assert (dstk ctx <= dstk ctx'). red in H14; rewrite H14. apply align_le. apply min_alignment_pos. omega. -(* builtin *) +- (* builtin *) exploit tr_funbody_inv; eauto. intros TR; inv TR. exploit match_stacks_inside_globalenvs; eauto. intros [bound MG]. exploit tr_builtin_args; eauto. intros (vargs' & P & Q). @@ -1080,14 +1081,13 @@ Proof. intros [F1 [v1 [m1' [A [B [C [D [E [J K]]]]]]]]]. left; econstructor; split. eapply plus_one. eapply exec_Ibuiltin; eauto. - eapply external_call_symbols_preserved; eauto. - exact symbols_preserved. exact public_preserved. exact varinfo_preserved. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. econstructor. eapply match_stacks_inside_set_res. eapply match_stacks_inside_extcall with (F1 := F) (F2 := F1) (m1 := m) (m1' := m'0); eauto. intros; eapply external_call_max_perm; eauto. intros; eapply external_call_max_perm; eauto. - auto. + auto. eauto. auto. destruct res; simpl; [apply agree_set_reg;auto|idtac|idtac]; eapply agree_regs_incr; eauto. auto. auto. eapply external_call_valid_block; eauto. @@ -1096,7 +1096,7 @@ Proof. auto. intros. apply SSZ2. eapply external_call_max_perm; eauto. -(* cond *) +- (* cond *) exploit tr_funbody_inv; eauto. intros TR; inv TR. assert (eval_condition cond rs'##(sregs ctx args) m' = Some b). eapply eval_condition_inject; eauto. eapply agree_val_regs; eauto. @@ -1104,7 +1104,7 @@ Proof. eapply plus_one. eapply exec_Icond; eauto. destruct b; econstructor; eauto. -(* jumptable *) +- (* jumptable *) exploit tr_funbody_inv; eauto. intros TR; inv TR. assert (Val.inject F rs#arg rs'#(sreg ctx arg)). eapply agree_val_reg; eauto. rewrite H0 in H2; inv H2. @@ -1113,9 +1113,9 @@ Proof. rewrite list_nth_z_map. rewrite H1. simpl; reflexivity. econstructor; eauto. -(* return *) +- (* return *) exploit tr_funbody_inv; eauto. intros TR; inv TR. - (* not inlined *) ++ (* not inlined *) inv MS0; try congruence. assert (X: { m1' | Mem.free m'0 sp' 0 (fn_stacksize f') = Some m1'}). apply Mem.range_perm_free. red; intros. @@ -1144,7 +1144,7 @@ Proof. eelim B; eauto. replace (ofs + delta - delta) with ofs by omega. apply Mem.perm_max with k. apply Mem.perm_implies with p; auto with mem. - (* inlined *) ++ (* inlined *) right. split. simpl. omega. split. auto. econstructor; eauto. eapply match_stacks_inside_invariant; eauto. @@ -1153,42 +1153,45 @@ Proof. eapply Mem.free_left_inject; eauto. inv FB. rewrite H4 in PRIV. eapply range_private_free_left; eauto. -(* internal function, not inlined *) - assert (A: exists f', tr_function fenv f f' /\ fd' = Internal f'). - Errors.monadInv FD. exists x. split; auto. eapply transf_function_spec; eauto. - destruct A as [f' [TR EQ]]. inversion TR; subst. +- (* internal function, not inlined *) + assert (A: exists f', tr_function cunit f f' /\ fd' = Internal f'). + { Errors.monadInv FD. exists x. split; auto. eapply transf_function_spec; eauto. } + destruct A as [f' [TR1 EQ]]. + assert (TR: tr_function prog f f'). + { eapply tr_function_linkorder; eauto. } + inversion TR; subst. exploit Mem.alloc_parallel_inject. eauto. eauto. apply Zle_refl. - instantiate (1 := fn_stacksize f'). inv H0. xomega. + instantiate (1 := fn_stacksize f'). inv H1. xomega. intros [F' [m1' [sp' [A [B [C [D E]]]]]]]. left; econstructor; split. eapply plus_one. eapply exec_function_internal; eauto. - rewrite H5. econstructor. + rewrite H6. econstructor. instantiate (1 := F'). apply match_stacks_inside_base. assert (SP: sp' = Mem.nextblock m'0) by (eapply Mem.alloc_result; eauto). rewrite <- SP in MS0. eapply match_stacks_invariant; eauto. intros. destruct (eq_block b1 stk). - subst b1. rewrite D in H7; inv H7. subst b2. eelim Plt_strict; eauto. - rewrite E in H7; auto. + subst b1. rewrite D in H8; inv H8. subst b2. eelim Plt_strict; eauto. + rewrite E in H8; auto. intros. exploit Mem.perm_alloc_inv. eexact H. eauto. destruct (eq_block b1 stk); intros; auto. - subst b1. rewrite D in H7; inv H7. subst b2. eelim Plt_strict; eauto. + subst b1. rewrite D in H8; inv H8. subst b2. eelim Plt_strict; eauto. intros. eapply Mem.perm_alloc_1; eauto. intros. exploit Mem.perm_alloc_inv. eexact A. eauto. rewrite dec_eq_false; auto. - auto. auto. auto. - rewrite H4. apply agree_regs_init_regs. eauto. auto. inv H0; auto. congruence. auto. + auto. auto. auto. eauto. auto. + rewrite H5. apply agree_regs_init_regs. eauto. auto. inv H1; auto. congruence. auto. eapply Mem.valid_new_block; eauto. red; intros. split. - eapply Mem.perm_alloc_2; eauto. inv H0; xomega. + eapply Mem.perm_alloc_2; eauto. inv H1; xomega. intros; red; intros. exploit Mem.perm_alloc_inv. eexact H. eauto. destruct (eq_block b stk); intros. - subst. rewrite D in H8; inv H8. inv H0; xomega. - rewrite E in H8; auto. eelim Mem.fresh_block_alloc. eexact A. eapply Mem.mi_mappedblocks; eauto. + subst. rewrite D in H9; inv H9. inv H1; xomega. + rewrite E in H9; auto. eelim Mem.fresh_block_alloc. eexact A. eapply Mem.mi_mappedblocks; eauto. auto. intros. exploit Mem.perm_alloc_inv; eauto. rewrite dec_eq_true. omega. -(* internal function, inlined *) +- (* internal function, inlined *) inversion FB; subst. exploit Mem.alloc_left_mapped_inject. eauto. @@ -1218,13 +1221,13 @@ Proof. eapply match_stacks_inside_alloc_left; eauto. eapply match_stacks_inside_invariant; eauto. omega. - auto. + eauto. auto. apply agree_regs_incr with F; auto. auto. auto. auto. rewrite H2. eapply range_private_alloc_left; eauto. auto. auto. -(* external function *) +- (* external function *) exploit match_stacks_globalenvs; eauto. intros [bound MG]. exploit external_call_mem_inject; eauto. eapply match_globalenvs_preserves_globals; eauto. @@ -1232,8 +1235,7 @@ Proof. simpl in FD. inv FD. left; econstructor; split. eapply plus_one. eapply exec_function_external; eauto. - eapply external_call_symbols_preserved; eauto. - exact symbols_preserved. exact public_preserved. exact varinfo_preserved. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. econstructor. eapply match_stacks_bound with (Mem.nextblock m'0). eapply match_stacks_extcall with (F1 := F) (F2 := F1) (m1 := m) (m1' := m'0); eauto. @@ -1243,43 +1245,38 @@ Proof. eapply external_call_nextblock; eauto. auto. auto. -(* return fron noninlined function *) +- (* return fron noninlined function *) inv MS0. - (* normal case *) ++ (* normal case *) left; econstructor; split. eapply plus_one. eapply exec_return. econstructor; eauto. apply match_stacks_inside_set_reg; auto. apply agree_set_reg; auto. - (* untailcall case *) ++ (* untailcall case *) inv MS; try congruence. rewrite RET in RET0; inv RET0. -(* - assert (rpc = pc). unfold spc in H0; unfold node in *; xomega. - assert (res0 = res). unfold sreg in H1; unfold reg in *; xomega. - subst rpc res0. -*) left; econstructor; split. eapply plus_one. eapply exec_return. eapply match_regular_states. eapply match_stacks_inside_set_reg; eauto. - auto. + eauto. auto. apply agree_set_reg; auto. auto. auto. auto. red; intros. destruct (zlt ofs (dstk ctx)). apply PAD; omega. apply PRIV; omega. auto. auto. -(* return from inlined function *) +- (* return from inlined function *) inv MS0; try congruence. rewrite RET0 in RET; inv RET. unfold inline_return in AT. assert (PRIV': range_private F m m' sp' (dstk ctx' + mstk ctx') f'.(fn_stacksize)). red; intros. destruct (zlt ofs (dstk ctx)). apply PAD. omega. apply PRIV. omega. destruct or. - (* with a result *) ++ (* with a result *) left; econstructor; split. eapply plus_one. eapply exec_Iop; eauto. simpl. reflexivity. econstructor; eauto. apply match_stacks_inside_set_reg; auto. apply agree_set_reg; auto. - (* without a result *) ++ (* without a result *) left; econstructor; split. eapply plus_one. eapply exec_Inop; eauto. econstructor; eauto. subst vres. apply agree_set_reg_undef'; auto. @@ -1289,13 +1286,13 @@ Lemma transf_initial_states: forall st1, initial_state prog st1 -> exists st2, initial_state tprog st2 /\ match_states st1 st2. Proof. intros. inv H. - exploit function_ptr_translated; eauto. intros [tf [FIND TR]]. + exploit function_ptr_translated; eauto. intros (cu & tf & FIND & TR & LINK). exists (Callstate nil tf nil m0); split. econstructor; eauto. - unfold transf_program in TRANSF. eapply Genv.init_mem_transf_partial; eauto. - rewrite symbols_preserved. - rewrite (transform_partial_program_main _ _ TRANSF). auto. - rewrite <- H3. apply sig_function_translated; auto. + eapply (Genv.init_mem_match TRANSF); eauto. + rewrite symbols_preserved. replace (prog_main tprog) with (prog_main prog). auto. + symmetry; eapply match_program_main; eauto. + rewrite <- H3. eapply sig_function_translated; eauto. econstructor; eauto. instantiate (1 := Mem.flat_inj (Mem.nextblock m0)). apply match_stacks_nil with (Mem.nextblock m0). @@ -1322,7 +1319,7 @@ Theorem transf_program_correct: forward_simulation (semantics prog) (semantics tprog). Proof. eapply forward_simulation_star. - eexact public_preserved. + apply senv_preserved. eexact transf_initial_states. eexact transf_final_states. eexact step_simulation. diff --git a/backend/Inliningspec.v b/backend/Inliningspec.v index ba62313f..23770cb7 100644 --- a/backend/Inliningspec.v +++ b/backend/Inliningspec.v @@ -12,64 +12,60 @@ (** RTL function inlining: relational specification *) -Require Import Coqlib. -Require Import Wfsimpl. -Require Import Errors. -Require Import Maps. -Require Import AST. -Require Import Integers. -Require Import Globalenvs. -Require Import Op. -Require Import Registers. -Require Import RTL. +Require Import Coqlib Wfsimpl Maps Errors Integers. +Require Import AST Linking. +Require Import Op Registers RTL. Require Import Inlining. (** ** Soundness of function environments. *) -(** A (compile-time) function environment is compatible with a - (run-time) global environment if the following condition holds. *) +(** A compile-time function environment is compatible with a whole + program if the following condition holds. *) -Definition fenv_compat (ge: genv) (fenv: funenv) : Prop := - forall id b f, - fenv!id = Some f -> Genv.find_symbol ge id = Some b -> - Genv.find_funct_ptr ge b = Some (Internal f). +Definition fenv_compat (p: program) (fenv: funenv) : Prop := + forall id f, + fenv!id = Some f -> (prog_defmap p)!id = Some (Gfun (Internal f)). -Remark add_globdef_compat: - forall ge fenv idg, - fenv_compat ge fenv -> - fenv_compat (Genv.add_global ge idg) (Inlining.add_globdef fenv idg). +Lemma funenv_program_compat: + forall p, fenv_compat p (funenv_program p). Proof. - intros. destruct idg as [id gd]. red; simpl; intros. - unfold Genv.find_symbol in H1; simpl in H1. - unfold Genv.find_funct_ptr; simpl. - rewrite PTree.gsspec in H1. destruct (peq id0 id). - (* same *) - subst id0. inv H1. destruct gd. destruct f0. - destruct (should_inline id f0). - rewrite PTree.gss in H0. rewrite PTree.gss. inv H0; auto. - rewrite PTree.grs in H0; discriminate. - rewrite PTree.grs in H0; discriminate. - rewrite PTree.grs in H0; discriminate. - (* different *) - destruct gd. rewrite PTree.gso. eapply H; eauto. - destruct f0. destruct (should_inline id f0). - rewrite PTree.gso in H0; auto. - rewrite PTree.gro in H0; auto. - rewrite PTree.gro in H0; auto. - red; intros; subst b. eelim Plt_strict. eapply Genv.genv_symb_range; eauto. - rewrite PTree.gro in H0; auto. eapply H; eauto. + set (P := fun (dm: PTree.t (globdef fundef unit)) (fenv: funenv) => + forall id f, + fenv!id = Some f -> dm!id = Some (Gfun (Internal f))). + assert (REMOVE: forall dm fenv id g, + P dm fenv -> + P (PTree.set id g dm) (PTree.remove id fenv)). + { unfold P; intros. rewrite PTree.grspec in H0. destruct (PTree.elt_eq id0 id). + discriminate. + rewrite PTree.gso; auto. + } + assert (ADD: forall dm fenv idg, + P dm fenv -> + P (PTree.set (fst idg) (snd idg) dm) (add_globdef fenv idg)). + { intros dm fenv [id g]; simpl; intros. + destruct g as [ [f|ef] | v]; auto. + destruct (should_inline id f); auto. + red; intros. rewrite ! PTree.gsspec in *. + destruct (peq id0 id); auto. inv H0; auto. + } + assert (REC: forall l dm fenv, + P dm fenv -> + P (fold_left (fun x idg => PTree.set (fst idg) (snd idg) x) l dm) + (fold_left add_globdef l fenv)). + { induction l; simpl; intros. + - auto. + - apply IHl. apply ADD; auto. + } + intros. apply REC. red; intros. rewrite PTree.gempty in H; discriminate. Qed. -Lemma funenv_program_compat: - forall p, fenv_compat (Genv.globalenv p) (funenv_program p). +Lemma fenv_compat_linkorder: + forall cunit prog fenv, + linkorder cunit prog -> fenv_compat cunit fenv -> fenv_compat prog fenv. Proof. - intros. - unfold Genv.globalenv, funenv_program. - assert (forall gl ge fenv, - fenv_compat ge fenv -> - fenv_compat (Genv.add_globals ge gl) (fold_left add_globdef gl fenv)). - induction gl; simpl; intros. auto. apply IHgl. apply add_globdef_compat; auto. - apply H. red; intros. rewrite PTree.gempty in H0; discriminate. + intros; red; intros. apply H0 in H1. + destruct (prog_defmap_linkorder _ _ _ _ H H1) as (gd' & P & Q). + inv Q. inv H3. auto. Qed. (** ** Properties of shifting *) @@ -684,29 +680,45 @@ Qed. End INLINING_BODY_SPEC. +End INLINING_SPEC. + (** ** Relational specification of the translation of a function *) -Inductive tr_function: function -> function -> Prop := - | tr_function_intro: forall f f' ctx, - tr_funbody f'.(fn_stacksize) ctx f f'.(fn_code) -> +Inductive tr_function: program -> function -> function -> Prop := + | tr_function_intro: forall p fenv f f' ctx, + fenv_compat p fenv -> + tr_funbody fenv f'.(fn_stacksize) ctx f f'.(fn_code) -> ctx.(dstk) = 0 -> ctx.(retinfo) = None -> f'.(fn_sig) = f.(fn_sig) -> f'.(fn_params) = sregs ctx f.(fn_params) -> f'.(fn_entrypoint) = spc ctx f.(fn_entrypoint) -> 0 <= fn_stacksize f' < Int.max_unsigned -> - tr_function f f'. + tr_function p f f'. + +Lemma tr_function_linkorder: + forall cunit prog f f', + linkorder cunit prog -> + tr_function cunit f f' -> + tr_function prog f f'. +Proof. + intros. inv H0. econstructor; eauto. eapply fenv_compat_linkorder; eauto. +Qed. Lemma transf_function_spec: - forall f f', transf_function fenv f = OK f' -> tr_function f f'. + forall cunit f f', + transf_function (funenv_program cunit) f = OK f' -> + tr_function cunit f f'. Proof. intros. unfold transf_function in H. + set (fenv := funenv_program cunit) in *. destruct (expand_function fenv f initstate) as [ctx s i] eqn:?. destruct (zlt (st_stksize s) Int.max_unsigned); inv H. monadInv Heqr. set (ctx := initcontext x x0 (max_reg_function f) (fn_stacksize f)) in *. Opaque initstate. destruct INCR3. inversion EQ1. inversion EQ. - apply tr_function_intro with ctx; auto. + apply tr_function_intro with fenv ctx; auto. + apply funenv_program_compat. eapply expand_cfg_spec with (fe := fenv); eauto. red; auto. unfold ctx; rewrite <- H1; rewrite <- H2; rewrite <- H3; simpl. xomega. @@ -718,5 +730,3 @@ Opaque initstate. simpl. split; auto. destruct INCR2. destruct INCR1. destruct INCR0. destruct INCR. simpl. change 0 with (st_stksize initstate). omega. Qed. - -End INLINING_SPEC. diff --git a/backend/Linearize.v b/backend/Linearize.v index 68c2b32f..2cfa4d3c 100644 --- a/backend/Linearize.v +++ b/backend/Linearize.v @@ -12,19 +12,9 @@ (** Linearization of the control-flow graph: translation from LTL to Linear *) -Require Import Coqlib. -Require Import Maps. -Require Import Ordered. -Require Import FSets. -Require FSetAVL. -Require Import AST. -Require Import Errors. -Require Import Op. -Require Import Locations. -Require Import LTL. -Require Import Linear. -Require Import Kildall. -Require Import Lattice. +Require Import FSets FSetAVL. +Require Import Coqlib Maps Ordered Errors Lattice Kildall. +Require Import AST Op Locations LTL Linear. Open Scope error_monad_scope. diff --git a/backend/Linearizeproof.v b/backend/Linearizeproof.v index 65258b2d..16717365 100644 --- a/backend/Linearizeproof.v +++ b/backend/Linearizeproof.v @@ -13,32 +13,29 @@ (** Correctness proof for code linearization *) Require Import FSets. -Require Import Coqlib. -Require Import Maps. -Require Import Ordered. -Require Import Lattice. -Require Import AST. -Require Import Integers. -Require Import Values. -Require Import Memory. -Require Import Events. -Require Import Globalenvs. -Require Import Errors. -Require Import Smallstep. -Require Import Op. -Require Import Locations. -Require Import LTL. -Require Import Linear. +Require Import Coqlib Maps Ordered Errors Lattice Kildall Integers. +Require Import AST Linking. +Require Import Values Memory Events Globalenvs Smallstep. +Require Import Op Locations LTL Linear. Require Import Linearize. Module NodesetFacts := FSetFacts.Facts(Nodeset). +Definition match_prog (p: LTL.program) (tp: Linear.program) := + match_program (fun ctx f tf => transf_fundef f = OK tf) eq p tp. + +Lemma transf_program_match: + forall p tp, transf_program p = OK tp -> match_prog p tp. +Proof. + intros. eapply match_transform_partial_program; eauto. +Qed. + Section LINEARIZATION. Variable prog: LTL.program. Variable tprog: Linear.program. -Hypothesis TRANSF: transf_program prog = OK tprog. +Hypothesis TRANSF: match_prog prog tprog. Let ge := Genv.globalenv prog. Let tge := Genv.globalenv tprog. @@ -48,28 +45,23 @@ 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). 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). Lemma symbols_preserved: forall id, Genv.find_symbol tge id = Genv.find_symbol ge id. -Proof (Genv.find_symbol_transf_partial transf_fundef _ TRANSF). - -Lemma public_preserved: - forall id, - Genv.public_symbol tge id = Genv.public_symbol ge id. -Proof (Genv.public_symbol_transf_partial transf_fundef _ TRANSF). +Proof (Genv.find_symbol_transf_partial TRANSF). -Lemma varinfo_preserved: - forall b, Genv.find_var_info tge b = Genv.find_var_info ge b. -Proof (Genv.find_var_info_transf_partial transf_fundef _ TRANSF). +Lemma senv_preserved: + Senv.equiv ge tge. +Proof (Genv.senv_transf_partial TRANSF). Lemma sig_preserved: forall f tf, @@ -645,8 +637,7 @@ Proof. left; econstructor; split. simpl. apply plus_one. eapply exec_Lbuiltin; eauto. eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. - eapply external_call_symbols_preserved; eauto. - exact symbols_preserved. exact public_preserved. exact varinfo_preserved. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. econstructor; eauto. (* Lbranch *) @@ -703,8 +694,7 @@ Proof. (* external function *) monadInv H8. left; econstructor; split. apply plus_one. eapply exec_function_external; eauto. - eapply external_call_symbols_preserved'; eauto. - exact symbols_preserved. exact public_preserved. exact varinfo_preserved. + eapply external_call_symbols_preserved'; eauto. apply senv_preserved. econstructor; eauto. (* return *) @@ -721,10 +711,9 @@ Proof. intros. inversion H. exploit function_ptr_translated; eauto. intros [tf [A B]]. exists (Callstate nil tf (Locmap.init Vundef) m0); split. - econstructor; eauto. eapply Genv.init_mem_transf_partial; eauto. - replace (prog_main tprog) with (prog_main prog). + econstructor; eauto. eapply (Genv.init_mem_transf_partial TRANSF); eauto. + rewrite (match_program_main TRANSF). rewrite symbols_preserved. eauto. - symmetry. apply (transform_partial_program_main transf_fundef _ TRANSF). rewrite <- H3. apply sig_preserved. auto. constructor. constructor. auto. Qed. @@ -740,7 +729,7 @@ Theorem transf_program_correct: forward_simulation (LTL.semantics prog) (Linear.semantics tprog). Proof. eapply forward_simulation_star. - eexact public_preserved. + apply senv_preserved. eexact transf_initial_states. eexact transf_final_states. eexact transf_step_correct. diff --git a/backend/RTLgenproof.v b/backend/RTLgenproof.v index f458de8b..ace822fd 100644 --- a/backend/RTLgenproof.v +++ b/backend/RTLgenproof.v @@ -12,23 +12,10 @@ (** Correctness proof for RTL generation. *) -Require Import Coqlib. -Require Import Maps. -Require Import AST. -Require Import Integers. -Require Import Values. -Require Import Memory. -Require Import Events. -Require Import Smallstep. -Require Import Globalenvs. -Require Import Switch. -Require Import Registers. -Require Import Cminor. -Require Import Op. -Require Import CminorSel. -Require Import RTL. -Require Import RTLgen. -Require Import RTLgenspec. +Require Import Coqlib Maps AST Linking. +Require Import Integers Values Memory Events Smallstep Globalenvs. +Require Import Switch Registers Cminor Op CminorSel RTL. +Require Import RTLgen RTLgenspec. (** * Correspondence between Cminor environments and RTL register sets *) @@ -361,11 +348,20 @@ Qed. Require Import Errors. +Definition match_prog (p: CminorSel.program) (tp: RTL.program) := + match_program (fun cu f tf => transl_fundef f = Errors.OK tf) eq p tp. + +Lemma transf_program_match: + forall p tp, transl_program p = OK tp -> match_prog p tp. +Proof. + intros. apply match_transform_partial_program; auto. +Qed. + Section CORRECTNESS. Variable prog: CminorSel.program. Variable tprog: RTL.program. -Hypothesis TRANSL: transl_program prog = OK tprog. +Hypothesis TRANSL: match_prog prog tprog. Let ge : CminorSel.genv := Genv.globalenv prog. Let tge : RTL.genv := Genv.globalenv tprog. @@ -376,12 +372,7 @@ Let tge : RTL.genv := Genv.globalenv tprog. Lemma symbols_preserved: forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. Proof - (Genv.find_symbol_transf_partial transl_fundef _ TRANSL). - -Lemma public_preserved: - forall (s: ident), Genv.public_symbol tge s = Genv.public_symbol ge s. -Proof - (Genv.public_symbol_transf_partial transl_fundef _ TRANSL). + (Genv.find_symbol_transf_partial TRANSL). Lemma function_ptr_translated: forall (b: block) (f: CminorSel.fundef), @@ -389,7 +380,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). Lemma functions_translated: forall (v: val) (f: CminorSel.fundef), @@ -397,7 +388,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). Lemma sig_transl_function: forall (f: CminorSel.fundef) (tf: RTL.fundef), @@ -414,10 +405,10 @@ Proof. intro. inversion H. reflexivity. Qed. -Lemma varinfo_preserved: - forall b, Genv.find_var_info tge b = Genv.find_var_info ge b. +Lemma senv_preserved: + Senv.equiv (Genv.to_senv ge) (Genv.to_senv tge). Proof - (Genv.find_var_info_transf_partial transl_fundef _ TRANSL). + (Genv.senv_transf_partial TRANSL). (** Correctness of the code generated by [add_move]. *) @@ -720,8 +711,7 @@ Proof. change (rs1#rd <- v') with (regmap_setres (BR rd) v' rs1). eapply exec_Ibuiltin; eauto. eapply eval_builtin_args_trivial. - eapply external_call_symbols_preserved; eauto. - exact symbols_preserved. exact public_preserved. exact varinfo_preserved. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. reflexivity. (* Match-env *) split. eauto with rtlg. @@ -754,8 +744,7 @@ Proof. eapply star_left. eapply exec_Icall; eauto. simpl. rewrite symbols_preserved. rewrite H. eauto. auto. eapply star_left. eapply exec_function_external. - eapply external_call_symbols_preserved; eauto. - exact symbols_preserved. exact public_preserved. exact varinfo_preserved. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. apply star_one. apply exec_return. reflexivity. reflexivity. reflexivity. (* Match-env *) @@ -1422,8 +1411,7 @@ Proof. left. eapply plus_right. eexact E. eapply exec_Ibuiltin. eauto. eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. - eapply external_call_symbols_preserved. eauto. - exact symbols_preserved. exact public_preserved. exact varinfo_preserved. + eapply external_call_symbols_preserved. apply senv_preserved. eauto. traceEq. econstructor; eauto. constructor. eapply match_env_update_res; eauto. @@ -1540,8 +1528,7 @@ Proof. edestruct external_call_mem_extends as [tvres [tm' [A [B [C D]]]]]; eauto. econstructor; split. left; apply plus_one. eapply exec_function_external; eauto. - eapply external_call_symbols_preserved. eauto. - exact symbols_preserved. exact public_preserved. exact varinfo_preserved. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. constructor; auto. (* return *) @@ -1559,9 +1546,9 @@ Proof. induction 1. exploit function_ptr_translated; eauto. intros [tf [A B]]. econstructor; split. - econstructor. apply (Genv.init_mem_transf_partial _ _ TRANSL); eauto. - rewrite (transform_partial_program_main _ _ TRANSL). fold tge. - rewrite symbols_preserved. eauto. + econstructor. apply (Genv.init_mem_transf_partial TRANSL); eauto. + replace (prog_main tprog) with (prog_main prog). rewrite symbols_preserved; eauto. + symmetry; eapply match_program_main; eauto. eexact A. rewrite <- H2. apply sig_transl_function; auto. constructor. auto. constructor. @@ -1579,7 +1566,7 @@ Theorem transf_program_correct: forward_simulation (CminorSel.semantics prog) (RTL.semantics tprog). Proof. eapply forward_simulation_star_wf with (order := lt_state). - eexact public_preserved. + apply senv_preserved. eexact transl_initial_states. eexact transl_final_states. apply lt_state_wf. diff --git a/backend/Renumberproof.v b/backend/Renumberproof.v index f4d9cca3..7cda9425 100644 --- a/backend/Renumberproof.v +++ b/backend/Renumberproof.v @@ -12,21 +12,24 @@ (** Postorder renumbering of RTL control-flow graphs. *) -Require Import Coqlib. -Require Import Maps. -Require Import Postorder. -Require Import Events. -Require Import Globalenvs. -Require Import Smallstep. -Require Import Op. -Require Import Registers. -Require Import RTL. -Require Import Renumber. +Require Import Coqlib Maps Postorder. +Require Import AST Linking. +Require Import Values Memory Globalenvs Events Smallstep. +Require Import Op Registers RTL Renumber. + +Definition match_prog (p tp: RTL.program) := + match_program (fun ctx f tf => tf = transf_fundef f) eq p tp. + +Lemma transf_program_match: + forall p, match_prog p (transf_program p). +Proof. + intros. eapply match_transform_program; eauto. +Qed. Section PRESERVATION. -Variable prog: program. -Let tprog := transf_program prog. +Variables prog tprog: program. +Hypothesis TRANSL: match_prog prog tprog. Let ge := Genv.globalenv prog. Let tge := Genv.globalenv tprog. @@ -34,27 +37,22 @@ Lemma functions_translated: forall v f, Genv.find_funct ge v = Some f -> Genv.find_funct tge v = Some (transf_fundef f). -Proof (@Genv.find_funct_transf _ _ _ transf_fundef prog). +Proof (Genv.find_funct_transf TRANSL). Lemma function_ptr_translated: forall v f, Genv.find_funct_ptr ge v = Some f -> Genv.find_funct_ptr tge v = Some (transf_fundef f). -Proof (@Genv.find_funct_ptr_transf _ _ _ transf_fundef prog). +Proof (Genv.find_funct_ptr_transf TRANSL). Lemma symbols_preserved: forall id, Genv.find_symbol tge id = Genv.find_symbol ge id. -Proof (@Genv.find_symbol_transf _ _ _ transf_fundef prog). - -Lemma public_preserved: - forall id, - Genv.public_symbol tge id = Genv.public_symbol ge id. -Proof (@Genv.public_symbol_transf _ _ _ transf_fundef prog). +Proof (Genv.find_symbol_transf TRANSL). -Lemma varinfo_preserved: - forall b, Genv.find_var_info tge b = Genv.find_var_info ge b. -Proof (@Genv.find_var_info_transf _ _ _ transf_fundef prog). +Lemma senv_preserved: + Senv.equiv ge tge. +Proof (Genv.senv_transf TRANSL). Lemma sig_preserved: forall f, funsig (transf_fundef f) = funsig f. @@ -199,8 +197,7 @@ Proof. econstructor; split. eapply exec_Ibuiltin; eauto. eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. - eapply external_call_symbols_preserved; eauto. - exact symbols_preserved. exact public_preserved. exact varinfo_preserved. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. constructor; auto. eapply reach_succ; eauto. simpl; auto. (* cond *) econstructor; split. @@ -224,8 +221,7 @@ Proof. (* external function *) econstructor; split. eapply exec_function_external; eauto. - eapply external_call_symbols_preserved; eauto. - exact symbols_preserved. exact public_preserved. exact varinfo_preserved. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. constructor; auto. (* return *) inv STACKS. inv H1. @@ -240,8 +236,8 @@ Lemma transf_initial_states: Proof. intros. inv H. econstructor; split. econstructor. - eapply Genv.init_mem_transf; eauto. - simpl. rewrite symbols_preserved. eauto. + eapply (Genv.init_mem_transf TRANSL); eauto. + rewrite symbols_preserved. rewrite (match_program_main TRANSL). eauto. eapply function_ptr_translated; eauto. rewrite <- H3; apply sig_preserved. constructor. constructor. @@ -257,7 +253,7 @@ Theorem transf_program_correct: forward_simulation (RTL.semantics prog) (RTL.semantics tprog). Proof. eapply forward_simulation_step. - eexact public_preserved. + apply senv_preserved. eexact transf_initial_states. eexact transf_final_states. exact step_simulation. diff --git a/backend/SelectLongproof.v b/backend/SelectLongproof.v index 35d53215..f15015e8 100644 --- a/backend/SelectLongproof.v +++ b/backend/SelectLongproof.v @@ -14,6 +14,7 @@ Require Import String. Require Import Coqlib. +Require Import Maps. Require Import AST. Require Import Errors. Require Import Integers. @@ -36,7 +37,7 @@ Open Local Scope string_scope. Definition external_implements (name: string) (sg: signature) (vargs: list val) (vres: val) : Prop := forall F V (ge: Genv.t F V) m, - external_call (EF_external name sg) ge vargs m E0 vres m. + external_call (EF_runtime name sg) ge vargs m E0 vres m. Definition builtin_implements (name: string) (sg: signature) (vargs: list val) (vres: val) : Prop := forall F V (ge: Genv.t F V) m, @@ -61,32 +62,32 @@ Axiom i64_helpers_correct : /\ (forall x y, external_implements "__i64_shr" sig_li_l (x::y::nil) (Val.shrlu x y)) /\ (forall x y, external_implements "__i64_sar" sig_li_l (x::y::nil) (Val.shrl x y)). -Definition helper_declared {F V: Type} (ge: Genv.t (AST.fundef F) V) (id: ident) (name: string) (sg: signature) : Prop := - exists b, Genv.find_symbol ge id = Some b - /\ Genv.find_funct_ptr ge b = Some (External (EF_external name sg)). - -Definition helper_functions_declared {F V: Type} (ge: Genv.t (AST.fundef F) V) (hf: helper_functions) : Prop := - helper_declared ge hf.(i64_dtos) "__i64_dtos" sig_f_l - /\ helper_declared ge hf.(i64_dtou) "__i64_dtou" sig_f_l - /\ helper_declared ge hf.(i64_stod) "__i64_stod" sig_l_f - /\ helper_declared ge hf.(i64_utod) "__i64_utod" sig_l_f - /\ helper_declared ge hf.(i64_stof) "__i64_stof" sig_l_s - /\ helper_declared ge hf.(i64_utof) "__i64_utof" sig_l_s - /\ helper_declared ge hf.(i64_sdiv) "__i64_sdiv" sig_ll_l - /\ helper_declared ge hf.(i64_udiv) "__i64_udiv" sig_ll_l - /\ helper_declared ge hf.(i64_smod) "__i64_smod" sig_ll_l - /\ helper_declared ge hf.(i64_umod) "__i64_umod" sig_ll_l - /\ helper_declared ge hf.(i64_shl) "__i64_shl" sig_li_l - /\ helper_declared ge hf.(i64_shr) "__i64_shr" sig_li_l - /\ helper_declared ge hf.(i64_sar) "__i64_sar" sig_li_l. +Definition helper_declared {F V: Type} (p: AST.program (AST.fundef F) V) (id: ident) (name: string) (sg: signature) : Prop := + (prog_defmap p)!id = Some (Gfun (External (EF_runtime name sg))). + +Definition helper_functions_declared {F V: Type} (p: AST.program (AST.fundef F) V) (hf: helper_functions) : Prop := + helper_declared p hf.(i64_dtos) "__i64_dtos" sig_f_l + /\ helper_declared p hf.(i64_dtou) "__i64_dtou" sig_f_l + /\ helper_declared p hf.(i64_stod) "__i64_stod" sig_l_f + /\ helper_declared p hf.(i64_utod) "__i64_utod" sig_l_f + /\ helper_declared p hf.(i64_stof) "__i64_stof" sig_l_s + /\ helper_declared p hf.(i64_utof) "__i64_utof" sig_l_s + /\ helper_declared p hf.(i64_sdiv) "__i64_sdiv" sig_ll_l + /\ helper_declared p hf.(i64_udiv) "__i64_udiv" sig_ll_l + /\ helper_declared p hf.(i64_smod) "__i64_smod" sig_ll_l + /\ helper_declared p hf.(i64_umod) "__i64_umod" sig_ll_l + /\ helper_declared p hf.(i64_shl) "__i64_shl" sig_li_l + /\ helper_declared p hf.(i64_shr) "__i64_shr" sig_li_l + /\ helper_declared p hf.(i64_sar) "__i64_sar" sig_li_l. (** * Correctness of the instruction selection functions for 64-bit operators *) Section CMCONSTR. -Variable ge: genv. +Variable prog: program. Variable hf: helper_functions. -Hypothesis HELPERS: helper_functions_declared ge hf. +Hypothesis HELPERS: helper_functions_declared prog hf. +Let ge := Genv.globalenv prog. Variable sp: val. Variable e: env. Variable m: mem. @@ -97,17 +98,20 @@ Ltac DeclHelper := red in HELPERS; decompose [Logic.and] HELPERS; eauto. Lemma eval_helper: forall le id name sg args vargs vres, eval_exprlist ge sp e m le args vargs -> - helper_declared ge id name sg -> + helper_declared prog id name sg -> external_implements name sg vargs vres -> eval_expr ge sp e m le (Eexternal id sg args) vres. Proof. - intros. destruct H0 as (b & P & Q). econstructor; eauto. + intros. + red in H0. apply Genv.find_def_symbol in H0. destruct H0 as (b & P & Q). + rewrite <- Genv.find_funct_ptr_iff in Q. + econstructor; eauto. Qed. Corollary eval_helper_1: forall le id name sg arg1 varg1 vres, eval_expr ge sp e m le arg1 varg1 -> - helper_declared ge id name sg -> + helper_declared prog id name sg -> external_implements name sg (varg1::nil) vres -> eval_expr ge sp e m le (Eexternal id sg (arg1 ::: Enil)) vres. Proof. @@ -118,7 +122,7 @@ Corollary eval_helper_2: forall le id name sg arg1 arg2 varg1 varg2 vres, eval_expr ge sp e m le arg1 varg1 -> eval_expr ge sp e m le arg2 varg2 -> - helper_declared ge id name sg -> + helper_declared prog id name sg -> external_implements name sg (varg1::varg2::nil) vres -> eval_expr ge sp e m le (Eexternal id sg (arg1 ::: arg2 ::: Enil)) vres. Proof. @@ -845,7 +849,7 @@ Qed. Lemma eval_binop_long: forall id name sem le a b x y z, (forall p q, x = Vlong p -> y = Vlong q -> z = Vlong (sem p q)) -> - helper_declared ge id name sig_ll_l -> + helper_declared prog id name sig_ll_l -> external_implements name sig_ll_l (x::y::nil) z -> eval_expr ge sp e m le a x -> eval_expr ge sp e m le b y -> diff --git a/backend/Selection.v b/backend/Selection.v index dcefdd1c..02b37c48 100644 --- a/backend/Selection.v +++ b/backend/Selection.v @@ -69,6 +69,8 @@ Definition store (chunk: memory_chunk) (e1 e2: expr) := Section SELECTION. +Definition globdef := AST.globdef Cminor.fundef unit. +Variable defmap: PTree.t globdef. Variable hf: helper_functions. Definition sel_constant (cst: Cminor.constant) : expr := @@ -194,17 +196,13 @@ Definition expr_is_addrof_ident (e: Cminor.expr) : option ident := | _ => None end. -Definition classify_call (ge: Cminor.genv) (e: Cminor.expr) : call_kind := +Definition classify_call (e: Cminor.expr) : call_kind := match expr_is_addrof_ident e with | None => Call_default | Some id => - match Genv.find_symbol ge id with - | None => Call_imm id - | Some b => - match Genv.find_funct_ptr ge b with - | Some(External ef) => if ef_inline ef then Call_builtin ef else Call_imm id - | _ => Call_imm id - end + match defmap!id with + | Some(Gfun(External ef)) => if ef_inline ef then Call_builtin ef else Call_imm id + | _ => Call_imm id end end. @@ -279,13 +277,13 @@ Definition sel_switch_long := (** Conversion from Cminor statements to Cminorsel statements. *) -Fixpoint sel_stmt (ge: Cminor.genv) (s: Cminor.stmt) : res stmt := +Fixpoint sel_stmt (s: Cminor.stmt) : res stmt := match s with | Cminor.Sskip => OK Sskip | Cminor.Sassign id e => OK (Sassign id (sel_expr e)) | Cminor.Sstore chunk addr rhs => OK (store chunk (sel_expr addr) (sel_expr rhs)) | Cminor.Scall optid sg fn args => - OK (match classify_call ge fn with + OK (match classify_call fn with | Call_default => Scall optid sg (inl _ (sel_expr fn)) (sel_exprlist args) | Call_imm id => Scall optid sg (inr _ id) (sel_exprlist args) | Call_builtin ef => Sbuiltin (sel_builtin_res optid) ef @@ -296,20 +294,20 @@ Fixpoint sel_stmt (ge: Cminor.genv) (s: Cminor.stmt) : res stmt := OK (Sbuiltin (sel_builtin_res optid) ef (sel_builtin_args args (Machregs.builtin_constraints ef))) | Cminor.Stailcall sg fn args => - OK (match classify_call ge fn with + OK (match classify_call fn with | Call_imm id => Stailcall sg (inr _ id) (sel_exprlist args) | _ => Stailcall sg (inl _ (sel_expr fn)) (sel_exprlist args) end) | Cminor.Sseq s1 s2 => - do s1' <- sel_stmt ge s1; do s2' <- sel_stmt ge s2; + do s1' <- sel_stmt s1; do s2' <- sel_stmt s2; OK (Sseq s1' s2') | Cminor.Sifthenelse e ifso ifnot => - do ifso' <- sel_stmt ge ifso; do ifnot' <- sel_stmt ge ifnot; + do ifso' <- sel_stmt ifso; do ifnot' <- sel_stmt ifnot; OK (Sifthenelse (condexpr_of_expr (sel_expr e)) ifso' ifnot') | Cminor.Sloop body => - do body' <- sel_stmt ge body; OK (Sloop body') + do body' <- sel_stmt body; OK (Sloop body') | Cminor.Sblock body => - do body' <- sel_stmt ge body; OK (Sblock body') + do body' <- sel_stmt body; OK (Sblock body') | Cminor.Sexit n => OK (Sexit n) | Cminor.Sswitch false e cases dfl => let t := compile_switch Int.modulus dfl cases in @@ -324,14 +322,14 @@ Fixpoint sel_stmt (ge: Cminor.genv) (s: Cminor.stmt) : res stmt := | Cminor.Sreturn None => OK (Sreturn None) | Cminor.Sreturn (Some e) => OK (Sreturn (Some (sel_expr e))) | Cminor.Slabel lbl body => - do body' <- sel_stmt ge body; OK (Slabel lbl body') + do body' <- sel_stmt body; OK (Slabel lbl body') | Cminor.Sgoto lbl => OK (Sgoto lbl) end. (** Conversion of functions. *) -Definition sel_function (ge: Cminor.genv) (f: Cminor.function) : res function := - do body' <- sel_stmt ge f.(Cminor.fn_body); +Definition sel_function (f: Cminor.function) : res function := + do body' <- sel_stmt f.(Cminor.fn_body); OK (mkfunction f.(Cminor.fn_sig) f.(Cminor.fn_params) @@ -339,41 +337,36 @@ Definition sel_function (ge: Cminor.genv) (f: Cminor.function) : res function := f.(Cminor.fn_stackspace) body'). -Definition sel_fundef (ge: Cminor.genv) (f: Cminor.fundef) : res fundef := - transf_partial_fundef (sel_function ge) f. +Definition sel_fundef (f: Cminor.fundef) : res fundef := + transf_partial_fundef sel_function f. End SELECTION. (** Setting up the helper functions. *) -Definition globdef := AST.globdef Cminor.fundef unit. - (** We build a partial mapping from global identifiers to their definitions, restricting ourselves to the globals we are interested in, namely - the external function declarations whose name starts with "__i64_". + the external function declarations that are marked as runtime library + helpers. This ensures that the mapping remains small and that [lookup_helper] below is efficient. *) Definition globdef_of_interest (gd: globdef) : bool := match gd with - | Gfun (External (EF_external name sg)) => String.prefix "__i64_" name + | Gfun (External (EF_runtime name sg)) => true | _ => false end. -Definition record_globdef (globs: PTree.t globdef) (id_gd: ident * globdef) := - let (id, gd) := id_gd in - if globdef_of_interest gd - then PTree.set id gd globs - else PTree.remove id globs. - -Definition record_globdefs (p: Cminor.program) : PTree.t globdef := - List.fold_left record_globdef p.(prog_defs) (PTree.empty _). +Definition record_globdefs (defmap: PTree.t globdef) : PTree.t globdef := + PTree.fold + (fun m id gd => if globdef_of_interest gd then PTree.set id gd m else m) + defmap (PTree.empty globdef). Definition lookup_helper_aux (name: String.string) (sg: signature) (res: option ident) (id: ident) (gd: globdef) := match gd with - | Gfun (External (EF_external name' sg')) => + | Gfun (External (EF_runtime name' sg')) => if String.string_dec name name' && signature_eq sg sg' then Some id else res @@ -389,8 +382,8 @@ Definition lookup_helper (globs: PTree.t globdef) Local Open Scope string_scope. -Definition get_helpers (p: Cminor.program) : res helper_functions := - let globs := record_globdefs p in +Definition get_helpers (defmap: PTree.t globdef) : res helper_functions := + let globs := record_globdefs defmap in do i64_dtos <- lookup_helper globs "__i64_dtos" sig_f_l ; do i64_dtou <- lookup_helper globs "__i64_dtou" sig_f_l ; do i64_stod <- lookup_helper globs "__i64_stod" sig_l_f ; @@ -412,6 +405,7 @@ Definition get_helpers (p: Cminor.program) : res helper_functions := (** Conversion of programs. *) Definition sel_program (p: Cminor.program) : res program := - do hf <- get_helpers p; - transform_partial_program (sel_fundef hf (Genv.globalenv p)) p. + let dm := prog_defmap p in + do hf <- get_helpers dm; + transform_partial_program (sel_fundef dm hf) p. diff --git a/backend/Selectionproof.v b/backend/Selectionproof.v index 8051df59..aad3add4 100644 --- a/backend/Selectionproof.v +++ b/backend/Selectionproof.v @@ -15,6 +15,7 @@ Require Import Coqlib. Require Import Maps. Require Import AST. +Require Import Linking. Require Import Errors. Require Import Integers. Require Import Values. @@ -37,6 +38,92 @@ Require Import SelectLongproof. Local Open Scope cminorsel_scope. Local Open Scope error_monad_scope. +(** * Relational specification of instruction selection *) + +Definition match_fundef (cunit: Cminor.program) (f: Cminor.fundef) (tf: CminorSel.fundef) : Prop := + exists hf, helper_functions_declared cunit hf /\ sel_fundef (prog_defmap cunit) hf f = OK tf. + +Definition match_prog (p: Cminor.program) (tp: CminorSel.program) := + match_program match_fundef eq p tp. + +(** Processing of helper functions *) + +Lemma record_globdefs_sound: + forall dm id gd, (record_globdefs dm)!id = Some gd -> dm!id = Some gd. +Proof. + intros. + set (f := fun m id gd => if globdef_of_interest gd then PTree.set id gd m else m) in *. + set (P := fun m m' => m'!id = Some gd -> m!id = Some gd). + assert (X: P dm (PTree.fold f dm (PTree.empty _))). + { apply PTree_Properties.fold_rec. + - unfold P; intros. rewrite <- H0; auto. + - red. rewrite ! PTree.gempty. auto. + - unfold P; intros. rewrite PTree.gsspec. unfold f in H3. + destruct (globdef_of_interest v). + + rewrite PTree.gsspec in H3. destruct (peq id k); auto. + + apply H2 in H3. destruct (peq id k). congruence. auto. } + apply X. auto. +Qed. + +Lemma lookup_helper_correct_1: + forall globs name sg id, + lookup_helper globs name sg = OK id -> + globs!id = Some (Gfun (External (EF_runtime name sg))). +Proof. + intros. + set (P := fun (m: PTree.t globdef) res => res = Some id -> m!id = Some(Gfun(External (EF_runtime name sg)))). + assert (P globs (PTree.fold (lookup_helper_aux name sg) globs None)). + { apply PTree_Properties.fold_rec; red; intros. + - rewrite <- H0. apply H1; auto. + - discriminate. + - assert (EITHER: k = id /\ v = Gfun (External (EF_runtime name sg)) + \/ a = Some id). + { unfold lookup_helper_aux in H3. destruct v; auto. destruct f; auto. destruct e; auto. + destruct (String.string_dec name name0); auto. + destruct (signature_eq sg sg0); auto. + inversion H3. left; split; auto. repeat f_equal; auto. } + destruct EITHER as [[X Y] | X]. + subst k v. apply PTree.gss. + apply H2 in X. rewrite PTree.gso by congruence. auto. + } + red in H0. unfold lookup_helper in H. + destruct (PTree.fold (lookup_helper_aux name sg) globs None); inv H. auto. +Qed. + +Lemma lookup_helper_correct: + forall p name sg id, + lookup_helper (record_globdefs (prog_defmap p)) name sg = OK id -> + helper_declared p id name sg. +Proof. + intros. apply lookup_helper_correct_1 in H. apply record_globdefs_sound in H. auto. +Qed. + +Lemma get_helpers_correct: + forall p hf, + get_helpers (prog_defmap p) = OK hf -> helper_functions_declared p hf. +Proof. + intros. monadInv H. red; simpl. auto 20 using lookup_helper_correct. +Qed. + +Theorem transf_program_match: + forall p tp, sel_program p = OK tp -> match_prog p tp. +Proof. + intros. monadInv H. + eapply match_transform_partial_program_contextual. eexact EQ0. + intros. exists x; split; auto. apply get_helpers_correct; auto. +Qed. + +Lemma helper_functions_declared_linkorder: + forall (p p': Cminor.program) hf, + helper_functions_declared p hf -> linkorder p p' -> helper_functions_declared p' hf. +Proof. + intros. + assert (X: forall id name sg, helper_declared p id name sg -> helper_declared p' id name sg). + { unfold helper_declared; intros. + destruct (prog_defmap_linkorder _ _ _ _ H0 H1) as (gd & P & Q). + inv Q. inv H3. auto. } + red in H. decompose [Logic.and] H; clear H. red; auto 20. +Qed. (** * Correctness of the instruction selection functions for expressions *) @@ -46,75 +133,68 @@ Variable prog: Cminor.program. Variable tprog: CminorSel.program. Let ge := Genv.globalenv prog. Let tge := Genv.globalenv tprog. -Variable hf: helper_functions. -Hypothesis HELPERS: helper_functions_declared ge hf. -Hypothesis TRANSFPROG: transform_partial_program (sel_fundef hf ge) prog = OK tprog. +Hypothesis TRANSF: match_prog prog tprog. Lemma symbols_preserved: forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. -Proof. - intros. eapply Genv.find_symbol_transf_partial; eauto. -Qed. +Proof (Genv.find_symbol_match TRANSF). -Lemma public_preserved: - forall (s: ident), Genv.public_symbol tge s = Genv.public_symbol ge s. -Proof. - intros. eapply Genv.public_symbol_transf_partial; eauto. -Qed. +Lemma senv_preserved: + Senv.equiv (Genv.to_senv ge) (Genv.to_senv tge). +Proof (Genv.senv_match TRANSF). Lemma function_ptr_translated: forall (b: block) (f: Cminor.fundef), Genv.find_funct_ptr ge b = Some f -> - exists tf, Genv.find_funct_ptr tge b = Some tf /\ sel_fundef hf ge f = OK tf. -Proof. - intros. eapply Genv.find_funct_ptr_transf_partial; eauto. -Qed. + exists cu tf, Genv.find_funct_ptr tge b = Some tf /\ match_fundef cu f tf /\ linkorder cu prog. +Proof (Genv.find_funct_ptr_match TRANSF). Lemma functions_translated: forall (v v': val) (f: Cminor.fundef), Genv.find_funct ge v = Some f -> Val.lessdef v v' -> - exists tf, Genv.find_funct tge v' = Some tf /\ sel_fundef hf ge f = OK tf. + exists cu tf, Genv.find_funct tge v' = Some tf /\ match_fundef cu f tf /\ linkorder cu prog. Proof. intros. inv H0. - eapply Genv.find_funct_transf_partial; eauto. - simpl in H. discriminate. + eapply Genv.find_funct_match; eauto. + discriminate. Qed. Lemma sig_function_translated: - forall f tf, sel_fundef hf ge f = OK tf -> funsig tf = Cminor.funsig f. + forall cu f tf, match_fundef cu f tf -> funsig tf = Cminor.funsig f. Proof. - intros. destruct f; monadInv H; auto. monadInv EQ. auto. + intros. destruct H as (hf & P & Q). destruct f; monadInv Q; auto. monadInv EQ; auto. Qed. Lemma stackspace_function_translated: - forall f tf, sel_function hf ge f = OK tf -> fn_stackspace tf = Cminor.fn_stackspace f. + forall dm hf f tf, sel_function dm hf f = OK tf -> fn_stackspace tf = Cminor.fn_stackspace f. Proof. intros. monadInv H. auto. Qed. -Lemma varinfo_preserved: - forall b, Genv.find_var_info tge b = Genv.find_var_info ge b. +Lemma helper_functions_preserved: + forall hf, helper_functions_declared prog hf -> helper_functions_declared tprog hf. Proof. - intros; eapply Genv.find_var_info_transf_partial; eauto. + assert (X: forall id name sg, helper_declared prog id name sg -> helper_declared tprog id name sg). + { unfold helper_declared; intros. + generalize (match_program_defmap _ _ _ _ _ TRANSF id). + unfold Cminor.fundef; rewrite H; intros R; inv R. inv H2. + destruct H4 as (cu & A & B). monadInv B. auto. } + unfold helper_functions_declared; intros. decompose [Logic.and] H; clear H. auto 20. Qed. -Lemma helper_declared_preserved: - forall id name sg, helper_declared ge id name sg -> helper_declared tge id name sg. -Proof. - intros id name sg (b & A & B). - exploit function_ptr_translated; eauto. simpl. intros (tf & P & Q). inv Q. - exists b; split; auto. rewrite symbols_preserved. auto. -Qed. +Section CMCONSTR. + +Variable cunit: Cminor.program. +Variable hf: helper_functions. +Hypothesis LINK: linkorder cunit prog. +Hypothesis HF: helper_functions_declared cunit hf. -Let HELPERS': helper_functions_declared tge hf. +Let HF': helper_functions_declared tprog hf. Proof. - red in HELPERS; decompose [Logic.and] HELPERS. - red. auto 20 using helper_declared_preserved. + apply helper_functions_preserved. eapply helper_functions_declared_linkorder; eauto. Qed. -Section CMCONSTR. - Variable sp: val. Variable e: env. Variable m: mem. @@ -172,6 +252,7 @@ Lemma eval_sel_unop: forall le op a1 v1 v, eval_expr tge sp e m le a1 v1 -> eval_unop op v1 = Some v -> + exists v', eval_expr tge sp e m le (sel_unop hf op a1) v' /\ Val.lessdef v v'. Proof. destruct op; simpl; intros; FuncInv; try subst v. @@ -276,26 +357,30 @@ Proof. Qed. Lemma classify_call_correct: - forall sp e m a v fd, + forall unit sp e m a v fd, + linkorder unit prog -> Cminor.eval_expr ge sp e m a v -> Genv.find_funct ge v = Some fd -> - match classify_call ge a with + match classify_call (prog_defmap unit) a with | Call_default => True | Call_imm id => exists b, Genv.find_symbol ge id = Some b /\ v = Vptr b Int.zero | Call_builtin ef => fd = External ef end. Proof. unfold classify_call; intros. - destruct (expr_is_addrof_ident a) as [id|] eqn:?. + destruct (expr_is_addrof_ident a) as [id|] eqn:EA; auto. exploit expr_is_addrof_ident_correct; eauto. intros EQ; subst a. - inv H. inv H2. - destruct (Genv.find_symbol ge id) as [b|] eqn:?. - rewrite Genv.find_funct_find_funct_ptr in H0. - rewrite H0. - destruct fd. exists b; auto. - destruct (ef_inline e0). auto. exists b; auto. - simpl in H0. discriminate. - auto. + inv H0. inv H3. + destruct (Genv.find_symbol ge id) as [b|] eqn:FS; try discriminate. + rewrite Genv.find_funct_find_funct_ptr in H1. + assert (DFL: exists b1, Genv.find_symbol ge id = Some b1 /\ Vptr b Int.zero = Vptr b1 Int.zero) by (exists b; auto). + unfold globdef; destruct (prog_defmap unit)!id as [[[f|ef] |gv] |] eqn:G; auto. + destruct (ef_inline ef) eqn:INLINE; auto. + destruct (prog_defmap_linkorder _ _ _ _ H G) as (gd & P & Q). + inv Q. inv H2. +- apply Genv.find_def_symbol in P. destruct P as (b' & X & Y). fold ge in X, Y. + rewrite <- Genv.find_funct_ptr_iff in Y. congruence. +- simpl in INLINE. discriminate. Qed. (** Translation of [switch] statements *) @@ -547,6 +632,13 @@ Qed. (** Semantic preservation for expressions. *) +Section EXPRESSIONS. + +Variable cunit: Cminor.program. +Variable hf: helper_functions. +Hypothesis LINK: linkorder cunit prog. +Hypothesis HF: helper_functions_declared cunit hf. + Lemma sel_expr_correct: forall sp e m a v, Cminor.eval_expr ge sp e m a v -> @@ -576,7 +668,7 @@ Proof. exploit IHeval_expr1; eauto. intros [v1' [A B]]. exploit IHeval_expr2; eauto. intros [v2' [C D]]. exploit eval_binop_lessdef; eauto. intros [v' [E F]]. - exploit eval_sel_binop. eexact A. eexact C. eauto. intros [v'' [P Q]]. + exploit eval_sel_binop. eexact LINK. eexact HF. eexact A. eexact C. eauto. intros [v'' [P Q]]. exists v''; split; eauto. eapply Val.lessdef_trans; eauto. (* Eload *) exploit IHeval_expr; eauto. intros [vaddr' [A B]]. @@ -641,51 +733,89 @@ Proof. intros. destruct oid; simpl; auto. apply set_var_lessdef; auto. Qed. +End EXPRESSIONS. + (** Semantic preservation for functions and statements. *) -Inductive match_cont: Cminor.cont -> CminorSel.cont -> Prop := - | match_cont_stop: - match_cont Cminor.Kstop Kstop - | match_cont_seq: forall s s' k k', - sel_stmt hf ge s = OK s' -> - match_cont k k' -> - match_cont (Cminor.Kseq s k) (Kseq s' k') - | match_cont_block: forall k k', - match_cont k k' -> - match_cont (Cminor.Kblock k) (Kblock k') - | match_cont_call: forall id f sp e k f' e' k', - sel_function hf ge f = OK f' -> - match_cont k k' -> env_lessdef e e' -> - match_cont (Cminor.Kcall id f sp e k) (Kcall id f' sp e' k'). +(* +Inductive match_call_cont: Cminor.cont -> CminorSel.cont -> Prop := + | match_call_cont_stop: + match_call_cont Cminor.Kstop Kstop + | match_call_cont_call: forall cunit hf id f sp e k f' e' k', + linkorder cunit prog -> + helper_functions_declared cunit hf -> + sel_function (prog_defmap cunit) hf f = OK f' -> + match_cont cunit hf k k' -> env_lessdef e e' -> + match_call_cont (Cminor.Kcall id f sp e k) (Kcall id f' sp e' k') + +with match_cont: Cminor.program -> helper_functions -> Cminor.cont -> CminorSel.cont -> Prop := + | match_cont_stop: forall cunit hf, + match_cont cunit hf Cminor.Kstop Kstop + | match_cont_seq: forall cunit hf s s' k k', + sel_stmt (prog_defmap cunit) hf s = OK s' -> + match_cont cunit hf k k' -> + match_cont cunit hf (Cminor.Kseq s k) (Kseq s' k') + | match_cont_block: forall cunit hf k k', + match_cont cunit hf k k' -> + match_cont cunit hf (Cminor.Kblock k) (Kblock k') + | match_cont_call: forall cunit hf id f sp e k f' e' k', + match_call_cont (Cminor.Kcall id f sp e k) (Kcall id f' sp e' k') -> + match_cont cunit hf (Cminor.Kcall id f sp e k) (Kcall id f' sp e' k'). +*) + +Inductive match_cont: Cminor.program -> helper_functions -> Cminor.cont -> CminorSel.cont -> Prop := + | match_cont_stop: forall cunit hf, + match_cont cunit hf Cminor.Kstop Kstop + | match_cont_seq: forall cunit hf s s' k k', + sel_stmt (prog_defmap cunit) hf s = OK s' -> + match_cont cunit hf k k' -> + match_cont cunit hf (Cminor.Kseq s k) (Kseq s' k') + | match_cont_block: forall cunit hf k k', + match_cont cunit hf k k' -> + match_cont cunit hf (Cminor.Kblock k) (Kblock k') + | match_cont_call: forall cunit' hf' cunit hf id f sp e k f' e' k', + linkorder cunit prog -> + helper_functions_declared cunit hf -> + sel_function (prog_defmap cunit) hf f = OK f' -> + match_cont cunit hf k k' -> env_lessdef e e' -> + match_cont cunit' hf' (Cminor.Kcall id f sp e k) (Kcall id f' sp e' k'). + +Definition match_call_cont (k: Cminor.cont) (k': CminorSel.cont) : Prop := + forall cunit hf, match_cont cunit hf k k'. Inductive match_states: Cminor.state -> CminorSel.state -> Prop := - | match_state: forall f f' s k s' k' sp e m e' m' - (TF: sel_function hf ge f = OK f') - (TS: sel_stmt hf ge s = OK s') - (MC: match_cont k k') + | match_state: forall cunit hf f f' s k s' k' sp e m e' m' + (LINK: linkorder cunit prog) + (HF: helper_functions_declared cunit hf) + (TF: sel_function (prog_defmap cunit) hf f = OK f') + (TS: sel_stmt (prog_defmap cunit) hf s = OK s') + (MC: match_cont cunit hf k k') (LD: env_lessdef e e') (ME: Mem.extends m m'), match_states (Cminor.State f s k sp e m) (State f' s' k' sp e' m') - | match_callstate: forall f f' args args' k k' m m' - (TF: sel_fundef hf ge f = OK f') - (MC: match_cont k k') + | match_callstate: forall cunit f f' args args' k k' m m' + (LINK: linkorder cunit prog) + (TF: match_fundef cunit f f') + (MC: match_call_cont k k') (LD: Val.lessdef_list args args') (ME: Mem.extends m m'), match_states (Cminor.Callstate f args k m) (Callstate f' args' k' m') | match_returnstate: forall v v' k k' m m' - (MC: match_cont k k') + (MC: match_call_cont k k') (LD: Val.lessdef v v') (ME: Mem.extends m m'), match_states (Cminor.Returnstate v k m) (Returnstate v' k' m') - | match_builtin_1: forall ef args args' optid f sp e k m al f' e' k' m' - (TF: sel_function hf ge f = OK f') - (MC: match_cont k k') + | match_builtin_1: forall cunit hf ef args args' optid f sp e k m al f' e' k' m' + (LINK: linkorder cunit prog) + (HF: helper_functions_declared cunit hf) + (TF: sel_function (prog_defmap cunit) hf f = OK f') + (MC: match_cont cunit hf k k') (LDA: Val.lessdef_list args args') (LDE: env_lessdef e e') (ME: Mem.extends m m') @@ -693,9 +823,11 @@ Inductive match_states: Cminor.state -> CminorSel.state -> Prop := match_states (Cminor.Callstate (External ef) args (Cminor.Kcall optid f sp e k) m) (State f' (Sbuiltin (sel_builtin_res optid) ef al) k' sp e' m') - | match_builtin_2: forall v v' optid f sp e k m f' e' m' k' - (TF: sel_function hf ge f = OK f') - (MC: match_cont k k') + | match_builtin_2: forall cunit hf v v' optid f sp e k m f' e' m' k' + (LINK: linkorder cunit prog) + (HF: helper_functions_declared cunit hf) + (TF: sel_function (prog_defmap cunit) hf f = OK f') + (MC: match_cont cunit hf k k') (LDV: Val.lessdef v v') (LDE: env_lessdef e e') (ME: Mem.extends m m'), @@ -703,19 +835,50 @@ Inductive match_states: Cminor.state -> CminorSel.state -> Prop := (Cminor.Returnstate v (Cminor.Kcall optid f sp e k) m) (State f' Sskip k' sp (set_builtin_res (sel_builtin_res optid) v' e') m'). +(* +Remark call_cont_commut_1: + forall cunit hf k k', match_cont cunit hf k k' -> + forall cunit' hf', match_cont cunit' hf' (Cminor.call_cont k) (call_cont k'). +Proof. + induction 1; simpl; auto; intros; econstructor; eauto. +Qed. + +Remark call_cont_commut_2: + forall cunit hf k k', match_cont cunit hf k k' -> match_cont cunit hf (Cminor.call_cont k) (call_cont k'). +Proof. + intros. eapply call_cont_commut_1; eauto. +Qed. +*) + Remark call_cont_commut: - forall k k', match_cont k k' -> match_cont (Cminor.call_cont k) (call_cont k'). + forall cunit hf k k', match_cont cunit hf k k' -> match_call_cont (Cminor.call_cont k) (call_cont k'). Proof. - induction 1; simpl; auto. constructor. constructor; auto. + induction 1; simpl; auto; red; intros; econstructor; eauto. +Qed. + +Remark match_is_call_cont: + forall cunit hf k k', match_cont cunit hf k k' -> Cminor.is_call_cont k -> match_call_cont k k'. +Proof. + destruct 1; intros; try contradiction; red; intros; econstructor; eauto. +Qed. + +Remark match_call_cont_cont: + forall k k', match_call_cont k k' -> exists cunit hf, match_cont cunit hf k k'. +Proof. + intros. refine (let cunit : Cminor.program := _ in _). + econstructor. apply nil. apply nil. apply xH. + refine (let hf : helper_functions := _ in _). + econstructor; apply xH. + exists cunit, hf; auto. Qed. Remark find_label_commut: - forall lbl s k s' k', - match_cont k k' -> - sel_stmt hf ge s = OK s' -> + forall cunit hf lbl s k s' k', + match_cont cunit hf k k' -> + sel_stmt (prog_defmap cunit) hf s = OK s' -> match Cminor.find_label lbl s k, find_label lbl s' k' with | None, None => True - | Some(s1, k1), Some(s1', k1') => sel_stmt hf ge s1 = OK s1' /\ match_cont k1 k1' + | Some(s1, k1), Some(s1', k1') => sel_stmt (prog_defmap cunit) hf s1 = OK s1' /\ match_cont cunit hf k1 k1' | _, _ => False end. Proof. @@ -723,9 +886,9 @@ Proof. (* store *) unfold store. destruct (addressing m (sel_expr hf e)); simpl; auto. (* call *) - destruct (classify_call ge e); simpl; auto. + destruct (classify_call (prog_defmap cunit) e); simpl; auto. (* tailcall *) - destruct (classify_call ge e); simpl; auto. + destruct (classify_call (prog_defmap cunit) e); simpl; auto. (* seq *) exploit (IHs1 (Cminor.Kseq s2 k)). constructor; eauto. eauto. destruct (Cminor.find_label lbl s1 (Cminor.Kseq s2 k)) as [[sx kx] | ]; @@ -767,48 +930,50 @@ Lemma sel_step_correct: Proof. induction 1; intros T1 ME; inv ME; try (monadInv TS). - (* skip seq *) - inv MC. left; econstructor; split. econstructor. constructor; auto. + inv MC. left; econstructor; split. econstructor. econstructor; eauto. - (* skip block *) - inv MC. left; econstructor; split. econstructor. constructor; auto. + inv MC. left; econstructor; split. econstructor. econstructor; eauto. - (* skip call *) exploit Mem.free_parallel_extends; eauto. intros [m2' [A B]]. left; econstructor; split. econstructor. inv MC; simpl in H; simpl; auto. eauto. erewrite stackspace_function_translated; eauto. - constructor; auto. + econstructor; eauto. eapply match_is_call_cont; eauto. - (* assign *) exploit sel_expr_correct; eauto. intros [v' [A B]]. left; econstructor; split. econstructor; eauto. - constructor; auto. apply set_var_lessdef; auto. + econstructor; eauto. apply set_var_lessdef; auto. - (* store *) - exploit sel_expr_correct. eexact H. eauto. eauto. intros [vaddr' [A B]]. - exploit sel_expr_correct. eexact H0. eauto. eauto. intros [v' [C D]]. + exploit sel_expr_correct. eauto. eauto. eexact H. eauto. eauto. intros [vaddr' [A B]]. + exploit sel_expr_correct. eauto. eauto. eexact H0. eauto. eauto. intros [v' [C D]]. exploit Mem.storev_extends; eauto. intros [m2' [P Q]]. left; econstructor; split. eapply eval_store; eauto. - constructor; auto. + econstructor; eauto. - (* Scall *) exploit classify_call_correct; eauto. - destruct (classify_call ge a) as [ | id | ef]. + destruct (classify_call (prog_defmap cunit) a) as [ | id | ef]. + (* indirect *) exploit sel_expr_correct; eauto. intros [vf' [A B]]. exploit sel_exprlist_correct; eauto. intros [vargs' [C D]]. - exploit functions_translated; eauto. intros (fd' & U & V). + exploit functions_translated; eauto. intros (cunit' & fd' & U & V & W). left; econstructor; split. econstructor; eauto. econstructor; eauto. - apply sig_function_translated; auto. - constructor; auto. constructor; auto. + eapply sig_function_translated; eauto. + eapply match_callstate with (cunit := cunit'); eauto. + red; intros. eapply match_cont_call with (cunit := cunit); eauto. + (* direct *) intros [b [U V]]. exploit sel_exprlist_correct; eauto. intros [vargs' [C D]]. - exploit functions_translated; eauto. intros (fd' & X & Y). + exploit functions_translated; eauto. intros (cunit' & fd' & X & Y & Z). left; econstructor; split. econstructor; eauto. subst vf. econstructor; eauto. rewrite symbols_preserved; eauto. - apply sig_function_translated; auto. - constructor; auto. constructor; auto. + eapply sig_function_translated; eauto. + eapply match_callstate with (cunit := cunit'); eauto. + red; intros; eapply match_cont_call with (cunit := cunit); eauto. + (* turned into Sbuiltin *) intros EQ. subst fd. exploit sel_builtin_args_correct; eauto. intros [vargs' [C D]]. @@ -819,43 +984,44 @@ Proof. erewrite <- stackspace_function_translated in P by eauto. exploit sel_expr_correct; eauto. intros [vf' [A B]]. exploit sel_exprlist_correct; eauto. intros [vargs' [C D]]. - exploit functions_translated; eauto. intros [fd' [E F]]. + exploit functions_translated; eauto. intros (cunit' & fd' & E & F & G). left; econstructor; split. - exploit classify_call_correct; eauto. - destruct (classify_call ge a) as [ | id | ef]; intros. - econstructor; eauto. econstructor; eauto. apply sig_function_translated; auto. + exploit classify_call_correct. eexact LINK. eauto. eauto. + destruct (classify_call (prog_defmap cunit)) as [ | id | ef]; intros. + econstructor; eauto. econstructor; eauto. eapply sig_function_translated; eauto. destruct H2 as [b [U V]]. subst vf. inv B. - econstructor; eauto. econstructor; eauto. rewrite symbols_preserved; eauto. apply sig_function_translated; auto. - econstructor; eauto. econstructor; eauto. apply sig_function_translated; auto. - constructor; auto. apply call_cont_commut; auto. + econstructor; eauto. econstructor; eauto. rewrite symbols_preserved; eauto. eapply sig_function_translated; eauto. + econstructor; eauto. econstructor; eauto. eapply sig_function_translated; eauto. + eapply match_callstate with (cunit := cunit'); eauto. + eapply call_cont_commut; eauto. - (* Sbuiltin *) exploit sel_builtin_args_correct; eauto. intros [vargs' [P Q]]. exploit external_call_mem_extends; eauto. intros [vres' [m2 [A [B [C D]]]]]. left; econstructor; split. - econstructor. eauto. eapply external_call_symbols_preserved; eauto. - exact symbols_preserved. exact public_preserved. exact varinfo_preserved. - constructor; auto. apply sel_builtin_res_correct; auto. + econstructor. eauto. eapply external_call_symbols_preserved; eauto. apply senv_preserved. + econstructor; eauto. apply sel_builtin_res_correct; auto. - (* Seq *) left; econstructor; split. - constructor. constructor; auto. constructor; auto. + constructor. + econstructor; eauto. constructor; auto. - (* Sifthenelse *) exploit sel_expr_correct; eauto. intros [v' [A B]]. assert (Val.bool_of_val v' b). inv B. auto. inv H0. left; exists (State f' (if b then x else x0) k' sp e' m'); split. econstructor; eauto. eapply eval_condexpr_of_expr; eauto. - constructor; auto. destruct b; auto. + econstructor; eauto. destruct b; auto. - (* Sloop *) - left; econstructor; split. constructor. constructor; auto. + left; econstructor; split. constructor. econstructor; eauto. constructor; auto. simpl; rewrite EQ; auto. - (* Sblock *) - left; econstructor; split. constructor. constructor; auto. constructor; auto. + left; econstructor; split. constructor. econstructor; eauto. constructor; auto. - (* Sexit seq *) - inv MC. left; econstructor; split. constructor. constructor; auto. + inv MC. left; econstructor; split. constructor. econstructor; eauto. - (* Sexit0 block *) - inv MC. left; econstructor; split. constructor. constructor; auto. + inv MC. left; econstructor; split. constructor. econstructor; eauto. - (* SexitS block *) - inv MC. left; econstructor; split. constructor. constructor; auto. + inv MC. left; econstructor; split. constructor. econstructor; eauto. - (* Sswitch *) inv H0; simpl in TS. + set (ct := compile_switch Int.modulus default cases) in *. @@ -863,69 +1029,70 @@ Proof. exploit sel_expr_correct; eauto. intros [v' [A B]]. inv B. left; econstructor; split. econstructor. eapply sel_switch_int_correct; eauto. - constructor; auto. + econstructor; eauto. + set (ct := compile_switch Int64.modulus default cases) in *. destruct (validate_switch Int64.modulus default cases ct) eqn:VALID; inv TS. exploit sel_expr_correct; eauto. intros [v' [A B]]. inv B. left; econstructor; split. econstructor. eapply sel_switch_long_correct; eauto. - constructor; auto. + econstructor; eauto. - (* Sreturn None *) exploit Mem.free_parallel_extends; eauto. intros [m2' [P Q]]. erewrite <- stackspace_function_translated in P by eauto. left; econstructor; split. econstructor. simpl; eauto. - constructor; auto. apply call_cont_commut; auto. + econstructor; eauto. eapply call_cont_commut; eauto. - (* Sreturn Some *) exploit Mem.free_parallel_extends; eauto. intros [m2' [P Q]]. erewrite <- stackspace_function_translated in P by eauto. exploit sel_expr_correct; eauto. intros [v' [A B]]. left; econstructor; split. econstructor; eauto. - constructor; auto. apply call_cont_commut; auto. + econstructor; eauto. eapply call_cont_commut; eauto. - (* Slabel *) - left; econstructor; split. constructor. constructor; auto. + left; econstructor; split. constructor. econstructor; eauto. - (* Sgoto *) - assert (sel_stmt hf ge (Cminor.fn_body f) = OK (fn_body f')). + assert (sel_stmt (prog_defmap cunit) hf (Cminor.fn_body f) = OK (fn_body f')). { monadInv TF; simpl; auto. } - exploit (find_label_commut lbl (Cminor.fn_body f) (Cminor.call_cont k)). - apply call_cont_commut; eauto. eauto. + exploit (find_label_commut cunit hf lbl (Cminor.fn_body f) (Cminor.call_cont k)). + eapply call_cont_commut; eauto. eauto. rewrite H. destruct (find_label lbl (fn_body f') (call_cont k'0)) as [[s'' k'']|] eqn:?; intros; try contradiction. destruct H1. left; econstructor; split. econstructor; eauto. - constructor; auto. + econstructor; eauto. - (* internal function *) + destruct TF as (hf & HF & TF). specialize (MC cunit hf). monadInv TF. generalize EQ; intros TF; monadInv TF. exploit Mem.alloc_extends. eauto. eauto. apply Zle_refl. apply Zle_refl. intros [m2' [A B]]. left; econstructor; split. econstructor; simpl; eauto. - constructor; simpl; auto. apply set_locals_lessdef. apply set_params_lessdef; auto. + econstructor; simpl; eauto. apply set_locals_lessdef. apply set_params_lessdef; auto. - (* external call *) + destruct TF as (hf & HF & TF). monadInv TF. exploit external_call_mem_extends; eauto. intros [vres' [m2 [A [B [C D]]]]]. left; econstructor; split. - econstructor. eapply external_call_symbols_preserved; eauto. - exact symbols_preserved. exact public_preserved. exact varinfo_preserved. - constructor; auto. + econstructor. eapply external_call_symbols_preserved; eauto. apply senv_preserved. + econstructor; eauto. - (* external call turned into a Sbuiltin *) exploit external_call_mem_extends; eauto. intros [vres' [m2 [A [B [C D]]]]]. left; econstructor; split. - econstructor. eauto. eapply external_call_symbols_preserved; eauto. - exact symbols_preserved. exact public_preserved. exact varinfo_preserved. - constructor; auto. + econstructor. eauto. eapply external_call_symbols_preserved; eauto. apply senv_preserved. + econstructor; eauto. - (* return *) + apply match_call_cont_cont in MC. destruct MC as (cunit0 & hf0 & MC). inv MC. left; econstructor; split. econstructor. - constructor; auto. destruct optid; simpl; auto. apply set_var_lessdef; auto. + econstructor; eauto. destruct optid; simpl; auto. apply set_var_lessdef; auto. - (* return of an external call turned into a Sbuiltin *) - right; split. simpl; omega. split. auto. constructor; auto. + right; split. simpl; omega. split. auto. econstructor; eauto. apply sel_builtin_res_correct; auto. Qed. @@ -933,118 +1100,49 @@ Lemma sel_initial_states: forall S, Cminor.initial_state prog S -> exists R, initial_state tprog R /\ match_states S R. Proof. - induction 1. - exploit function_ptr_translated; eauto. intros (f' & A & B). + destruct 1. + exploit function_ptr_translated; eauto. intros (cu & f' & A & B & C). econstructor; split. econstructor. - eapply Genv.init_mem_transf_partial; eauto. - simpl. fold tge. rewrite symbols_preserved. - erewrite transform_partial_program_main by eauto. eexact H0. - eauto. - rewrite <- H2. apply sig_function_translated; auto. - constructor; auto. constructor. apply Mem.extends_refl. + eapply (Genv.init_mem_match TRANSF); eauto. + rewrite (match_program_main TRANSF). fold tge. rewrite symbols_preserved. eauto. + eexact A. + rewrite <- H2. eapply sig_function_translated; eauto. + econstructor; eauto. red; intros; constructor. apply Mem.extends_refl. Qed. Lemma sel_final_states: forall S R r, match_states S R -> Cminor.final_state S r -> final_state R r. Proof. - intros. inv H0. inv H. inv MC. inv LD. constructor. -Qed. - -End PRESERVATION. - -(** Processing of helper functions *) - -Lemma record_globdefs_sound: - forall p id fd, - (record_globdefs p)!id = Some (Gfun fd) -> - exists b, Genv.find_symbol (Genv.globalenv p) id = Some b - /\ Genv.find_funct_ptr (Genv.globalenv p) b = Some fd. -Proof. - intros until fd. - set (P := fun (m: PTree.t globdef) (ge: Genv.t Cminor.fundef unit) => - m!id = Some (Gfun fd) -> - exists b, Genv.find_symbol ge id = Some b - /\ Genv.find_funct_ptr ge b = Some fd). - assert (REC: forall gl m ge, - P m ge -> - P (fold_left record_globdef gl m) (Genv.add_globals ge gl)). - { - induction gl; simpl; intros. - - auto. - - apply IHgl. red. destruct a as [id1 gd1]; simpl; intros. - unfold Genv.find_symbol; simpl. rewrite PTree.gsspec. destruct (peq id id1). - + subst id1. exists (Genv.genv_next ge); split; auto. - replace gd1 with (@Gfun Cminor.fundef unit fd). - unfold Genv.find_funct_ptr; simpl. apply PTree.gss. - destruct (globdef_of_interest gd1). - rewrite PTree.gss in H0; congruence. - rewrite PTree.grs in H0; congruence. - + assert (m!id = Some (Gfun fd)). - { destruct (globdef_of_interest gd1). - rewrite PTree.gso in H0; auto. - rewrite PTree.gro in H0; auto. } - exploit H; eauto. intros (b & A & B). - exists b; split; auto. unfold Genv.find_funct_ptr; simpl. - destruct gd1; auto. rewrite PTree.gso; auto. - apply Plt_ne. eapply Genv.genv_symb_range; eauto. - } - eapply REC. red; intros. rewrite PTree.gempty in H; discriminate. -Qed. - -Lemma lookup_helper_correct_1: - forall globs name sg id, - lookup_helper globs name sg = OK id -> - globs!id = Some (Gfun (External (EF_external name sg))). -Proof. - intros. - set (P := fun (m: PTree.t globdef) res => res = Some id -> m!id = Some(Gfun(External (EF_external name sg)))). - assert (P globs (PTree.fold (lookup_helper_aux name sg) globs None)). - { apply PTree_Properties.fold_rec; red; intros. - - rewrite <- H0. apply H1; auto. - - discriminate. - - assert (EITHER: k = id /\ v = Gfun (External (EF_external name sg)) - \/ a = Some id). - { unfold lookup_helper_aux in H3. destruct v; auto. destruct f; auto. destruct e; auto. - destruct (String.string_dec name name0); auto. - destruct (signature_eq sg sg0); auto. - inversion H3. left; split; auto. repeat f_equal; auto. } - destruct EITHER as [[X Y] | X]. - subst k v. apply PTree.gss. - apply H2 in X. rewrite PTree.gso by congruence. auto. - } - red in H0. unfold lookup_helper in H. - destruct (PTree.fold (lookup_helper_aux name sg) globs None); inv H. auto. + intros. inv H0. inv H. + apply match_call_cont_cont in MC. destruct MC as (cunit0 & hf0 & MC). + inv MC. inv LD. constructor. Qed. -Lemma lookup_helper_correct: - forall p name sg id, - lookup_helper (record_globdefs p) name sg = OK id -> - helper_declared (Genv.globalenv p) id name sg. +Theorem transf_program_correct: + forward_simulation (Cminor.semantics prog) (CminorSel.semantics tprog). Proof. - intros. apply lookup_helper_correct_1 in H. apply record_globdefs_sound in H. auto. + apply forward_simulation_opt with (match_states := match_states) (measure := measure). + apply senv_preserved. + apply sel_initial_states; auto. + apply sel_final_states; auto. + apply sel_step_correct; auto. Qed. -Theorem get_helpers_correct: - forall p hf, - get_helpers p = OK hf -> helper_functions_declared (Genv.globalenv p) hf. -Proof. - intros. monadInv H. red; simpl. auto 20 using lookup_helper_correct. -Qed. +End PRESERVATION. -(** All together *) +(** ** Commutation with linking *) -Theorem transf_program_correct: - forall prog tprog, - sel_program prog = OK tprog -> - forward_simulation (Cminor.semantics prog) (CminorSel.semantics tprog). +Instance TransfSelectionLink : TransfLink match_prog. Proof. - intros. unfold sel_program in H. - destruct (get_helpers prog) as [hf|] eqn:G; simpl in H; try discriminate. - apply forward_simulation_opt with (match_states := match_states prog tprog hf) (measure := measure). - eapply public_preserved; eauto. - apply sel_initial_states; auto. - apply sel_final_states; auto. - apply sel_step_correct; auto. eapply get_helpers_correct; eauto. + red; intros. destruct (link_linkorder _ _ _ H) as [LO1 LO2]. + eapply link_match_program; eauto. + intros. elim H3; intros hf1 [A1 B1]. elim H4; intros hf2 [A2 B2]. +Local Transparent Linker_fundef. + simpl in *. destruct f1, f2; simpl in *; monadInv B1; monadInv B2; simpl. +- discriminate. +- destruct e; inv H2. econstructor; eauto. +- destruct e; inv H2. econstructor; eauto. +- destruct (external_function_eq e e0); inv H2. econstructor; eauto. Qed. diff --git a/backend/Stacking.v b/backend/Stacking.v index ab67e213..cf797a11 100644 --- a/backend/Stacking.v +++ b/backend/Stacking.v @@ -12,18 +12,10 @@ (** Layout of activation records; translation from Linear to Mach. *) -Require Import Coqlib. -Require Import Errors. -Require Import AST. -Require Import Integers. -Require Import Op. -Require Import Locations. -Require Import Linear. -Require Import Bounds. -Require Import Mach. -Require Import Conventions. -Require Import Stacklayout. -Require Import Lineartyping. +Require Import Coqlib Errors. +Require Import Integers AST. +Require Import Op Locations Linear Mach. +Require Import Bounds Conventions Stacklayout Lineartyping. (** * Layout of activation records *) diff --git a/backend/Stackingproof.v b/backend/Stackingproof.v index 8becb773..a76fdbba 100644 --- a/backend/Stackingproof.v +++ b/backend/Stackingproof.v @@ -14,26 +14,22 @@ (** This file proves semantic preservation for the [Stacking] pass. *) -Require Import Coqlib. -Require Import Errors. -Require Import AST. -Require Import Integers. -Require Import Values. -Require Import Op. -Require Import Memory. -Require Import Events. -Require Import Globalenvs. -Require Import Smallstep. -Require Import Locations. -Require Import LTL. -Require Import Linear. -Require Import Lineartyping. -Require Import Mach. -Require Import Bounds. -Require Import Conventions. -Require Import Stacklayout. +Require Import Coqlib Errors. +Require Import Integers AST Linking. +Require Import Values Memory Events Globalenvs Smallstep. +Require Import LTL Op Locations Linear Mach. +Require Import Bounds Conventions Stacklayout Lineartyping. Require Import Stacking. +Definition match_prog (p: Linear.program) (tp: Mach.program) := + match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp. + +Lemma transf_program_match: + forall p tp, transf_program p = OK tp -> match_prog p tp. +Proof. + intros. eapply match_transform_partial_program; eauto. +Qed. + (** * Properties of frame offsets *) Lemma typesize_typesize: @@ -61,11 +57,10 @@ Let step := Mach.step return_address_offset. Variable prog: Linear.program. Variable tprog: Mach.program. -Hypothesis TRANSF: transf_program prog = OK tprog. +Hypothesis TRANSF: match_prog prog tprog. Let ge := Genv.globalenv prog. Let tge := Genv.globalenv tprog. - Section FRAME_PROPERTIES. Variable f: Linear.function. @@ -2261,44 +2256,26 @@ Qed. (** Preservation / translation of global symbols and functions. *) Lemma symbols_preserved: - forall id, Genv.find_symbol tge id = Genv.find_symbol ge id. -Proof. - intros. unfold ge, tge. - apply Genv.find_symbol_transf_partial with transf_fundef. - exact TRANSF. -Qed. + forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. +Proof (Genv.find_symbol_match TRANSF). -Lemma public_preserved: - forall id, Genv.public_symbol tge id = Genv.public_symbol ge id. -Proof. - intros. unfold ge, tge. - apply Genv.public_symbol_transf_partial with transf_fundef. - exact TRANSF. -Qed. - -Lemma varinfo_preserved: - forall b, Genv.find_var_info tge b = Genv.find_var_info ge b. -Proof. - intros. unfold ge, tge. - apply Genv.find_var_info_transf_partial with transf_fundef. - exact TRANSF. -Qed. +Lemma senv_preserved: + Senv.equiv ge tge. +Proof (Genv.senv_match TRANSF). Lemma functions_translated: forall v f, 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). Lemma function_ptr_translated: - forall v f, - Genv.find_funct_ptr ge v = Some f -> + forall b f, + Genv.find_funct_ptr ge b = 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). + Genv.find_funct_ptr tge b = Some tf /\ transf_fundef f = OK tf. +Proof (Genv.find_funct_ptr_transf_partial TRANSF). Lemma sig_preserved: forall f tf, transf_fundef f = OK tf -> Mach.funsig tf = Linear.funsig f. @@ -2749,8 +2726,7 @@ Proof. econstructor; split. apply plus_one. econstructor; eauto. eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. - eapply external_call_symbols_preserved. eauto. - exact symbols_preserved. exact public_preserved. exact varinfo_preserved. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. econstructor; eauto with coqlib. eapply match_stack_change_extcall; eauto. apply Plt_Ple. change (Mem.valid_block m sp0). eapply agree_valid_linear; eauto. @@ -2858,8 +2834,7 @@ Proof. intros [j' [res' [m1' [A [B [C [D [E [F G]]]]]]]]]. econstructor; split. apply plus_one. eapply exec_function_external; eauto. - eapply external_call_symbols_preserved'; eauto. - exact symbols_preserved. exact public_preserved. exact varinfo_preserved. + eapply external_call_symbols_preserved'; eauto. apply senv_preserved. econstructor; eauto. apply match_stacks_change_bounds with (Mem.nextblock m) (Mem.nextblock m'0). inv H0; inv A. eapply match_stack_change_extcall; eauto. apply Ple_refl. apply Ple_refl. @@ -2884,8 +2859,8 @@ 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). + eapply (Genv.init_mem_transf_partial TRANSF); eauto. + rewrite (match_program_main TRANSF). rewrite symbols_preserved. eauto. econstructor; eauto. eapply Genv.initmem_inject; eauto. @@ -2913,9 +2888,10 @@ Qed. Lemma wt_prog: forall i fd, In (i, Gfun fd) prog.(prog_defs) -> wt_fundef fd. Proof. - intros. exploit transform_partial_program_succeeds; eauto. - intros [tfd TF]. destruct fd; simpl in *. -- monadInv TF. unfold transf_function in EQ. + intros. + exploit list_forall2_in_left. eexact (proj1 TRANSF). eauto. + intros ([i' g] & P & Q & R). simpl in *. inv R. destruct fd; simpl in *. +- monadInv H2. unfold transf_function in EQ. destruct (wt_function f). auto. discriminate. - auto. Qed. @@ -2925,7 +2901,7 @@ Theorem transf_program_correct: Proof. set (ms := fun s s' => wt_state s /\ match_states s s'). eapply forward_simulation_plus with (match_states := ms). -- exact public_preserved. +- apply senv_preserved. - intros. exploit transf_initial_states; eauto. intros [st2 [A B]]. exists st2; split; auto. split; auto. apply wt_initial_state with (prog := prog); auto. exact wt_prog. diff --git a/backend/Tailcall.v b/backend/Tailcall.v index e8ce9e25..939abeea 100644 --- a/backend/Tailcall.v +++ b/backend/Tailcall.v @@ -12,13 +12,7 @@ (** Recognition of tail calls. *) -Require Import Coqlib. -Require Import Maps. -Require Import AST. -Require Import Registers. -Require Import Op. -Require Import RTL. -Require Import Conventions. +Require Import Coqlib Maps AST Registers Op RTL Conventions. (** An [Icall] instruction that stores its result in register [rreg] can be turned into a tail call if: @@ -95,8 +89,7 @@ Definition transf_instr (f: function) (pc: node) (instr: instruction) := end. (** A function is transformed only if its stack block is empty, - as explained above. Moreover, we can turn tail calls off - using a compilation option. *) + as explained above. *) Definition transf_function (f: function) : function := if zeq f.(fn_stacksize) 0 diff --git a/backend/Tailcallproof.v b/backend/Tailcallproof.v index 7e7b7b53..793dc861 100644 --- a/backend/Tailcallproof.v +++ b/backend/Tailcallproof.v @@ -12,20 +12,9 @@ (** Recognition of tail calls: correctness proof *) -Require Import Coqlib. -Require Import Maps. -Require Import AST. -Require Import Integers. -Require Import Values. -Require Import Memory. -Require Import Op. -Require Import Events. -Require Import Globalenvs. -Require Import Smallstep. -Require Import Registers. -Require Import RTL. -Require Import Conventions. -Require Import Tailcall. +Require Import Coqlib Maps Integers AST Linking. +Require Import Values Memory Events Globalenvs Smallstep. +Require Import Op Registers RTL Conventions Tailcall. (** * Syntactic properties of the code transformation *) @@ -212,36 +201,42 @@ Qed. (** * Proof of semantic preservation *) +Definition match_prog (p tp: RTL.program) := + match_program (fun cu f tf => tf = transf_fundef f) eq p tp. + +Lemma transf_program_match: + forall p, match_prog p (transf_program p). +Proof. + intros. apply match_transform_program; auto. +Qed. + Section PRESERVATION. -Variable prog: program. -Let tprog := transf_program prog. +Variable prog tprog: program. +Hypothesis TRANSL: match_prog prog tprog. + Let ge := Genv.globalenv prog. Let tge := Genv.globalenv tprog. Lemma symbols_preserved: forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. -Proof (Genv.find_symbol_transf transf_fundef prog). - -Lemma public_preserved: - forall (s: ident), Genv.public_symbol tge s = Genv.public_symbol ge s. -Proof (Genv.public_symbol_transf transf_fundef prog). - -Lemma varinfo_preserved: - forall b, Genv.find_var_info tge b = Genv.find_var_info ge b. -Proof (Genv.find_var_info_transf transf_fundef prog). +Proof (Genv.find_symbol_transf TRANSL). Lemma functions_translated: forall (v: val) (f: RTL.fundef), Genv.find_funct ge v = Some f -> Genv.find_funct tge v = Some (transf_fundef f). -Proof (@Genv.find_funct_transf _ _ _ transf_fundef prog). +Proof (Genv.find_funct_transf TRANSL). Lemma funct_ptr_translated: forall (b: block) (f: RTL.fundef), Genv.find_funct_ptr ge b = Some f -> Genv.find_funct_ptr tge b = Some (transf_fundef f). -Proof (@Genv.find_funct_ptr_transf _ _ _ transf_fundef prog). +Proof (Genv.find_funct_ptr_transf TRANSL). + +Lemma senv_preserved: + Senv.equiv ge tge. +Proof (Genv.senv_transf TRANSL). Lemma sig_preserved: forall f, funsig (transf_fundef f) = funsig f. @@ -409,15 +404,15 @@ Lemma transf_step_correct: Proof. induction 1; intros; inv MS; EliminatedInstr. -(* nop *) +- (* nop *) TransfInstr. left. econstructor; split. eapply exec_Inop; eauto. constructor; auto. -(* eliminated nop *) +- (* eliminated nop *) assert (s0 = pc') by congruence. subst s0. right. split. simpl. omega. split. auto. econstructor; eauto. -(* op *) +- (* op *) TransfInstr. assert (Val.lessdef_list (rs##args) (rs'##args)). apply regs_lessdef_regs; auto. exploit eval_operation_lessdef; eauto. @@ -426,12 +421,12 @@ Proof. eapply exec_Iop; eauto. rewrite <- EVAL'. apply eval_operation_preserved. exact symbols_preserved. econstructor; eauto. apply set_reg_lessdef; auto. -(* eliminated move *) +- (* eliminated move *) rewrite H1 in H. clear H1. inv H. right. split. simpl. omega. split. auto. econstructor; eauto. simpl in H0. rewrite PMap.gss. congruence. -(* load *) +- (* load *) TransfInstr. assert (Val.lessdef_list (rs##args) (rs'##args)). apply regs_lessdef_regs; auto. exploit eval_addressing_lessdef; eauto. @@ -443,7 +438,7 @@ Proof. apply eval_addressing_preserved. exact symbols_preserved. eauto. econstructor; eauto. apply set_reg_lessdef; auto. -(* store *) +- (* store *) TransfInstr. assert (Val.lessdef_list (rs##args) (rs'##args)). apply regs_lessdef_regs; auto. exploit eval_addressing_lessdef; eauto. @@ -456,10 +451,10 @@ Proof. destruct a; simpl in H1; try discriminate. econstructor; eauto. -(* call *) +- (* call *) exploit find_function_translated; eauto. intro FIND'. TransfInstr. -(* call turned tailcall *) ++ (* call turned tailcall *) 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. @@ -469,13 +464,13 @@ Proof. constructor. eapply match_stackframes_tail; eauto. apply regs_lessdef_regs; auto. eapply Mem.free_right_extends; eauto. rewrite stacksize_preserved. rewrite H7. intros. omegaContradiction. -(* call that remains a call *) ++ (* call that remains a call *) 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 regs_lessdef_regs; auto. auto. -(* tailcall *) +- (* tailcall *) exploit find_function_translated; eauto. intro FIND'. exploit Mem.free_parallel_extends; eauto. intros [m'1 [FREE EXT]]. TransfInstr. @@ -484,7 +479,7 @@ Proof. rewrite stacksize_preserved; auto. constructor. auto. apply regs_lessdef_regs; auto. auto. -(* builtin *) +- (* builtin *) TransfInstr. exploit (@eval_builtin_args_lessdef _ ge (fun r => rs#r) (fun r => rs'#r)); eauto. intros (vargs' & P & Q). @@ -493,25 +488,24 @@ Proof. left. exists (State s' (transf_function f) (Vptr sp0 Int.zero) pc' (regmap_setres res v' rs') m'1); split. eapply exec_Ibuiltin; eauto. eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. - eapply external_call_symbols_preserved; eauto. - exact symbols_preserved. exact public_preserved. exact varinfo_preserved. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. econstructor; eauto. apply set_res_lessdef; auto. -(* cond *) +- (* cond *) TransfInstr. left. exists (State s' (transf_function f) (Vptr sp0 Int.zero) (if b then ifso else ifnot) rs' m'); split. eapply exec_Icond; eauto. apply eval_condition_lessdef with (rs##args) m; auto. apply regs_lessdef_regs; auto. constructor; auto. -(* jumptable *) +- (* jumptable *) TransfInstr. 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 *) +- (* return *) exploit Mem.free_parallel_extends; eauto. intros [m'1 [FREE EXT]]. TransfInstr. left. exists (Returnstate s' (regmap_optget or Vundef rs') m'1); split. @@ -520,21 +514,21 @@ Proof. destruct or; simpl. apply RLD. constructor. auto. -(* eliminated return None *) +- (* eliminated return None *) assert (or = None) by congruence. subst or. right. split. simpl. omega. split. auto. constructor. auto. simpl. constructor. eapply Mem.free_left_extends; eauto. -(* eliminated return Some *) +- (* eliminated return Some *) assert (or = Some r) by congruence. subst or. right. split. simpl. omega. split. auto. constructor. auto. simpl. auto. eapply Mem.free_left_extends; eauto. -(* internal call *) +- (* internal call *) exploit Mem.alloc_extends; eauto. instantiate (1 := 0). omega. instantiate (1 := fn_stacksize f). omega. @@ -549,22 +543,21 @@ Proof. rewrite EQ2. rewrite EQ3. constructor; auto. apply regs_lessdef_init_regs. auto. -(* external call *) +- (* external call *) exploit external_call_mem_extends; eauto. intros [res' [m2' [A [B [C D]]]]]. left. exists (Returnstate s' res' m2'); split. simpl. econstructor; eauto. - eapply external_call_symbols_preserved; eauto. - exact symbols_preserved. exact public_preserved. exact varinfo_preserved. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. constructor; auto. -(* returnstate *) +- (* returnstate *) inv H2. -(* synchronous return in both programs *) ++ (* synchronous return in both programs *) left. econstructor; split. apply exec_return. constructor; auto. apply set_reg_lessdef; auto. -(* return instr in source program, eliminated because of tailcall *) ++ (* return instr in source program, eliminated because of tailcall *) right. split. unfold measure. simpl length. change (S (length s) * (niter + 2))%nat with ((niter + 2) + (length s) * (niter + 2))%nat. @@ -581,10 +574,10 @@ Proof. intros. inv H. exploit funct_ptr_translated; eauto. intro FIND. exists (Callstate nil (transf_fundef f) nil m0); split. - econstructor; eauto. apply Genv.init_mem_transf. auto. + econstructor; eauto. apply (Genv.init_mem_transf TRANSL). auto. replace (prog_main tprog) with (prog_main prog). rewrite symbols_preserved. eauto. - reflexivity. + symmetry; eapply match_program_main; eauto. rewrite <- H3. apply sig_preserved. constructor. constructor. constructor. apply Mem.extends_refl. Qed. @@ -604,7 +597,7 @@ Theorem transf_program_correct: forward_simulation (RTL.semantics prog) (RTL.semantics tprog). Proof. eapply forward_simulation_opt with (measure := measure); eauto. - eexact public_preserved. + apply senv_preserved. eexact transf_initial_states. eexact transf_final_states. exact transf_step_correct. @@ -612,4 +605,3 @@ Qed. End PRESERVATION. - diff --git a/backend/Tunneling.v b/backend/Tunneling.v index fa7ff787..3374d5b4 100644 --- a/backend/Tunneling.v +++ b/backend/Tunneling.v @@ -12,9 +12,7 @@ (** Branch tunneling (optimization of branches to branches). *) -Require Import Coqlib. -Require Import Maps. -Require Import UnionFind. +Require Import Coqlib Maps UnionFind. Require Import AST. Require Import LTL. diff --git a/backend/Tunnelingproof.v b/backend/Tunnelingproof.v index 22f0521e..4f1f8143 100644 --- a/backend/Tunnelingproof.v +++ b/backend/Tunnelingproof.v @@ -12,20 +12,21 @@ (** Correctness proof for the branch tunneling optimization. *) -Require Import Coqlib. -Require Import Maps. -Require Import UnionFind. -Require Import AST. -Require Import Values. -Require Import Memory. -Require Import Events. -Require Import Globalenvs. -Require Import Smallstep. -Require Import Op. -Require Import Locations. -Require Import LTL. +Require Import Coqlib Maps UnionFind. +Require Import AST Linking. +Require Import Values Memory Events Globalenvs Smallstep. +Require Import Op Locations LTL. Require Import Tunneling. +Definition match_prog (p tp: program) := + match_program (fun ctx f tf => tf = tunnel_fundef f) eq p tp. + +Lemma transf_program_match: + forall p, match_prog p (tunnel_program p). +Proof. + intros. eapply match_transform_program; eauto. +Qed. + (** * Properties of the branch map computed using union-find. *) (** A variant of [record_goto] that also incrementally computes a measure [f: node -> nat] @@ -138,8 +139,8 @@ Qed. Section PRESERVATION. -Variable prog: program. -Let tprog := tunnel_program prog. +Variables prog tprog: program. +Hypothesis TRANSL: match_prog prog tprog. Let ge := Genv.globalenv prog. Let tge := Genv.globalenv tprog. @@ -147,27 +148,22 @@ Lemma functions_translated: forall v f, Genv.find_funct ge v = Some f -> Genv.find_funct tge v = Some (tunnel_fundef f). -Proof (@Genv.find_funct_transf _ _ _ tunnel_fundef prog). +Proof (Genv.find_funct_transf TRANSL). Lemma function_ptr_translated: forall v f, Genv.find_funct_ptr ge v = Some f -> Genv.find_funct_ptr tge v = Some (tunnel_fundef f). -Proof (@Genv.find_funct_ptr_transf _ _ _ tunnel_fundef prog). +Proof (Genv.find_funct_ptr_transf TRANSL). Lemma symbols_preserved: forall id, Genv.find_symbol tge id = Genv.find_symbol ge id. -Proof (@Genv.find_symbol_transf _ _ _ tunnel_fundef prog). - -Lemma public_preserved: - forall id, - Genv.public_symbol tge id = Genv.public_symbol ge id. -Proof (@Genv.public_symbol_transf _ _ _ tunnel_fundef prog). +Proof (Genv.find_symbol_transf TRANSL). -Lemma varinfo_preserved: - forall b, Genv.find_var_info tge b = Genv.find_var_info ge b. -Proof (@Genv.find_var_info_transf _ _ _ tunnel_fundef prog). +Lemma senv_preserved: + Senv.equiv ge tge. +Proof (Genv.senv_transf TRANSL). Lemma sig_preserved: forall f, funsig (tunnel_fundef f) = funsig f. @@ -340,8 +336,7 @@ Proof. left; simpl; econstructor; split. eapply exec_Lbuiltin; eauto. eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. - eapply external_call_symbols_preserved. eauto. - exact symbols_preserved. exact public_preserved. exact varinfo_preserved. + eapply external_call_symbols_preserved. apply senv_preserved. eauto. econstructor; eauto. (* Lbranch (preserved) *) @@ -372,8 +367,7 @@ Proof. (* external function *) left; simpl; econstructor; split. eapply exec_function_external; eauto. - eapply external_call_symbols_preserved'; eauto. - exact symbols_preserved. exact public_preserved. exact varinfo_preserved. + eapply external_call_symbols_preserved'; eauto. apply senv_preserved. simpl. econstructor; eauto. (* return *) inv H3. inv H1. @@ -389,8 +383,8 @@ Proof. intros. inversion H. exists (Callstate nil (tunnel_fundef f) (Locmap.init Vundef) m0); split. econstructor; eauto. - apply Genv.init_mem_transf; auto. - change (prog_main tprog) with (prog_main prog). + apply (Genv.init_mem_transf TRANSL); auto. + rewrite (match_program_main TRANSL). rewrite symbols_preserved. eauto. apply function_ptr_translated; auto. rewrite <- H3. apply sig_preserved. @@ -408,7 +402,7 @@ Theorem transf_program_correct: forward_simulation (LTL.semantics prog) (LTL.semantics tprog). Proof. eapply forward_simulation_opt. - eexact public_preserved. + apply senv_preserved. eexact transf_initial_states. eexact transf_final_states. eexact tunnel_step_correct. diff --git a/backend/Unusedglob.v b/backend/Unusedglob.v index 8725c9af..916e111b 100644 --- a/backend/Unusedglob.v +++ b/backend/Unusedglob.v @@ -12,16 +12,9 @@ (** Elimination of unreferenced static definitions *) -Require Import FSets. -Require Import Coqlib. -Require Import Ordered. -Require Import Maps. -Require Import Iteration. -Require Import AST. -Require Import Errors. -Require Import Op. -Require Import Registers. -Require Import RTL. +Require Import FSets Coqlib Maps Ordered Iteration Errors. +Require Import AST Linking. +Require Import Op Registers RTL. Local Open Scope string_scope. @@ -90,6 +83,15 @@ Definition add_ref_definition (pm: prog_map) (id: ident) (w: workset): workset : | Some (Gvar gv) => add_ref_globvar gv w end. +(** The initial workset is composed of all public definitions of the compilation unit, + plus the "main" entry point. *) + +Definition initial_workset (p: program): workset := + add_workset p.(prog_main) + (List.fold_left (fun w id => add_workset id w) + p.(prog_public) + {| w_seen := IS.empty; w_todo := nil |}). + (** Traversal of the dependency graph. *) Definition iter_step (pm: prog_map) (w: workset) : IS.t + workset := @@ -100,20 +102,7 @@ Definition iter_step (pm: prog_map) (w: workset) : IS.t + workset := inr _ (add_ref_definition pm id {| w_seen := w.(w_seen); w_todo := rem |}) end. -Definition initial_workset (p: program): workset := - add_workset p.(prog_main) - (List.fold_left (fun w id => add_workset id w) - p.(prog_public) - {| w_seen := IS.empty; w_todo := nil |}). - -Definition add_def_prog_map (pm: prog_map) (id_df: ident * globdef fundef unit) : prog_map := - PTree.set (fst id_df) (snd id_df) pm. - -Definition program_map (p: program) : prog_map := - List.fold_left add_def_prog_map p.(prog_defs) (PTree.empty _). - -Definition used_globals (p: program) : option IS.t := - let pm := program_map p in +Definition used_globals (p: program) (pm: prog_map) : option IS.t := PrimIter.iterate _ _ (iter_step pm) (initial_workset p). (** * Elimination of unreferenced global definitions *) @@ -130,12 +119,23 @@ Fixpoint filter_globdefs (used: IS.t) (accu defs: list (ident * globdef fundef u else filter_globdefs used accu defs' end. +(** To ensure compatibility with linking, we must ensure that all the + global names referenced are defined in the compilation unit, with + the possible exception of the [prog_main] name. *) + +Definition global_defined (p: program) (pm: prog_map) (id: ident) : bool := + match pm!id with Some _ => true | None => ident_eq id (prog_main p) end. + Definition transform_program (p: program) : res program := - match used_globals p with + let pm := prog_defmap p in + match used_globals p pm with | None => Error (msg "Unusedglob: analysis failed") | Some used => - OK {| prog_defs := filter_globdefs used nil (List.rev p.(prog_defs)); - prog_public := p.(prog_public); - prog_main := p.(prog_main) |} + if IS.for_all (global_defined p pm) used then + OK {| prog_defs := filter_globdefs used nil (List.rev p.(prog_defs)); + prog_public := p.(prog_public); + prog_main := p.(prog_main) |} + else + Error (msg "Unusedglob: reference to undefined global") end. diff --git a/backend/Unusedglobproof.v b/backend/Unusedglobproof.v index 7c1b60a9..bb40a2d3 100644 --- a/backend/Unusedglobproof.v +++ b/backend/Unusedglobproof.v @@ -12,28 +12,67 @@ (** Elimination of unreferenced static definitions *) -Require Import FSets. -Require Import Coqlib. -Require Import Ordered. -Require Import Maps. -Require Import Iteration. -Require Import AST. -Require Import Errors. -Require Import Integers. -Require Import Values. -Require Import Memory. -Require Import Globalenvs. -Require Import Events. -Require Import Smallstep. -Require Import Op. -Require Import Registers. -Require Import RTL. +Require Import FSets Coqlib Maps Ordered Iteration Errors. +Require Import AST Linking. +Require Import Integers Values Memory Globalenvs Events Smallstep. +Require Import Op Registers RTL. Require Import Unusedglob. Module ISF := FSetFacts.Facts(IS). Module ISP := FSetProperties.Properties(IS). -(** * Properties of the analysis *) +(** * Relational specification of the transformation *) + +(** The transformed program is obtained from the original program + by keeping only the global definitions that belong to a given + set [u] of names. *) + +Record match_prog_1 (u: IS.t) (p tp: program) : Prop := { + match_prog_main: + tp.(prog_main) = p.(prog_main); + match_prog_public: + tp.(prog_public) = p.(prog_public); + match_prog_def: + forall id, + (prog_defmap tp)!id = if IS.mem id u then (prog_defmap p)!id else None; + match_prog_unique: + list_norepet (prog_defs_names tp) +}. + +(** This set [u] (as "used") must be closed under references, and + contain the entry point and the public identifiers of the program. *) + +Definition ref_function (f: function) (id: ident) : Prop := + exists pc i, f.(fn_code)!pc = Some i /\ In id (ref_instruction i). + +Definition ref_fundef (fd: fundef) (id: ident) : Prop := + match fd with Internal f => ref_function f id | External ef => False end. + +Definition ref_init (il: list init_data) (id: ident) : Prop := + exists ofs, In (Init_addrof id ofs) il. + +Definition ref_def (gd: globdef fundef unit) (id: ident) : Prop := + match gd with + | Gfun fd => ref_fundef fd id + | Gvar gv => ref_init gv.(gvar_init) id + end. + +Record valid_used_set (p: program) (u: IS.t) : Prop := { + used_closed: forall id gd id', + IS.In id u -> (prog_defmap p)!id = Some gd -> ref_def gd id' -> + IS.In id' u; + used_main: + IS.In p.(prog_main) u; + used_public: forall id, + In id p.(prog_public) -> IS.In id u; + used_defined: forall id, + IS.In id u -> In id (prog_defs_names p) \/ id = p.(prog_main) +}. + +Definition match_prog (p tp: program) : Prop := + exists u: IS.t, valid_used_set p u /\ match_prog_1 u p tp. + +(** * Properties of the static analysis *) (** Monotonic evolution of the workset. *) @@ -123,7 +162,7 @@ Proof. eapply workset_incl_trans. 2: apply add_workset_incl. generalize {| w_seen := IS.empty; w_todo := nil |}. induction (prog_public p); simpl; intros. apply workset_incl_refl. - eapply workset_incl_trans. eapply add_workset_incl. eapply IHl. + eapply workset_incl_trans. apply add_workset_incl. apply IHl. Qed. (** Soundness properties for functions that add identifiers to the workset *) @@ -148,9 +187,6 @@ Proof. apply IHl; auto. Qed. -Definition ref_function (f: function) (id: ident) : Prop := - exists pc i, f.(fn_code)!pc = Some i /\ In id (ref_instruction i). - Lemma seen_add_ref_function: forall id f w, ref_function f id -> IS.In id (add_ref_function f w). @@ -164,15 +200,6 @@ Proof. apply H1. exists pc, i; auto. Qed. -Definition ref_fundef (fd: fundef) (id: ident) : Prop := - match fd with Internal f => ref_function f id | External ef => False end. - -Definition ref_def (gd: globdef fundef unit) (id: ident) : Prop := - match gd with - | Gfun fd => ref_fundef fd id - | Gvar gv => exists ofs, List.In (Init_addrof id ofs) gv.(gvar_init) - end. - Lemma seen_add_ref_definition: forall pm id gd id' w, pm!id = Some gd -> ref_def gd id' -> IS.In id' (add_ref_definition pm id w). @@ -198,7 +225,7 @@ Qed. Lemma seen_main_initial_workset: forall p, IS.In p.(prog_main) (initial_workset p). Proof. - unfold initial_workset; intros. apply seen_add_workset. + intros. apply seen_add_workset. Qed. Lemma seen_public_initial_workset: @@ -217,19 +244,14 @@ Proof. apply H0. auto. Qed. -(** * Semantic preservation *) +(** * Correctness of the transformation with respect to the relational specification *) -Section SOUNDNESS. -Variable p: program. -Variable tp: program. -Hypothesis TRANSF: transform_program p = OK tp. -Let ge := Genv.globalenv p. -Let tge := Genv.globalenv tp. - -Let pm := program_map p. +(** Correctness of the dependency graph traversal. *) +Section ANALYSIS. -(** Correctness of the dependency graph traversal. *) +Variable p: program. +Let pm := prog_defmap p. Definition workset_invariant (w: workset) : Prop := forall id gd id', @@ -264,7 +286,7 @@ Proof. Qed. Theorem used_globals_sound: - forall u, used_globals p = Some u -> used_set_closed u. + forall u, used_globals p pm = Some u -> used_set_closed u. Proof. unfold used_globals; intros. eapply PrimIter.iterate_prop with (P := workset_invariant); eauto. - intros. apply iter_step_invariant; auto. @@ -275,7 +297,7 @@ Proof. Qed. Theorem used_globals_incl: - forall u, used_globals p = Some u -> IS.Subset (initial_workset p) u. + forall u, used_globals p pm = Some u -> IS.Subset (initial_workset p) u. Proof. unfold used_globals; intros. eapply PrimIter.iterate_prop with (P := fun (w: workset) => IS.Subset (initial_workset p) w); eauto. @@ -286,35 +308,34 @@ Proof. - red; auto. Qed. -Definition used: IS.t := - match used_globals p with Some u => u | None => IS.empty end. - -Remark USED_GLOBALS: used_globals p = Some used. +Corollary used_globals_valid: + forall u, + used_globals p pm = Some u -> + IS.for_all (global_defined p pm) u = true -> + valid_used_set p u. Proof. - unfold used. unfold transform_program in TRANSF. destruct (used_globals p). auto. discriminate. + intros. constructor. +- intros. eapply used_globals_sound; eauto. +- eapply used_globals_incl; eauto. apply seen_main_initial_workset. +- intros. eapply used_globals_incl; eauto. apply seen_public_initial_workset; auto. +- intros. apply ISF.for_all_iff in H0. ++ red in H0. apply H0 in H1. unfold global_defined in H1. + destruct pm!id as [g|] eqn:E. +* left. change id with (fst (id,g)). apply in_map. apply in_prog_defmap; auto. +* InvBooleans; auto. ++ hnf. simpl; intros; congruence. Qed. -Definition kept (id: ident) : Prop := IS.In id used. +End ANALYSIS. -Theorem kept_closed: - forall id gd id', - kept id -> pm!id = Some gd -> ref_def gd id' -> kept id'. -Proof. - intros. assert (UC: used_set_closed used) by (apply used_globals_sound; apply USED_GLOBALS). - eapply UC; eauto. -Qed. +(** Properties of the elimination of unused global definitions. *) -Theorem kept_main: - kept p.(prog_main). -Proof. - unfold kept. eapply used_globals_incl; eauto. apply USED_GLOBALS. apply seen_main_initial_workset. -Qed. +Section TRANSFORMATION. -Theorem kept_public: - forall id, In id p.(prog_public) -> kept id. -Proof. - intros. unfold kept. eapply used_globals_incl; eauto. apply USED_GLOBALS. apply seen_public_initial_workset; auto. -Qed. +Variable p: program. +Variable used: IS.t. + +Let add_def (m: prog_map) idg := PTree.set (fst idg) (snd idg) m. Remark filter_globdefs_accu: forall defs accu1 accu2 u, @@ -333,98 +354,154 @@ Proof. intros. rewrite <- filter_globdefs_accu. auto. Qed. -Theorem transform_program_charact: - forall id, (program_map tp)!id = if IS.mem id used then pm!id else None. +Lemma filter_globdefs_map_1: + forall id l u m1, + IS.mem id u = false -> + m1!id = None -> + (fold_left add_def (filter_globdefs u nil l) m1)!id = None. Proof. - intros. - assert (X: forall l u m1 m2, - IS.In id u -> - m1!id = m2!id -> - (fold_left add_def_prog_map (filter_globdefs u nil l) m1)!id = - (fold_left add_def_prog_map (List.rev l) m2)!id). - { - induction l; simpl; intros. - auto. - destruct a as [id1 gd1]. rewrite fold_left_app. simpl. - destruct (IS.mem id1 u) eqn:MEM. - rewrite filter_globdefs_nil. rewrite fold_left_app. simpl. - unfold add_def_prog_map at 1 3. simpl. - rewrite ! PTree.gsspec. destruct (peq id id1). auto. - apply IHl; auto. apply IS.remove_2; auto. - unfold add_def_prog_map at 2. simpl. rewrite PTree.gso. apply IHl; auto. - red; intros; subst id1. - assert (IS.mem id u = true) by (apply IS.mem_1; auto). congruence. - } - assert (Y: forall l u m1, - IS.mem id u = false -> - m1!id = None -> - (fold_left add_def_prog_map (filter_globdefs u nil l) m1)!id = None). - { - induction l; simpl; intros. - auto. - destruct a as [id1 gd1]. - destruct (IS.mem id1 u) eqn:MEM. - rewrite filter_globdefs_nil. rewrite fold_left_app. simpl. - unfold add_def_prog_map at 1. simpl. rewrite PTree.gso by congruence. eapply IHl; eauto. - rewrite ISF.remove_b. rewrite H; auto. - eapply IHl; eauto. - } - unfold pm, program_map. - unfold transform_program in TRANSF; rewrite USED_GLOBALS in TRANSF. inversion TRANSF. - simpl. destruct (IS.mem id used) eqn: MEM. - erewrite X. rewrite List.rev_involutive. eauto. apply IS.mem_2; auto. auto. - apply Y. auto. apply PTree.gempty. -Qed. - -(** Program map and Genv operations *) - -Definition genv_progmap_match (ge: genv) (pm: prog_map) : Prop := - forall id, - match Genv.find_symbol ge id with - | None => pm!id = None - | Some b => - match pm!id with - | None => False - | Some (Gfun fd) => Genv.find_funct_ptr ge b = Some fd - | Some (Gvar gv) => Genv.find_var_info ge b = Some gv - end - end. + induction l as [ | [id1 gd1] l]; simpl; intros. +- auto. +- destruct (IS.mem id1 u) eqn:MEM. ++ rewrite filter_globdefs_nil. rewrite fold_left_app. simpl. + unfold add_def at 1. simpl. rewrite PTree.gso by congruence. eapply IHl; eauto. + rewrite ISF.remove_b. rewrite H; auto. ++ eapply IHl; eauto. +Qed. -Lemma genv_program_map: - forall p, genv_progmap_match (Genv.globalenv p) (program_map p). +Lemma filter_globdefs_map_2: + forall id l u m1 m2, + IS.mem id u = true -> + m1!id = m2!id -> + (fold_left add_def (filter_globdefs u nil l) m1)!id = (fold_left add_def (List.rev l) m2)!id. Proof. - intros. unfold Genv.globalenv, program_map. - assert (REC: forall defs g m, - genv_progmap_match g m -> - genv_progmap_match (Genv.add_globals g defs) (fold_left add_def_prog_map defs m)). - { - induction defs; simpl; intros. - auto. - apply IHdefs. red; intros. specialize (H id). - destruct a as [id1 [fd|gv]]; - unfold Genv.add_global, Genv.find_symbol, Genv.find_funct_ptr, Genv.find_var_info, add_def_prog_map in *; - simpl. - - rewrite PTree.gsspec. destruct (peq id id1); subst. - + rewrite ! PTree.gss. auto. - + destruct (Genv.genv_symb g)!id as [b|] eqn:S; rewrite PTree.gso by auto. - * rewrite PTree.gso. auto. apply Plt_ne. eapply Genv.genv_symb_range; eauto. - * auto. - - rewrite PTree.gsspec. destruct (peq id id1); subst. - + rewrite ! PTree.gss. auto. - + destruct (Genv.genv_symb g)!id as [b|] eqn:S; rewrite PTree.gso by auto. - * rewrite PTree.gso. auto. apply Plt_ne. eapply Genv.genv_symb_range; eauto. - * auto. - } - apply REC. red; intros. unfold Genv.find_symbol, Genv.empty_genv; simpl. rewrite ! PTree.gempty; auto. + induction l as [ | [id1 gd1] l]; simpl; intros. +- auto. +- rewrite fold_left_app. simpl. + destruct (IS.mem id1 u) eqn:MEM. ++ rewrite filter_globdefs_nil. rewrite fold_left_app. simpl. + unfold add_def at 1 3. simpl. + rewrite ! PTree.gsspec. destruct (peq id id1). auto. + apply IHl; auto. + apply IS.mem_1. apply IS.remove_2; auto. apply IS.mem_2; auto. ++ unfold add_def at 2. simpl. rewrite PTree.gso by congruence. apply IHl; auto. Qed. -Lemma transform_program_kept: - forall id b, Genv.find_symbol tge id = Some b -> kept id. +Lemma filter_globdefs_map: + forall id u defs, + (PTree_Properties.of_list (filter_globdefs u nil (List.rev defs)))! id = + if IS.mem id u then (PTree_Properties.of_list defs)!id else None. Proof. - intros. generalize (genv_program_map tp id). fold tge; rewrite H. - rewrite transform_program_charact. intros. destruct (IS.mem id used) eqn:U. - unfold kept; apply IS.mem_2; auto. - contradiction. + intros. unfold PTree_Properties.of_list. fold prog_map. unfold PTree.elt. fold add_def. + destruct (IS.mem id u) eqn:MEM. +- erewrite filter_globdefs_map_2. rewrite List.rev_involutive. reflexivity. + auto. auto. +- apply filter_globdefs_map_1. auto. apply PTree.gempty. +Qed. + +Lemma filter_globdefs_domain: + forall id l u, + In id (map fst (filter_globdefs u nil l)) -> IS.In id u /\ In id (map fst l). +Proof. + induction l as [ | [id1 gd1] l]; simpl; intros. +- tauto. +- destruct (IS.mem id1 u) eqn:MEM. ++ rewrite filter_globdefs_nil, map_app, in_app_iff in H. destruct H. + apply IHl in H. rewrite ISF.remove_iff in H. tauto. + simpl in H. destruct H; try tauto. subst id1. split; auto. apply IS.mem_2; auto. ++ apply IHl in H. tauto. +Qed. + +Lemma filter_globdefs_unique_names: + forall l u, list_norepet (map fst (filter_globdefs u nil l)). +Proof. + induction l as [ | [id1 gd1] l]; simpl; intros. +- constructor. +- destruct (IS.mem id1 u) eqn:MEM; auto. + rewrite filter_globdefs_nil, map_app. simpl. + apply list_norepet_append; auto. + constructor. simpl; tauto. constructor. + red; simpl; intros. destruct H0; try tauto. subst y. + apply filter_globdefs_domain in H. rewrite ISF.remove_iff in H. intuition. +Qed. + +End TRANSFORMATION. + +Theorem transf_program_match: + forall p tp, transform_program p = OK tp -> match_prog p tp. +Proof. + unfold transform_program; intros p tp TR. set (pm := prog_defmap p) in *. + destruct (used_globals p pm) as [u|] eqn:U; try discriminate. + destruct (IS.for_all (global_defined p pm) u) eqn:DEF; inv TR. + exists u; split. + apply used_globals_valid; auto. + constructor; simpl; auto. + intros. unfold prog_defmap; simpl. apply filter_globdefs_map. + apply filter_globdefs_unique_names. +Qed. + +(** * Semantic preservation *) + +Section SOUNDNESS. + +Variable p: program. +Variable tp: program. +Variable used: IS.t. +Hypothesis USED_VALID: valid_used_set p used. +Hypothesis TRANSF: match_prog_1 used p tp. +Let ge := Genv.globalenv p. +Let tge := Genv.globalenv tp. +Let pm := prog_defmap p. + +Definition kept (id: ident) : Prop := IS.In id used. + +Lemma kept_closed: + forall id gd id', + kept id -> pm!id = Some gd -> ref_def gd id' -> kept id'. +Proof. + intros. eapply used_closed; eauto. +Qed. + +Lemma kept_main: + kept p.(prog_main). +Proof. + eapply used_main; eauto. +Qed. + +Lemma kept_public: + forall id, In id p.(prog_public) -> kept id. +Proof. + intros. eapply used_public; eauto. +Qed. + +(** Relating [Genv.find_symbol] operations in the original and transformed program *) + +Lemma transform_find_symbol_1: + forall id b, + Genv.find_symbol ge id = Some b -> kept id -> exists b', Genv.find_symbol tge id = Some b'. +Proof. + intros. + assert (A: exists g, (prog_defmap p)!id = Some g). + { apply prog_defmap_dom. eapply Genv.find_symbol_inversion; eauto. } + destruct A as (g & P). + apply Genv.find_symbol_exists with g. + apply in_prog_defmap. + erewrite match_prog_def by eauto. rewrite IS.mem_1 by auto. auto. +Qed. + +Lemma transform_find_symbol_2: + forall id b, + Genv.find_symbol tge id = Some b -> kept id /\ exists b', Genv.find_symbol ge id = Some b'. +Proof. + intros. + assert (A: exists g, (prog_defmap tp)!id = Some g). + { apply prog_defmap_dom. eapply Genv.find_symbol_inversion; eauto. } + destruct A as (g & P). + erewrite match_prog_def in P by eauto. + destruct (IS.mem id used) eqn:U; try discriminate. + split. apply IS.mem_2; auto. + apply Genv.find_symbol_exists with g. + apply in_prog_defmap. auto. Qed. (** Injections that preserve used globals. *) @@ -439,16 +516,13 @@ Record meminj_preserves_globals (f: meminj) : Prop := { symbols_inject_3: forall id b', Genv.find_symbol tge id = Some b' -> exists b, Genv.find_symbol ge id = Some b /\ f b = Some(b', 0); - funct_ptr_inject: forall b b' delta fd, - f b = Some(b', delta) -> Genv.find_funct_ptr ge b = Some fd -> - Genv.find_funct_ptr tge b' = Some fd /\ delta = 0 /\ - (forall id, ref_fundef fd id -> kept id); - var_info_inject: forall b b' delta gv, - f b = Some(b', delta) -> Genv.find_var_info ge b = Some gv -> - Genv.find_var_info tge b' = Some gv /\ delta = 0; - var_info_rev_inject: forall b b' delta gv, - f b = Some(b', delta) -> Genv.find_var_info tge b' = Some gv -> - Genv.find_var_info ge b = Some gv /\ delta = 0 + defs_inject: forall b b' delta gd, + f b = Some(b', delta) -> Genv.find_def ge b = Some gd -> + Genv.find_def tge b' = Some gd /\ delta = 0 /\ + (forall id, ref_def gd id -> kept id); + defs_rev_inject: forall b b' delta gd, + f b = Some(b', delta) -> Genv.find_def tge b' = Some gd -> + Genv.find_def ge b = Some gd /\ delta = 0 }. Definition init_meminj : meminj := @@ -462,6 +536,14 @@ Definition init_meminj : meminj := | None => None end. +Remark init_meminj_eq: + forall id b b', + Genv.find_symbol ge id = Some b -> Genv.find_symbol tge id = Some b' -> + init_meminj b = Some(b', 0). +Proof. + intros. unfold init_meminj. erewrite Genv.find_invert_symbol by eauto. rewrite H0. auto. +Qed. + Remark init_meminj_invert: forall b b' delta, init_meminj b = Some(b', delta) -> @@ -480,44 +562,26 @@ Proof. - exploit init_meminj_invert; eauto. intros (A & id1 & B & C). assert (id1 = id) by (eapply (Genv.genv_vars_inj ge); eauto). subst id1. auto. -- unfold init_meminj. erewrite Genv.find_invert_symbol by eauto. apply IS.mem_1 in H. - generalize (genv_program_map p id) (genv_program_map tp id). fold ge; fold tge; fold pm. - rewrite transform_program_charact. rewrite H, H0. - destruct (Genv.find_symbol tge id) as [b'|]; intros. - exists b'; auto. rewrite H2 in H1; contradiction. -- generalize (genv_program_map tp id). fold tge. rewrite H. intros. - destruct (program_map tp)!id as [gd|] eqn:PM; try contradiction. - generalize (transform_program_charact id). rewrite PM. - destruct (IS.mem id used) eqn:USED; intros; try discriminate. - generalize (genv_program_map p id). fold ge; fold pm. - destruct (Genv.find_symbol ge id) as [b|] eqn:FS; intros; try congruence. - exists b; split; auto. unfold init_meminj. - erewrite Genv.find_invert_symbol by eauto. rewrite H. auto. +- exploit transform_find_symbol_1; eauto. intros (b' & F). exists b'; split; auto. + eapply init_meminj_eq; eauto. +- exploit transform_find_symbol_2; eauto. intros (K & b & F). + exists b; split; auto. eapply init_meminj_eq; eauto. +- exploit init_meminj_invert; eauto. intros (A & id & B & C). + assert (kept id) by (eapply transform_find_symbol_2; eauto). + assert (pm!id = Some gd). + { unfold pm; rewrite Genv.find_def_symbol. exists b; auto. } + assert ((prog_defmap tp)!id = Some gd). + { erewrite match_prog_def by eauto. rewrite IS.mem_1 by auto. auto. } + rewrite Genv.find_def_symbol in H3. destruct H3 as (b1 & P & Q). + fold tge in P. replace b' with b1 by congruence. split; auto. split; auto. + intros. eapply kept_closed; eauto. - exploit init_meminj_invert; eauto. intros (A & id & B & C). - generalize (genv_program_map p id) (genv_program_map tp id). fold ge; fold tge; fold pm. - rewrite transform_program_charact. rewrite B, C. intros. - destruct (IS.mem id used) eqn:KEPT; try contradiction. - destruct (pm!id) as [gd|] eqn:PM; try contradiction. - destruct gd as [fd'|gv']. - + assert (fd' = fd) by congruence. subst fd'. split. auto. split. auto. - intros. eapply kept_closed; eauto. red; apply IS.mem_2; auto. - + assert (b <> b) by (eapply Genv.genv_funs_vars; eassumption). congruence. -- exploit init_meminj_invert; eauto. intros (A & id & B & C). split; auto. - generalize (genv_program_map p id) (genv_program_map tp id). fold ge; fold tge; fold pm. - rewrite transform_program_charact. rewrite B, C. intros. - destruct (IS.mem id used); try contradiction. - destruct (pm!id) as [gd|]; try contradiction. - destruct gd as [fd'|gv']. - + assert (b <> b) by (eapply Genv.genv_funs_vars; eassumption). congruence. - + congruence. -- exploit init_meminj_invert; eauto. intros (A & id & B & C). split; auto. - generalize (genv_program_map p id) (genv_program_map tp id). fold ge; fold tge; fold pm. - rewrite transform_program_charact. rewrite B, C. intros. - destruct (IS.mem id used); try contradiction. - destruct (pm!id) as [gd|]; try contradiction. - destruct gd as [fd'|gv']. - + assert (b' <> b') by (eapply Genv.genv_funs_vars; eassumption). congruence. - + congruence. + assert ((prog_defmap tp)!id = Some gd). + { rewrite Genv.find_def_symbol. exists b'; auto. } + erewrite match_prog_def in H1 by eauto. + destruct (IS.mem id used); try discriminate. + rewrite Genv.find_def_symbol in H1. destruct H1 as (b1 & P & Q). + fold ge in P. replace b with b1 by congruence. auto. Qed. Lemma globals_symbols_inject: @@ -527,28 +591,33 @@ Proof. assert (E1: Genv.genv_public ge = p.(prog_public)). { apply Genv.globalenv_public. } assert (E2: Genv.genv_public tge = p.(prog_public)). - { unfold tge; rewrite Genv.globalenv_public. - unfold transform_program in TRANSF. rewrite USED_GLOBALS in TRANSF. inversion TRANSF. auto. } + { unfold tge; rewrite Genv.globalenv_public. eapply match_prog_public; eauto. } split; [|split;[|split]]; intros. + simpl; unfold Genv.public_symbol; rewrite E1, E2. destruct (Genv.find_symbol tge id) as [b'|] eqn:TFS. exploit symbols_inject_3; eauto. intros (b & FS & INJ). rewrite FS. auto. destruct (Genv.find_symbol ge id) as [b|] eqn:FS; auto. destruct (in_dec ident_eq id (prog_public p)); simpl; auto. - exploit symbols_inject_2; eauto. apply kept_public; auto. + exploit symbols_inject_2; eauto. + eapply kept_public; eauto. intros (b' & TFS' & INJ). congruence. + eapply symbols_inject_1; eauto. + simpl in *; unfold Genv.public_symbol in H0. destruct (Genv.find_symbol ge id) as [b|] eqn:FS; try discriminate. rewrite E1 in H0. destruct (in_dec ident_eq id (prog_public p)); try discriminate. inv H1. - exploit symbols_inject_2; eauto. apply kept_public; auto. + exploit symbols_inject_2; eauto. + eapply kept_public; eauto. intros (b' & A & B); exists b'; auto. + simpl. unfold Genv.block_is_volatile. destruct (Genv.find_var_info ge b1) as [gv|] eqn:V1. - exploit var_info_inject; eauto. intros [A B]. rewrite A. auto. + rewrite Genv.find_var_info_iff in V1. + exploit defs_inject; eauto. intros (A & B & C). + rewrite <- Genv.find_var_info_iff in A. rewrite A; auto. destruct (Genv.find_var_info tge b2) as [gv|] eqn:V2; auto. - exploit var_info_rev_inject; eauto. intros [A B]. congruence. + rewrite Genv.find_var_info_iff in V2. + exploit defs_rev_inject; eauto. intros (A & B). + rewrite <- Genv.find_var_info_iff in A. congruence. Qed. Lemma symbol_address_inject: @@ -661,12 +730,10 @@ Proof. exists b'; auto. + exploit symbols_inject_3; eauto. intros (b & A & B). exists b; auto. - + eapply funct_ptr_inject; eauto. apply SAME; auto. - eapply Genv.genv_funs_range; eauto. - + eapply var_info_inject; eauto. apply SAME; auto. - eapply Genv.genv_vars_range; eauto. - + eapply var_info_rev_inject; eauto. apply SAME'; auto. - eapply Genv.genv_vars_range; eauto. + + eapply defs_inject; eauto. apply SAME; auto. + eapply Genv.genv_defs_range; eauto. + + eapply defs_rev_inject; eauto. apply SAME'; auto. + eapply Genv.genv_defs_range; eauto. - econstructor; eauto. apply IHmatch_stacks. intros. exploit H1; eauto. intros [A B]. split; eapply Ple_trans; eauto. @@ -738,11 +805,15 @@ Proof. - exploit Genv.find_funct_inv; eauto. intros (b & R). rewrite R in H0. rewrite Genv.find_funct_find_funct_ptr in H0. specialize (H1 r). rewrite R in H1. inv H1. - exploit funct_ptr_inject; eauto. intros (A & B & C). + rewrite Genv.find_funct_ptr_iff in H0. + exploit defs_inject; eauto. intros (A & B & C). + rewrite <- Genv.find_funct_ptr_iff in A. rewrite B; auto. - destruct (Genv.find_symbol ge id) as [b|] eqn:FS; try discriminate. exploit symbols_inject_2; eauto. intros (tb & P & Q). rewrite P. - exploit funct_ptr_inject; eauto. intros (A & B & C). + rewrite Genv.find_funct_ptr_iff in H0. + exploit defs_inject; eauto. intros (A & B & C). + rewrite <- Genv.find_funct_ptr_iff in A. auto. Qed. @@ -973,285 +1044,159 @@ Qed. (** Relating initial memory states *) -Remark init_meminj_no_overlap: - forall m, Mem.meminj_no_overlap init_meminj m. +(* +Remark genv_find_def_exists: + forall (F V: Type) (p: AST.program F V) b, + Plt b (Genv.genv_next (Genv.globalenv p)) -> + exists gd, Genv.find_def (Genv.globalenv p) b = Some gd. Proof. - intros; red; intros. - exploit init_meminj_invert. eexact H0. intros (A1 & id1 & B1 & C1). - exploit init_meminj_invert. eexact H1. intros (A2 & id2 & B2 & C2). - left; red; intros; subst b2'. - assert (id1 = id2) by (eapply Genv.genv_vars_inj; eauto). - congruence. + intros until b. + set (P := fun (g: Genv.t F V) => + Plt b (Genv.genv_next g) -> exists gd, (Genv.genv_defs g)!b = Some gd). + assert (forall l g, P g -> P (Genv.add_globals g l)). + { induction l as [ | [id1 g1] l]; simpl; intros. + - auto. + - apply IHl. unfold Genv.add_global, P; simpl. intros LT. apply Plt_succ_inv in LT. destruct LT. + + rewrite PTree.gso. apply H; auto. apply Plt_ne; auto. + + rewrite H0. rewrite PTree.gss. exists g1; auto. } + apply H. red; simpl; intros. exfalso; xomega. Qed. +*) -Lemma store_zeros_unmapped_inj: - forall m1 b1 i n m1', - store_zeros m1 b1 i n = Some m1' -> - forall m2, - Mem.mem_inj init_meminj m1 m2 -> - init_meminj b1 = None -> - Mem.mem_inj init_meminj m1' m2. -Proof. - intros until m1'. functional induction (store_zeros m1 b1 i n); intros. - inv H. auto. - eapply IHo; eauto. eapply Mem.store_unmapped_inj; eauto. - discriminate. -Qed. - -Lemma store_zeros_mapped_inj: - forall m1 b1 i n m1', - store_zeros m1 b1 i n = Some m1' -> - forall m2 b2, - Mem.mem_inj init_meminj m1 m2 -> - init_meminj b1 = Some(b2, 0) -> - exists m2', store_zeros m2 b2 i n = Some m2' /\ Mem.mem_inj init_meminj m1' m2'. -Proof. - intros until m1'. functional induction (store_zeros m1 b1 i n); intros. - inv H. exists m2; split; auto. rewrite store_zeros_equation, e; auto. - exploit Mem.store_mapped_inj; eauto. apply init_meminj_no_overlap. instantiate (1 := Vzero); constructor. - intros (m2' & A & B). rewrite Zplus_0_r in A. - exploit IHo; eauto. intros (m3' & C & D). - exists m3'; split; auto. rewrite store_zeros_equation, e, A, C; auto. - discriminate. -Qed. - -Lemma store_init_data_unmapped_inj: - forall m1 b1 i id m1' m2, - Genv.store_init_data ge m1 b1 i id = Some m1' -> - Mem.mem_inj init_meminj m1 m2 -> - init_meminj b1 = None -> - Mem.mem_inj init_meminj m1' m2. -Proof. - intros. destruct id; simpl in H; try (eapply Mem.store_unmapped_inj; now eauto). - inv H; auto. - destruct (Genv.find_symbol ge i0); try discriminate. eapply Mem.store_unmapped_inj; now eauto. -Qed. - -Lemma store_init_data_mapped_inj: - forall m1 b1 i init m1' b2 m2, - Genv.store_init_data ge m1 b1 i init = Some m1' -> - Mem.mem_inj init_meminj m1 m2 -> - init_meminj b1 = Some(b2, 0) -> - (forall id ofs, init = Init_addrof id ofs -> kept id) -> - exists m2', Genv.store_init_data tge m2 b2 i init = Some m2' /\ Mem.mem_inj init_meminj m1' m2'. -Proof. - intros. replace i with (i + 0) by omega. pose proof (init_meminj_no_overlap m1). - destruct init; simpl in *; try (eapply Mem.store_mapped_inj; now eauto). - inv H. exists m2; auto. - destruct (Genv.find_symbol ge i0) as [bi|] eqn:FS1; try discriminate. - exploit symbols_inject_2. eapply init_meminj_preserves_globals. eapply H2; eauto. eauto. - intros (bi' & A & B). rewrite A. eapply Mem.store_mapped_inj; eauto. - econstructor; eauto. rewrite Int.add_zero; auto. +Lemma init_meminj_invert_strong: + forall b b' delta, + init_meminj b = Some(b', delta) -> + delta = 0 /\ + exists id gd, + Genv.find_symbol ge id = Some b + /\ Genv.find_symbol tge id = Some b' + /\ Genv.find_def ge b = Some gd + /\ Genv.find_def tge b' = Some gd + /\ (forall i, ref_def gd i -> kept i). +Proof. + intros. exploit init_meminj_invert; eauto. intros (A & id & B & C). + assert (exists gd, (prog_defmap p)!id = Some gd). + { apply prog_defmap_dom. eapply Genv.find_symbol_inversion; eauto. } + destruct H0 as [gd DM]. rewrite Genv.find_def_symbol in DM. + destruct DM as (b'' & P & Q). fold ge in P. rewrite P in B; inv B. + fold ge in Q. exploit defs_inject. apply init_meminj_preserves_globals. + eauto. eauto. intros (X & _ & Y). + split. auto. exists id, gd; auto. Qed. - Lemma store_init_data_list_unmapped_inj: - forall initlist m1 b1 i m1' m2, - Genv.store_init_data_list ge m1 b1 i initlist = Some m1' -> - Mem.mem_inj init_meminj m1 m2 -> - init_meminj b1 = None -> - Mem.mem_inj init_meminj m1' m2. -Proof. - induction initlist; simpl; intros. -- inv H; auto. -- destruct (Genv.store_init_data ge m1 b1 i a) as [m1''|] eqn:ST; try discriminate. - eapply IHinitlist; eauto. eapply store_init_data_unmapped_inj; eauto. -Qed. - -Lemma store_init_data_list_mapped_inj: - forall initlist m1 b1 i m1' b2 m2, - Genv.store_init_data_list ge m1 b1 i initlist = Some m1' -> - Mem.mem_inj init_meminj m1 m2 -> - init_meminj b1 = Some(b2, 0) -> - (forall id ofs, In (Init_addrof id ofs) initlist -> kept id) -> - exists m2', Genv.store_init_data_list tge m2 b2 i initlist = Some m2' /\ Mem.mem_inj init_meminj m1' m2'. -Proof. - induction initlist; simpl; intros. -- inv H. exists m2; auto. -- destruct (Genv.store_init_data ge m1 b1 i a) as [m1''|] eqn:ST; try discriminate. - exploit store_init_data_mapped_inj; eauto. intros (m2'' & A & B). - exploit IHinitlist; eauto. intros (m2' & C & D). - exists m2'; split; auto. rewrite A; auto. -Qed. - -Lemma alloc_global_unmapped_inj: - forall m1 id g m1' m2, - Genv.alloc_global ge m1 (id, g) = Some m1' -> - Mem.mem_inj init_meminj m1 m2 -> - init_meminj (Mem.nextblock m1) = None -> - Mem.mem_inj init_meminj m1' m2. -Proof. - unfold Genv.alloc_global; intros. destruct g as [fd|gv]. -- destruct (Mem.alloc m1 0 1) as (m1a, b) eqn:ALLOC. - exploit Mem.alloc_result; eauto. intros EQ. rewrite <- EQ in H1. - eapply Mem.drop_unmapped_inj with (m1 := m1a); eauto. - eapply Mem.alloc_left_unmapped_inj; eauto. -- set (sz := Genv.init_data_list_size (gvar_init gv)) in *. - destruct (Mem.alloc m1 0 sz) as (m1a, b) eqn:ALLOC. - destruct (store_zeros m1a b 0 sz) as [m1b|] eqn: STZ; try discriminate. - destruct (Genv.store_init_data_list ge m1b b 0 (gvar_init gv)) as [m1c|] eqn:ST; try discriminate. - exploit Mem.alloc_result; eauto. intros EQ. rewrite <- EQ in H1. - eapply Mem.drop_unmapped_inj with (m1 := m1c); eauto. - eapply store_init_data_list_unmapped_inj with (m1 := m1b); eauto. - eapply store_zeros_unmapped_inj with (m1 := m1a); eauto. - eapply Mem.alloc_left_unmapped_inj; eauto. -Qed. - -Lemma alloc_global_mapped_inj: - forall m1 id g m1' m2, - Genv.alloc_global ge m1 (id, g) = Some m1' -> - Mem.mem_inj init_meminj m1 m2 -> - init_meminj (Mem.nextblock m1) = Some(Mem.nextblock m2, 0) -> - (forall id, ref_def g id -> kept id) -> - exists m2', - Genv.alloc_global tge m2 (id, g) = Some m2' /\ Mem.mem_inj init_meminj m1' m2'. -Proof. - unfold Genv.alloc_global; intros. destruct g as [fd|gv]. -- destruct (Mem.alloc m1 0 1) as (m1a, b1) eqn:ALLOC. - exploit Mem.alloc_result; eauto. intros EQ. rewrite <- EQ in H1. - destruct (Mem.alloc m2 0 1) as (m2a, b2) eqn:ALLOC2. - exploit Mem.alloc_result; eauto. intros EQ2. rewrite <- EQ2 in H1. - assert (Mem.mem_inj init_meminj m1a m2a). - { eapply Mem.alloc_left_mapped_inj with (b1 := b1) (b2 := b2) (delta := 0). - eapply Mem.alloc_right_inj; eauto. - eauto. - eauto with mem. - red; intros; apply Z.divide_0_r. - intros. apply Mem.perm_implies with Freeable; auto with mem. - eapply Mem.perm_alloc_2; eauto. omega. - auto. - } - exploit Mem.drop_mapped_inj; eauto. apply init_meminj_no_overlap. -- set (sz := Genv.init_data_list_size (gvar_init gv)) in *. - destruct (Mem.alloc m1 0 sz) as (m1a, b1) eqn:ALLOC. - destruct (store_zeros m1a b1 0 sz) as [m1b|] eqn: STZ; try discriminate. - destruct (Genv.store_init_data_list ge m1b b1 0 (gvar_init gv)) as [m1c|] eqn:ST; try discriminate. - exploit Mem.alloc_result; eauto. intros EQ. rewrite <- EQ in H1. - destruct (Mem.alloc m2 0 sz) as (m2a, b2) eqn:ALLOC2. - exploit Mem.alloc_result; eauto. intros EQ2. rewrite <- EQ2 in H1. - assert (Mem.mem_inj init_meminj m1a m2a). - { eapply Mem.alloc_left_mapped_inj with (b1 := b1) (b2 := b2) (delta := 0). - eapply Mem.alloc_right_inj; eauto. - eauto. - eauto with mem. - red; intros; apply Z.divide_0_r. - intros. apply Mem.perm_implies with Freeable; auto with mem. - eapply Mem.perm_alloc_2; eauto. omega. - auto. - } - exploit store_zeros_mapped_inj; eauto. intros (m2b & A & B). - exploit store_init_data_list_mapped_inj; eauto. - intros. apply H2. red. exists ofs; auto. intros (m2c & C & D). - exploit Mem.drop_mapped_inj; eauto. apply init_meminj_no_overlap. intros (m2' & E & F). - exists m2'; split; auto. rewrite ! Zplus_0_r in E. rewrite A, C, E. auto. -Qed. - -Lemma alloc_globals_app: - forall F V (g: Genv.t F V) defs1 m defs2, - Genv.alloc_globals g m (defs1 ++ defs2) = - match Genv.alloc_globals g m defs1 with - | None => None - | Some m1 => Genv.alloc_globals g m1 defs2 - end. +Section INIT_MEM. + +Variables m tm: mem. +Hypothesis IM: Genv.init_mem p = Some m. +Hypothesis TIM: Genv.init_mem tp = Some tm. + +Lemma bytes_of_init_inject: + forall il, + (forall id, ref_init il id -> kept id) -> + list_forall2 (memval_inject init_meminj) (Genv.bytes_of_init_data_list ge il) (Genv.bytes_of_init_data_list tge il). Proof. - induction defs1; simpl; intros. auto. - destruct (Genv.alloc_global g m a); auto. + induction il as [ | i1 il]; simpl; intros. +- constructor. +- apply list_forall2_app. ++ destruct i1; simpl; try (apply inj_bytes_inject). + induction (Z.to_nat z); simpl; constructor. constructor. auto. + destruct (Genv.find_symbol ge i) as [b|] eqn:FS. + assert (kept i). { apply H. red. exists i0; auto with coqlib. } + exploit symbols_inject_2. apply init_meminj_preserves_globals. eauto. eauto. + intros (b' & A & B). rewrite A. apply inj_value_inject. + econstructor; eauto. symmetry; apply Int.add_zero. + destruct (Genv.find_symbol tge i) as [b'|] eqn:FS'. + exploit symbols_inject_3. apply init_meminj_preserves_globals. eauto. + intros (b & A & B). congruence. + apply repeat_Undef_inject_self with (n := 4%nat). ++ apply IHil. intros id [ofs IN]. apply H. exists ofs; auto with coqlib. Qed. -Lemma alloc_globals_snoc: - forall F V (g: Genv.t F V) m defs1 id_def, - Genv.alloc_globals g m (defs1 ++ id_def :: nil) = - match Genv.alloc_globals g m defs1 with - | None => None - | Some m1 => Genv.alloc_global g m1 id_def - end. +Lemma Mem_getN_forall2: + forall (P: memval -> memval -> Prop) c1 c2 i n p, + list_forall2 P (Mem.getN n p c1) (Mem.getN n p c2) -> + p <= i -> i < p + Z.of_nat n -> + P (ZMap.get i c1) (ZMap.get i c2). Proof. - intros. rewrite alloc_globals_app. - destruct (Genv.alloc_globals g m defs1); auto. unfold Genv.alloc_globals. - destruct (Genv.alloc_global g m0 id_def); auto. -Qed. - -Lemma alloc_globals_inj: - forall pubs defs m1 u g1 g2, - Genv.alloc_globals ge Mem.empty (List.rev defs) = Some m1 -> - g1 = Genv.add_globals (Genv.empty_genv _ _ pubs) (List.rev defs) -> - g2 = Genv.add_globals (Genv.empty_genv _ _ pubs) (filter_globdefs u nil defs) -> - Mem.nextblock m1 = Genv.genv_next g1 -> - (forall id, IS.In id u -> Genv.find_symbol g1 id = Genv.find_symbol ge id) -> - (forall id, IS.In id u -> Genv.find_symbol g2 id = Genv.find_symbol tge id) -> - (forall b id, Genv.find_symbol ge id = Some b -> Plt b (Mem.nextblock m1) -> kept id -> IS.In id u) -> - (forall id, IS.In id u -> (fold_left add_def_prog_map (List.rev defs) (PTree.empty _))!id = pm!id) -> - exists m2, - Genv.alloc_globals tge Mem.empty (filter_globdefs u nil defs) = Some m2 - /\ Mem.nextblock m2 = Genv.genv_next g2 - /\ Mem.mem_inj init_meminj m1 m2. -Proof. - induction defs; simpl; intros until g2; intros ALLOC GE1 GE2 NEXT1 SYMB1 SYMB2 SYMB3 PROGMAP. -- inv ALLOC. exists Mem.empty. intuition auto. constructor; intros. - eelim Mem.perm_empty; eauto. - exploit init_meminj_invert; eauto. intros [A B]. subst delta. apply Z.divide_0_r. - eelim Mem.perm_empty; eauto. -- rewrite Genv.add_globals_app in GE1. simpl in GE1. - set (g1' := Genv.add_globals (Genv.empty_genv fundef unit pubs) (rev defs)) in *. - rewrite alloc_globals_snoc in ALLOC. - destruct (Genv.alloc_globals ge Mem.empty (rev defs)) as [m1'|] eqn:ALLOC1'; try discriminate. - exploit Genv.alloc_global_nextblock; eauto. intros NEXTBLOCK1. - assert (NEXTGE1: Genv.genv_next g1 = Pos.succ (Genv.genv_next g1')) by (rewrite GE1; reflexivity). - assert (NEXT1': Mem.nextblock m1' = Genv.genv_next g1') by (unfold block in *; xomega). - rewrite fold_left_app in PROGMAP. simpl in PROGMAP. - destruct a as [id gd]. unfold add_def_prog_map at 1 in PROGMAP. simpl in PROGMAP. - destruct (IS.mem id u) eqn:MEM. - + rewrite filter_globdefs_nil in *. rewrite alloc_globals_snoc. - rewrite Genv.add_globals_app in GE2. simpl in GE2. - set (g2' := Genv.add_globals (Genv.empty_genv fundef unit pubs) (filter_globdefs (IS.remove id u) nil defs)) in *. - assert (NEXTGE2: Genv.genv_next g2 = Pos.succ (Genv.genv_next g2')) by (rewrite GE2; reflexivity). - assert (FS1: Genv.find_symbol ge id = Some (Mem.nextblock m1')). - { rewrite <- SYMB1 by (apply IS.mem_2; auto). - rewrite GE1. unfold Genv.find_symbol; simpl. rewrite PTree.gss. congruence. } - exploit (IHdefs m1' (IS.remove id u) g1' g2'); eauto. - intros. rewrite ISF.remove_iff in H; destruct H. - rewrite <- SYMB1 by auto. rewrite GE1. unfold Genv.find_symbol; simpl. - rewrite PTree.gso; auto. - intros. rewrite ISF.remove_iff in H; destruct H. - rewrite <- SYMB2 by auto. rewrite GE2. unfold Genv.find_symbol; simpl. - rewrite PTree.gso; auto. - intros. rewrite ISF.remove_iff. destruct (ident_eq id id0). - subst id0. rewrite FS1 in H. inv H. eelim Plt_strict; eauto. - exploit SYMB3. eexact H. unfold block in *; xomega. auto. tauto. - intros. rewrite ISF.remove_iff in H; destruct H. - rewrite <- PROGMAP by auto. rewrite PTree.gso by auto. auto. - intros (m2' & A & B & C). fold g2' in B. - assert (FS2: Genv.find_symbol tge id = Some (Mem.nextblock m2')). - { rewrite <- SYMB2 by (apply IS.mem_2; auto). - rewrite GE2. unfold Genv.find_symbol; simpl. rewrite PTree.gss. congruence. } - assert (INJ: init_meminj (Mem.nextblock m1') = Some (Mem.nextblock m2', 0)). - { apply Genv.find_invert_symbol in FS1. unfold init_meminj. rewrite FS1, FS2. auto. } - exploit alloc_global_mapped_inj. eexact ALLOC. eexact C. exact INJ. - intros. apply kept_closed with id gd. eapply transform_program_kept; eauto. - rewrite <- PROGMAP by (apply IS.mem_2; auto). apply PTree.gss. auto. - intros (m2 & D & E). - exploit Genv.alloc_global_nextblock; eauto. intros NEXTBLOCK2. - exists m2; split. rewrite A, D. auto. - split. unfold block in *; xomega. - auto. - + exploit (IHdefs m1' u g1' g2); auto. - intros. rewrite <- SYMB1 by auto. rewrite GE1. - unfold Genv.find_symbol; simpl. rewrite PTree.gso; auto. - red; intros; subst id0. apply IS.mem_1 in H. congruence. - intros. eapply SYMB3; eauto. unfold block in *; xomega. - intros. rewrite <- PROGMAP by auto. rewrite PTree.gso; auto. - apply IS.mem_1 in H. congruence. - intros (m2 & A & B & C). - assert (NOTINJ: init_meminj (Mem.nextblock m1') = None). - { destruct (init_meminj (Mem.nextblock m1')) as [[b' delta]|] eqn:J; auto. - exploit init_meminj_invert; eauto. intros (U & id1 & V & W). - exploit SYMB3; eauto. unfold block in *; xomega. - eapply transform_program_kept; eauto. - intros P. - revert V. rewrite <- SYMB1, GE1 by auto. unfold Genv.find_symbol; simpl. - rewrite PTree.gsspec. rewrite NEXT1'. destruct (peq id1 id); intros Q. - subst id1. apply IS.mem_1 in P. congruence. - eelim Plt_strict. eapply Genv.genv_symb_range; eauto. } - exists m2; intuition auto. eapply alloc_global_unmapped_inj; eauto. + induction n; simpl Mem.getN; intros. +- simpl in H1. omegaContradiction. +- inv H. rewrite inj_S in H1. destruct (zeq i p0). ++ congruence. ++ apply IHn with (p0 + 1); auto. omega. omega. +Qed. + +Lemma init_mem_inj_1: + Mem.mem_inj init_meminj m tm. +Proof. + intros; constructor; intros. +- exploit init_meminj_invert_strong; eauto. intros (A & id & gd & B & C & D & E & F). + exploit (Genv.init_mem_characterization_gen p); eauto. + exploit (Genv.init_mem_characterization_gen tp); eauto. + destruct gd as [f|v]. ++ intros (P2 & Q2) (P1 & Q1). + apply Q1 in H0. destruct H0. subst. + apply Mem.perm_cur. auto. ++ intros (P2 & Q2 & R2 & S2) (P1 & Q1 & R1 & S1). + apply Q1 in H0. destruct H0. subst. + apply Mem.perm_cur. eapply Mem.perm_implies; eauto. + apply P2. omega. +- exploit init_meminj_invert; eauto. intros (A & id & B & C). + subst delta. apply Zdivide_0. +- exploit init_meminj_invert_strong; eauto. intros (A & id & gd & B & C & D & E & F). + exploit (Genv.init_mem_characterization_gen p); eauto. + exploit (Genv.init_mem_characterization_gen tp); eauto. + destruct gd as [f|v]. ++ intros (P2 & Q2) (P1 & Q1). + apply Q1 in H0. destruct H0; discriminate. ++ intros (P2 & Q2 & R2 & S2) (P1 & Q1 & R1 & S1). + apply Q1 in H0. destruct H0. + assert (NO: gvar_volatile v = false). + { unfold Genv.perm_globvar in H1. destruct (gvar_volatile v); auto. inv H1. } +Local Transparent Mem.loadbytes. + generalize (S1 NO). unfold Mem.loadbytes. destruct Mem.range_perm_dec; intros E1; inv E1. + generalize (S2 NO). unfold Mem.loadbytes. destruct Mem.range_perm_dec; intros E2; inv E2. + rewrite Zplus_0_r. + apply Mem_getN_forall2 with (p := 0) (n := nat_of_Z (init_data_list_size (gvar_init v))). + rewrite H3, H4. apply bytes_of_init_inject. auto. + omega. + rewrite nat_of_Z_eq by (apply init_data_list_size_pos). omega. +Qed. + +Lemma init_mem_inj_2: + Mem.inject init_meminj m tm. +Proof. + constructor; intros. +- apply init_mem_inj_1. +- destruct (init_meminj b) as [[b' delta]|] eqn:INJ; auto. + elim H. exploit init_meminj_invert; eauto. intros (A & id & B & C). + eapply Genv.find_symbol_not_fresh; eauto. +- exploit init_meminj_invert; eauto. intros (A & id & B & C). + eapply Genv.find_symbol_not_fresh; eauto. +- red; intros. + exploit init_meminj_invert. eexact H0. intros (A1 & id1 & B1 & C1). + exploit init_meminj_invert. eexact H1. intros (A2 & id2 & B2 & C2). + destruct (ident_eq id1 id2). congruence. left; eapply Genv.global_addresses_distinct; eauto. +- exploit init_meminj_invert; eauto. intros (A & id & B & C). subst delta. + split. omega. generalize (Int.unsigned_range_2 ofs). omega. +Qed. + +End INIT_MEM. + +Lemma init_mem_exists: + forall m, Genv.init_mem p = Some m -> + exists tm, Genv.init_mem tp = Some tm. +Proof. + intros. apply Genv.init_mem_exists. + intros. + assert (P: (prog_defmap tp)!id = Some (Gvar v)). + { eapply prog_defmap_norepet; eauto. eapply match_prog_unique; eauto. } + rewrite (match_prog_def _ _ _ TRANSF) in P. destruct (IS.mem id used) eqn:U; try discriminate. + exploit Genv.init_mem_inversion; eauto. apply in_prog_defmap; eauto. intros [AL FV]. + split. auto. + intros. exploit FV; eauto. intros (b & FS). + apply transform_find_symbol_1 with b; auto. + apply kept_closed with id (Gvar v). + apply IS.mem_2; auto. auto. red. red. exists o; auto. Qed. Theorem init_mem_inject: @@ -1260,40 +1205,25 @@ Theorem init_mem_inject: exists f tm, Genv.init_mem tp = Some tm /\ Mem.inject f m tm /\ meminj_preserves_globals f. Proof. intros. - unfold transform_program in TRANSF; rewrite USED_GLOBALS in TRANSF; injection TRANSF. intros EQ. - destruct (alloc_globals_inj (prog_public p) (List.rev (prog_defs p)) m used ge tge) as (tm & A & B & C). - rewrite rev_involutive; auto. - rewrite rev_involutive; auto. - unfold tge; rewrite <- EQ; auto. - symmetry. apply Genv.init_mem_genv_next; auto. - auto. auto. auto. - intros. rewrite rev_involutive. auto. - assert (D: Genv.init_mem tp = Some tm). - { unfold Genv.init_mem. fold tge. rewrite <- EQ. exact A. } - pose proof (init_meminj_preserves_globals). - exists init_meminj, tm; intuition auto. - constructor; intros. - + auto. - + destruct (init_meminj b) as [[b1 delta1]|] eqn:INJ; auto. - exploit init_meminj_invert; eauto. intros (P & id & Q & R). - elim H1. eapply Genv.find_symbol_not_fresh; eauto. - + exploit init_meminj_invert; eauto. intros (P & id & Q & R). - eapply Genv.find_symbol_not_fresh; eauto. - + apply init_meminj_no_overlap. - + exploit init_meminj_invert; eauto. intros (P & id & Q & R). - split. omega. generalize (Int.unsigned_range_2 ofs). omega. + exploit init_mem_exists; eauto. intros [tm INIT]. + exists init_meminj, tm. + split. auto. + split. eapply init_mem_inj_2; eauto. + apply init_meminj_preserves_globals. Qed. Lemma transf_initial_states: forall S1, initial_state p S1 -> exists S2, initial_state tp S2 /\ match_states S1 S2. Proof. intros. inv H. exploit init_mem_inject; eauto. intros (j & tm & A & B & C). - exploit symbols_inject_2. eauto. apply kept_main. eexact H1. intros (tb & P & Q). - exploit funct_ptr_inject. eauto. eexact Q. exact H2. + exploit symbols_inject_2. eauto. eapply kept_main. eexact H1. intros (tb & P & Q). + rewrite Genv.find_funct_ptr_iff in H2. + exploit defs_inject. eauto. eexact Q. exact H2. intros (R & S & T). + rewrite <- Genv.find_funct_ptr_iff in R. exists (Callstate nil f nil tm); split. econstructor; eauto. - fold tge. unfold transform_program in TRANSF; rewrite USED_GLOBALS in TRANSF; inversion TRANSF; auto. + fold tge. erewrite match_prog_main by eauto. auto. econstructor; eauto. constructor. auto. erewrite <- Genv.init_mem_genv_next by eauto. apply Ple_refl. @@ -1307,7 +1237,7 @@ Proof. intros. inv H0. inv H. inv STACKS. inv RESINJ. constructor. Qed. -Theorem transf_program_correct: +Lemma transf_program_correct_1: forward_simulation (semantics p) (semantics tp). Proof. intros. @@ -1319,3 +1249,175 @@ Proof. Qed. End SOUNDNESS. + +Theorem transf_program_correct: + forall p tp, match_prog p tp -> forward_simulation (semantics p) (semantics tp). +Proof. + intros p tp (used & A & B). apply transf_program_correct_1 with used; auto. +Qed. + +(** * Commutation with linking *) + +Remark link_def_either: + forall (gd1 gd2 gd: globdef fundef unit), + link_def gd1 gd2 = Some gd -> gd = gd1 \/ gd = gd2. +Proof with (try discriminate). + intros until gd. +Local Transparent Linker_def Linker_fundef Linker_varinit Linker_vardef Linker_unit. + destruct gd1 as [f1|v1], gd2 as [f2|v2]... +(* Two fundefs *) + destruct f1 as [f1|ef1], f2 as [f2|ef2]; simpl... + destruct ef2; intuition congruence. + destruct ef1; intuition congruence. + destruct (external_function_eq ef1 ef2); intuition congruence. +(* Two vardefs *) + simpl. unfold link_vardef. destruct v1 as [info1 init1 ro1 vo1], v2 as [info2 init2 ro2 vo2]; simpl. + destruct (link_varinit init1 init2) as [init|] eqn:LI... + destruct (eqb ro1 ro2) eqn:RO... + destruct (eqb vo1 vo2) eqn:VO... + simpl. + destruct info1, info2. + assert (EITHER: init = init1 \/ init = init2). + { revert LI. unfold link_varinit. + destruct (classify_init init1), (classify_init init2); intro EQ; inv EQ; auto. + destruct (zeq sz (Z.max sz0 0 + 0)); inv H0; auto. + destruct (zeq sz (init_data_list_size il)); inv H0; auto. + destruct (zeq sz (init_data_list_size il)); inv H0; auto. } + apply eqb_prop in RO. apply eqb_prop in VO. + intro EQ; inv EQ. destruct EITHER; subst init; auto. +Qed. + +Remark used_not_defined: + forall p used id, + valid_used_set p used -> + (prog_defmap p)!id = None -> + IS.mem id used = false \/ id = prog_main p. +Proof. + intros. destruct (IS.mem id used) eqn:M; auto. + exploit used_defined; eauto using IS.mem_2. intros [A|A]; auto. + apply prog_defmap_dom in A. destruct A as [g E]; congruence. +Qed. + +Remark used_not_defined_2: + forall p used id, + valid_used_set p used -> + id <> prog_main p -> + (prog_defmap p)!id = None -> + ~IS.In id used. +Proof. + intros. exploit used_not_defined; eauto. intros [A|A]. + red; intros; apply IS.mem_1 in H2; congruence. + congruence. +Qed. + +Lemma link_valid_used_set: + forall p1 p2 p used1 used2, + link p1 p2 = Some p -> + valid_used_set p1 used1 -> + valid_used_set p2 used2 -> + valid_used_set p (IS.union used1 used2). +Proof. + intros until used2; intros L V1 V2. + destruct (link_prog_inv _ _ _ L) as (X & Y & Z). + rewrite Z; clear Z; constructor. +- intros. rewrite ISF.union_iff in H. rewrite ISF.union_iff. + rewrite prog_defmap_elements, PTree.gcombine in H0. + destruct (prog_defmap p1)!id as [gd1|] eqn:GD1; + destruct (prog_defmap p2)!id as [gd2|] eqn:GD2; + simpl in H0; try discriminate. ++ (* common definition *) + exploit Y; eauto. intros (PUB1 & PUB2 & _). + exploit link_def_either; eauto. intros [EQ|EQ]; subst gd. +* left. eapply used_closed. eexact V1. eapply used_public. eexact V1. eauto. eauto. auto. +* right. eapply used_closed. eexact V2. eapply used_public. eexact V2. eauto. eauto. auto. ++ (* left definition *) + inv H0. destruct (ISP.In_dec id used1). +* left; eapply used_closed; eauto. +* assert (IS.In id used2) by tauto. + exploit used_defined. eexact V2. eauto. intros [A|A]. + exploit prog_defmap_dom; eauto. intros [g E]; congruence. + elim n. rewrite A, <- X. eapply used_main; eauto. ++ (* right definition *) + inv H0. destruct (ISP.In_dec id used2). +* right; eapply used_closed; eauto. +* assert (IS.In id used1) by tauto. + exploit used_defined. eexact V1. eauto. intros [A|A]. + exploit prog_defmap_dom; eauto. intros [g E]; congruence. + elim n. rewrite A, X. eapply used_main; eauto. ++ (* no definition *) + auto. +- simpl. rewrite ISF.union_iff; left; eapply used_main; eauto. +- simpl. intros id. rewrite in_app_iff, ISF.union_iff. + intros [A|A]; [left|right]; eapply used_public; eauto. +- intros. rewrite ISF.union_iff in H. + destruct (ident_eq id (prog_main p1)). ++ right; assumption. ++ assert (E: exists g, link_prog_merge (prog_defmap p1)!id (prog_defmap p2)!id = Some g). + { destruct (prog_defmap p1)!id as [gd1|] eqn:GD1; + destruct (prog_defmap p2)!id as [gd2|] eqn:GD2; simpl. + * apply Y with id; auto. + * exists gd1; auto. + * exists gd2; auto. + * eapply used_not_defined_2 in GD1; eauto. eapply used_not_defined_2 in GD2; eauto. + tauto. + congruence. + } + destruct E as [g LD]. + left. unfold prog_defs_names; simpl. + change id with (fst (id, g)). apply in_map. apply PTree.elements_correct. + rewrite PTree.gcombine; auto. +Qed. + +Theorem link_match_program: + forall p1 p2 tp1 tp2 p, + link p1 p2 = Some p -> + match_prog p1 tp1 -> match_prog p2 tp2 -> + exists tp, link tp1 tp2 = Some tp /\ match_prog p tp. +Proof. + intros. destruct H0 as (used1 & A1 & B1). destruct H1 as (used2 & A2 & B2). + destruct (link_prog_inv _ _ _ H) as (U & V & W). + econstructor; split. +- apply link_prog_succeeds. ++ rewrite (match_prog_main _ _ _ B1), (match_prog_main _ _ _ B2). auto. ++ intros. + rewrite (match_prog_def _ _ _ B1) in H0. + rewrite (match_prog_def _ _ _ B2) in H1. + destruct (IS.mem id used1) eqn:U1; try discriminate. + destruct (IS.mem id used2) eqn:U2; try discriminate. + edestruct V as (X & Y & gd & Z); eauto. + split. rewrite (match_prog_public _ _ _ B1); auto. + split. rewrite (match_prog_public _ _ _ B2); auto. + congruence. +- exists (IS.union used1 used2); split. ++ eapply link_valid_used_set; eauto. ++ rewrite W. constructor; simpl; intros. +* eapply match_prog_main; eauto. +* rewrite (match_prog_public _ _ _ B1), (match_prog_public _ _ _ B2). auto. +* rewrite ! prog_defmap_elements, !PTree.gcombine by auto. + rewrite (match_prog_def _ _ _ B1 id), (match_prog_def _ _ _ B2 id). + rewrite ISF.union_b. +{ + destruct (prog_defmap p1)!id as [gd1|] eqn:GD1; + destruct (prog_defmap p2)!id as [gd2|] eqn:GD2. +- (* both defined *) + exploit V; eauto. intros (PUB1 & PUB2 & _). + assert (EQ1: IS.mem id used1 = true) by (apply IS.mem_1; eapply used_public; eauto). + assert (EQ2: IS.mem id used2 = true) by (apply IS.mem_1; eapply used_public; eauto). + rewrite EQ1, EQ2; auto. +- (* left defined *) + exploit used_not_defined; eauto. intros [A|A]. + rewrite A, orb_false_r. destruct (IS.mem id used1); auto. + replace (IS.mem id used1) with true. destruct (IS.mem id used2); auto. + symmetry. apply IS.mem_1. rewrite A, <- U. eapply used_main; eauto. +- (* right defined *) + exploit used_not_defined. eexact A1. eauto. intros [A|A]. + rewrite A, orb_false_l. destruct (IS.mem id used2); auto. + replace (IS.mem id used2) with true. destruct (IS.mem id used1); auto. + symmetry. apply IS.mem_1. rewrite A, U. eapply used_main; eauto. +- (* none defined *) + destruct (IS.mem id used1), (IS.mem id used2); auto. +} +* intros. apply PTree.elements_keys_norepet. +Qed. + +Instance TransfSelectionLink : TransfLink match_prog := link_match_program. diff --git a/backend/ValueAnalysis.v b/backend/ValueAnalysis.v index 979f8c0e..a4d34279 100644 --- a/backend/ValueAnalysis.v +++ b/backend/ValueAnalysis.v @@ -10,24 +10,11 @@ (* *) (* *********************************************************************) -Require Import Coqlib. -Require Import Maps. -Require Import Compopts. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import Memory. -Require Import Globalenvs. -Require Import Events. -Require Import Lattice. -Require Import Kildall. -Require Import Registers. -Require Import Op. -Require Import RTL. -Require Import ValueDomain. -Require Import ValueAOp. -Require Import Liveness. +Require Import Coqlib Maps Integers Floats Lattice Kildall. +Require Import Compopts AST Linking. +Require Import Values Memory Globalenvs Events. +Require Import Registers Op RTL. +Require Import ValueDomain ValueAOp Liveness. (** * The dataflow analysis *) @@ -208,7 +195,7 @@ Fixpoint store_init_data_list (ab: ablock) (p: Z) (idl: list init_data) {struct idl}: ablock := match idl with | nil => ab - | id :: idl' => store_init_data_list (store_init_data ab p id) (p + Genv.init_data_size id) idl' + | id :: idl' => store_init_data_list (store_init_data ab p id) (p + init_data_size id) idl' end. (** When CompCert is used in separate compilation mode, the [gvar_init] @@ -239,7 +226,7 @@ Definition alloc_global (rm: romem) (idg: ident * globdef fundef unit): romem := else PTree.remove id rm end. -Definition romem_for_program (p: program) : romem := +Definition romem_for (p: program) : romem := List.fold_left alloc_global p.(prog_defs) (PTree.empty _). (** * Soundness proof *) @@ -1045,10 +1032,9 @@ Qed. Section SOUNDNESS. Variable prog: program. +Variable ge: genv. -Let ge : genv := Genv.globalenv prog. - -Let rm := romem_for_program prog. +Let rm := romem_for prog. Inductive sound_stack: block_classification -> list stackframe -> mem -> block -> Prop := | sound_stack_nil: forall bc m bound, @@ -1079,7 +1065,7 @@ Inductive sound_stack: block_classification -> list stackframe -> mem -> block - (CONTENTS: bmatch bc' m sp am.(am_stack)), sound_stack bc (Stackframe res f (Vptr sp Int.zero) pc e :: stk) m bound. -Inductive sound_state: state -> Prop := +Inductive sound_state_base: state -> Prop := | sound_regular_state: forall s f sp pc e m ae am bc (STK: sound_stack bc s m sp) @@ -1089,7 +1075,7 @@ Inductive sound_state: state -> Prop := (MM: mmatch bc m am) (GE: genv_match bc ge) (SP: bc sp = BCstack), - sound_state (State s f (Vptr sp Int.zero) pc e m) + sound_state_base (State s f (Vptr sp Int.zero) pc e m) | sound_call_state: forall s fd args m bc (STK: sound_stack bc s m (Mem.nextblock m)) @@ -1098,7 +1084,7 @@ Inductive sound_state: state -> Prop := (MM: mmatch bc m mtop) (GE: genv_match bc ge) (NOSTK: bc_nostack bc), - sound_state (Callstate s fd args m) + sound_state_base (Callstate s fd args m) | sound_return_state: forall s v m bc (STK: sound_stack bc s m (Mem.nextblock m)) @@ -1107,7 +1093,7 @@ Inductive sound_state: state -> Prop := (MM: mmatch bc m mtop) (GE: genv_match bc ge) (NOSTK: bc_nostack bc), - sound_state (Returnstate s v m). + sound_state_base (Returnstate s v m). (** Properties of the [sound_stack] invariant on call stacks. *) @@ -1223,14 +1209,14 @@ Lemma sound_succ_state: genv_match bc ge -> bc sp = BCstack -> sound_stack bc s m' sp -> - sound_state (State s f (Vptr sp Int.zero) pc' e' m'). + sound_state_base (State s f (Vptr sp Int.zero) pc' e' m'). Proof. intros. exploit analyze_succ; eauto. intros (ae'' & am'' & AN & EM & MM). econstructor; eauto. Qed. -Theorem sound_step: - forall st t st', RTL.step ge st t st' -> sound_state st -> sound_state st'. +Theorem sound_step_base: + forall st t st', RTL.step ge st t st' -> sound_state_base st -> sound_state_base st'. Proof. induction 1; intros SOUND; inv SOUND. @@ -1309,7 +1295,7 @@ Proof. (* The default case *) assert (DEFAULT: transfer f rm pc ae am = transfer_builtin_default ae am rm args res -> - sound_state + sound_state_base (State s f (Vptr sp0 Int.zero) pc' (regmap_setres res vres rs) m')). { unfold transfer_builtin_default, analyze_call; intros TR'. set (aargs := map (abuiltin_arg ae am rm) args) in *. @@ -1480,6 +1466,37 @@ Qed. End SOUNDNESS. +(** ** Extension to separate compilation *) + +(** Following Kang et al, POPL 2016, we now extend the results above + to the case where only one compilation unit is analyzed, and not the + whole program. *) + +Section LINKING. + +Variable prog: program. +Let ge := Genv.globalenv prog. + +Inductive sound_state: state -> Prop := + | sound_state_intro: forall st, + (forall cunit, linkorder cunit prog -> sound_state_base cunit ge st) -> + sound_state st. + +Theorem sound_step: + forall st t st', RTL.step ge st t st' -> sound_state st -> sound_state st'. +Proof. + intros. inv H0. constructor; intros. eapply sound_step_base; eauto. +Qed. + +Remark sound_state_inv: + forall st cunit, + sound_state st -> linkorder cunit prog -> sound_state_base cunit ge st. +Proof. + intros. inv H. eauto. +Qed. + +End LINKING. + (** ** Soundness of the initial memory abstraction *) Section INITIAL. @@ -1660,8 +1677,8 @@ Proof. Qed. Definition initial_mem_match (bc: block_classification) (m: mem) (g: genv) := - forall b v, - Genv.find_var_info g b = Some v -> + forall id b v, + Genv.find_symbol g id = Some b -> Genv.find_var_info g b = Some v -> v.(gvar_volatile) = false -> v.(gvar_readonly) = true -> bmatch bc m b (store_init_data_list (ablock_init Pbot) 0 v.(gvar_init)). @@ -1672,27 +1689,32 @@ Lemma alloc_global_match: Genv.alloc_global ge m idg = Some m' -> initial_mem_match bc m' (Genv.add_global g idg). Proof. - intros; red; intros. destruct idg as [id [fd | gv]]; simpl in *. + intros; red; intros. destruct idg as [id1 [fd | gv]]; simpl in *. - destruct (Mem.alloc m 0 1) as [m1 b1] eqn:ALLOC. - unfold Genv.find_var_info, Genv.add_global in H2; simpl in H2. - assert (Plt b (Mem.nextblock m)). - { rewrite <- H. eapply Genv.genv_vars_range; eauto. } - assert (b <> b1). - { apply Plt_ne. erewrite Mem.alloc_result by eauto. auto. } + unfold Genv.find_symbol in H2; simpl in H2. + unfold Genv.find_var_info, Genv.find_def in H3; simpl in H3. + rewrite PTree.gsspec in H2. destruct (peq id id1). + inv H2. rewrite PTree.gss in H3. discriminate. + assert (Plt b (Genv.genv_next g)) by (eapply Genv.genv_symb_range; eauto). + rewrite PTree.gso in H3 by (apply Plt_ne; auto). + assert (Mem.valid_block m b) by (red; rewrite <- H; auto). + assert (b <> b1) by (apply Mem.valid_not_valid_diff with m; eauto with mem). apply bmatch_inv with m. eapply H0; eauto. - intros. transitivity (Mem.loadbytes m1 b ofs n). + intros. transitivity (Mem.loadbytes m1 b ofs n0). eapply Mem.loadbytes_drop; eauto. eapply Mem.loadbytes_alloc_unchanged; eauto. -- set (sz := Genv.init_data_list_size (gvar_init gv)) in *. +- set (sz := init_data_list_size (gvar_init gv)) in *. destruct (Mem.alloc m 0 sz) as [m1 b1] eqn:ALLOC. destruct (store_zeros m1 b1 0 sz) as [m2 | ] eqn:STZ; try discriminate. destruct (Genv.store_init_data_list ge m2 b1 0 (gvar_init gv)) as [m3 | ] eqn:SIDL; try discriminate. - unfold Genv.find_var_info, Genv.add_global in H2; simpl in H2. - rewrite PTree.gsspec in H2. destruct (peq b (Genv.genv_next g)). -+ inversion H2; clear H2; subst v. + unfold Genv.find_symbol in H2; simpl in H2. + unfold Genv.find_var_info, Genv.find_def in H3; simpl in H3. + rewrite PTree.gsspec in H2. destruct (peq id id1). ++ injection H2; clear H2; intro EQ. + rewrite EQ, PTree.gss in H3. injection H3; clear H3; intros EQ'; subst v. assert (b = b1). { erewrite Mem.alloc_result by eauto. congruence. } - clear e. subst b. + clear EQ. subst b. apply bmatch_inv with m3. eapply store_init_data_list_sound; eauto. apply ablock_init_sound. @@ -1701,11 +1723,11 @@ Proof. exploit Mem.load_alloc_same; eauto. intros EQ; subst v; constructor. exploit Mem.loadbytes_alloc_same; eauto with coqlib. congruence. intros. eapply Mem.loadbytes_drop; eauto. - right; right; right. unfold Genv.perm_globvar. rewrite H3, H4. constructor. -+ assert (Plt b (Mem.nextblock m)). - { rewrite <- H. eapply Genv.genv_vars_range; eauto. } - assert (b <> b1). - { apply Plt_ne. erewrite Mem.alloc_result by eauto. auto. } + right; right; right. unfold Genv.perm_globvar. rewrite H4, H5. constructor. ++ assert (Plt b (Genv.genv_next g)) by (eapply Genv.genv_symb_range; eauto). + rewrite PTree.gso in H3 by (apply Plt_ne; auto). + assert (Mem.valid_block m b) by (red; rewrite <- H; auto). + assert (b <> b1) by (apply Mem.valid_not_valid_diff with m; eauto with mem). apply bmatch_inv with m3. eapply store_init_data_list_other; eauto. eapply store_zeros_other; eauto. @@ -1730,44 +1752,56 @@ Proof. eapply alloc_global_match; eauto. Qed. -Definition romem_consistent (g: genv) (rm: romem) := - forall id b ab, - Genv.find_symbol g id = Some b -> rm!id = Some ab -> +Definition romem_consistent (defmap: PTree.t (globdef fundef unit)) (rm: romem) := + forall id ab, + rm!id = Some ab -> exists v, - Genv.find_var_info g b = Some v + defmap!id = Some (Gvar v) /\ v.(gvar_readonly) = true /\ v.(gvar_volatile) = false + /\ definitive_initializer v.(gvar_init) = true /\ ab = store_init_data_list (ablock_init Pbot) 0 v.(gvar_init). Lemma alloc_global_consistent: - forall g rm idg, - romem_consistent g rm -> - romem_consistent (Genv.add_global g idg) (alloc_global rm idg). + forall dm rm idg, + romem_consistent dm rm -> + romem_consistent (PTree.set (fst idg) (snd idg) dm) (alloc_global rm idg). +Proof. + intros; red; intros. destruct idg as [id1 [f1 | v1]]; simpl in *. +- rewrite PTree.grspec in H0. destruct (PTree.elt_eq id id1); try discriminate. + rewrite PTree.gso by auto. apply H; auto. +- destruct (gvar_readonly v1 && negb (gvar_volatile v1) && definitive_initializer (gvar_init v1)) eqn:RO. ++ InvBooleans. rewrite negb_true_iff in H4. + rewrite PTree.gsspec in *. destruct (peq id id1). +* inv H0. exists v1; auto. +* apply H; auto. ++ rewrite PTree.grspec in H0. destruct (PTree.elt_eq id id1); try discriminate. + rewrite PTree.gso by auto. apply H; auto. +Qed. + +Lemma romem_for_consistent: + forall cunit, romem_consistent (prog_defmap cunit) (romem_for cunit). Proof. - intros; red; intros. destruct idg as [id1 [fd1 | v1]]; - unfold Genv.add_global, Genv.find_symbol, Genv.find_var_info, alloc_global in *; simpl in *. -- rewrite PTree.gsspec in H0. rewrite PTree.grspec in H1. unfold PTree.elt_eq in *. - destruct (peq id id1). congruence. eapply H; eauto. -- rewrite PTree.gsspec in H0. destruct (peq id id1). -+ inv H0. rewrite PTree.gss. - destruct (gvar_readonly v1 && negb (gvar_volatile v1) && definitive_initializer (gvar_init v1)) eqn:RO. - InvBooleans. rewrite negb_true_iff in H4. - rewrite PTree.gss in H1. - exists v1. intuition congruence. - rewrite PTree.grs in H1. discriminate. -+ rewrite PTree.gso. eapply H; eauto. - destruct (gvar_readonly v1 && negb (gvar_volatile v1) && definitive_initializer (gvar_init v1)). - rewrite PTree.gso in H1; auto. - rewrite PTree.gro in H1; auto. - apply Plt_ne. eapply Genv.genv_symb_range; eauto. + assert (REC: forall l dm rm, + romem_consistent dm rm -> + romem_consistent (fold_left (fun m idg => PTree.set (fst idg) (snd idg) m) l dm) + (fold_left alloc_global l rm)). + { induction l; intros; simpl; auto. apply IHl. apply alloc_global_consistent; auto. } + intros. apply REC. + red; intros. rewrite PTree.gempty in H; discriminate. Qed. -Lemma alloc_globals_consistent: - forall gl g rm, - romem_consistent g rm -> - romem_consistent (Genv.add_globals g gl) (List.fold_left alloc_global gl rm). +Lemma romem_for_consistent_2: + forall cunit, linkorder cunit prog -> romem_consistent (prog_defmap prog) (romem_for cunit). Proof. - induction gl; simpl; intros. auto. apply IHgl. apply alloc_global_consistent; auto. + intros; red; intros. + exploit (romem_for_consistent cunit); eauto. intros (v & DM & RO & VO & DEFN & AB). + destruct (prog_defmap_linkorder _ _ _ _ H DM) as (gd & P & Q). + assert (gd = Gvar v). + { inv Q. inv H2. simpl in *. f_equal. f_equal. + destruct info1, info2; auto. + inv H3; auto; discriminate. } + subst gd. exists v; auto. Qed. End INIT. @@ -1779,27 +1813,28 @@ Theorem initial_mem_matches: genv_match bc ge /\ bc_below bc (Mem.nextblock m) /\ bc_nostack bc - /\ romatch bc m (romem_for_program prog) + /\ (forall cunit, linkorder cunit prog -> romatch bc m (romem_for cunit)) /\ (forall b, Mem.valid_block m b -> bc b <> BCinvalid). Proof. intros. exploit initial_block_classification; eauto. intros (bc & GE & BELOW & NOSTACK & INV & VALID). exists bc; splitall; auto. + intros. assert (A: initial_mem_match bc m ge). { apply alloc_globals_match with (m := Mem.empty); auto. - red. unfold Genv.find_var_info; simpl. intros. rewrite PTree.gempty in H0; discriminate. - } - assert (B: romem_consistent ge (romem_for_program prog)). - { - apply alloc_globals_consistent. - red; intros. rewrite PTree.gempty in H1; discriminate. + red. unfold Genv.find_symbol; simpl; intros. rewrite PTree.gempty in H1; discriminate. } + assert (B: romem_consistent (prog_defmap prog) (romem_for cunit)) by (apply romem_for_consistent_2; auto). red; intros. - exploit B; eauto. intros (v & FV & RO & NVOL & EQ). + exploit B; eauto. intros (v & DM & RO & NVOL & DEFN & EQ). + rewrite Genv.find_def_symbol in DM. destruct DM as (b1 & FS & FD). + rewrite <- Genv.find_var_info_iff in FD. + assert (b1 = b). { apply INV in H1. unfold ge in H1; congruence. } + subst b1. split. subst ab. apply store_init_data_list_summary. constructor. split. subst ab. eapply A; eauto. - unfold ge in FV; exploit Genv.init_mem_characterization; eauto. + exploit Genv.init_mem_characterization; eauto. intros (P & Q & R). intros; red; intros. exploit Q; eauto. intros [U V]. unfold Genv.perm_globvar in V; rewrite RO, NVOL in V. inv V. @@ -1814,10 +1849,10 @@ Theorem sound_initial: Proof. destruct 1. exploit initial_mem_matches; eauto. intros (bc & GE & BELOW & NOSTACK & RM & VALID). - apply sound_call_state with bc. + constructor; intros. apply sound_call_state with bc. - constructor. - simpl; tauto. -- exact RM. +- apply RM; auto. - apply mmatch_inj_top with m0. replace (inj_of_bc bc) with (Mem.flat_inj (Mem.nextblock m0)). eapply Genv.initmem_inject; eauto. @@ -1833,6 +1868,12 @@ Hint Resolve areg_sound aregs_sound: va. (** * Interface with other optimizations *) +Ltac InvSoundState := + match goal with + | H1: sound_state ?prog ?st, H2: linkorder ?cunit ?prog |- _ => + let S := fresh "S" in generalize (sound_state_inv _ _ _ H1 H2); intros S; inv S + end. + Definition avalue (a: VA.t) (r: reg) : aval := match a with | VA.Bot => Vbot @@ -1840,14 +1881,15 @@ Definition avalue (a: VA.t) (r: reg) : aval := end. Lemma avalue_sound: - forall prog s f sp pc e m r, + forall cunit prog s f sp pc e m r, sound_state prog (State s f (Vptr sp Int.zero) pc e m) -> + linkorder cunit prog -> exists bc, - vmatch bc e#r (avalue (analyze (romem_for_program prog) f)!!pc r) + vmatch bc e#r (avalue (analyze (romem_for cunit) f)!!pc r) /\ genv_match bc (Genv.globalenv prog) /\ bc sp = BCstack. Proof. - intros. inv H. exists bc; split; auto. rewrite AN. apply EM. + intros. InvSoundState. exists bc; split; auto. rewrite AN. apply EM. Qed. Definition aaddr (a: VA.t) (r: reg) : aptr := @@ -1857,16 +1899,17 @@ Definition aaddr (a: VA.t) (r: reg) : aptr := end. Lemma aaddr_sound: - forall prog s f sp pc e m r b ofs, + forall cunit prog s f sp pc e m r b ofs, sound_state prog (State s f (Vptr sp Int.zero) pc e m) -> + linkorder cunit prog -> e#r = Vptr b ofs -> exists bc, - pmatch bc b ofs (aaddr (analyze (romem_for_program prog) f)!!pc r) + pmatch bc b ofs (aaddr (analyze (romem_for cunit) f)!!pc r) /\ genv_match bc (Genv.globalenv prog) /\ bc sp = BCstack. Proof. - intros. inv H. exists bc; split; auto. - unfold aaddr; rewrite AN. apply match_aptr_of_aval. rewrite <- H0. apply EM. + intros. InvSoundState. exists bc; split; auto. + unfold aaddr; rewrite AN. apply match_aptr_of_aval. rewrite <- H1. apply EM. Qed. Definition aaddressing (a: VA.t) (addr: addressing) (args: list reg) : aptr := @@ -1876,15 +1919,16 @@ Definition aaddressing (a: VA.t) (addr: addressing) (args: list reg) : aptr := end. Lemma aaddressing_sound: - forall prog s f sp pc e m addr args b ofs, + forall cunit prog s f sp pc e m addr args b ofs, sound_state prog (State s f (Vptr sp Int.zero) pc e m) -> + linkorder cunit prog -> eval_addressing (Genv.globalenv prog) (Vptr sp Int.zero) addr e##args = Some (Vptr b ofs) -> exists bc, - pmatch bc b ofs (aaddressing (analyze (romem_for_program prog) f)!!pc addr args) + pmatch bc b ofs (aaddressing (analyze (romem_for cunit) f)!!pc addr args) /\ genv_match bc (Genv.globalenv prog) /\ bc sp = BCstack. Proof. - intros. inv H. exists bc; split; auto. + intros. InvSoundState. exists bc; split; auto. unfold aaddressing. rewrite AN. apply match_aptr_of_aval. eapply eval_static_addressing_sound; eauto with va. Qed. @@ -1921,14 +1965,15 @@ Proof. Qed. Lemma aaddr_arg_sound: - forall prog s f sp pc e m a b ofs, + forall cunit prog s f sp pc e m a b ofs, sound_state prog (State s f (Vptr sp Int.zero) pc e m) -> + linkorder cunit prog -> eval_builtin_arg (Genv.globalenv prog) (fun r => e#r) (Vptr sp Int.zero) m a (Vptr b ofs) -> exists bc, - pmatch bc b ofs (aaddr_arg (analyze (romem_for_program prog) f)!!pc a) + pmatch bc b ofs (aaddr_arg (analyze (romem_for cunit) f)!!pc a) /\ genv_match bc (Genv.globalenv prog) /\ bc sp = BCstack. Proof. - intros. inv H. rewrite AN. exists bc; split; auto. + intros. InvSoundState. rewrite AN. exists bc; split; auto. eapply aaddr_arg_sound_1; eauto. Qed. diff --git a/backend/ValueDomain.v b/backend/ValueDomain.v index 048ab816..f9ccd5db 100644 --- a/backend/ValueDomain.v +++ b/backend/ValueDomain.v @@ -10,21 +10,12 @@ (* *) (* *********************************************************************) -Require Import Coqlib. -Require Import Zwf. -Require Import Maps. -Require Import Compopts. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import Memory. -Require Import Globalenvs. -Require Import Events. -Require Import Lattice. -Require Import Kildall. -Require Import Registers. -Require Import RTL. +Require Import Zwf Coqlib Maps Integers Floats Lattice. +Require Import Compopts AST. +Require Import Values Memory Globalenvs Events. +Require Import Registers RTL. + +(** The abstract domains for value analysis *) Inductive block_class : Type := | BCinvalid @@ -3814,7 +3805,8 @@ Lemma inj_of_bc_preserves_globals: Proof. intros. destruct H as [A B]. split. intros. apply inj_of_bc_valid. rewrite A in H. congruence. - split. intros. apply inj_of_bc_valid. apply B. eapply Genv.genv_vars_range; eauto. + split. intros. apply inj_of_bc_valid. apply B. + rewrite Genv.find_var_info_iff in H. eapply Genv.genv_defs_range; eauto. intros. exploit inj_of_bc_inv; eauto. intros (P & Q & R). auto. Qed. diff --git a/cfrontend/C2C.ml b/cfrontend/C2C.ml index e4001e6b..418fa702 100644 --- a/cfrontend/C2C.ml +++ b/cfrontend/C2C.ml @@ -1090,6 +1090,7 @@ let convertFundef loc env fd = (** External function declaration *) let re_builtin = Str.regexp "__builtin_" +let re_runtime = Str.regexp "__i64_" let convertFundecl env (sto, id, ty, optinit) = let (args, res, cconv) = @@ -1102,6 +1103,7 @@ let convertFundecl env (sto, id, ty, optinit) = let ef = if id.name = "malloc" then EF_malloc else if id.name = "free" then EF_free else + if Str.string_match re_runtime id.name 0 then EF_runtime(id'', sg) else if Str.string_match re_builtin id.name 0 && List.mem_assoc id.name builtins.functions then EF_builtin(id'', sg) diff --git a/cfrontend/Cexec.v b/cfrontend/Cexec.v index 00d77b00..bf88e033 100644 --- a/cfrontend/Cexec.v +++ b/cfrontend/Cexec.v @@ -536,6 +536,7 @@ Definition do_external (ef: external_function): match ef with | EF_external name sg => do_external_function name sg ge | EF_builtin name sg => do_external_function name sg ge + | EF_runtime name sg => do_external_function name sg ge | EF_vload chunk => do_ef_volatile_load chunk | EF_vstore chunk => do_ef_volatile_store chunk | EF_malloc => do_ef_malloc @@ -558,6 +559,8 @@ Proof with try congruence. eapply do_external_function_sound; eauto. (* EF_builtin *) eapply do_external_function_sound; eauto. +(* EF_runtime *) + eapply do_external_function_sound; eauto. (* EF_vload *) unfold do_ef_volatile_load. destruct vargs... destruct v... destruct vargs... mydestr. destruct p as [[w'' t''] v]; mydestr. @@ -604,6 +607,8 @@ Proof. eapply do_external_function_complete; eauto. (* EF_builtin *) eapply do_external_function_complete; eauto. +(* EF_runtime *) + eapply do_external_function_complete; eauto. (* EF_vload *) inv H; unfold do_ef_volatile_load. exploit do_volatile_load_complete; eauto. intros EQ; rewrite EQ; auto. diff --git a/cfrontend/Clight.v b/cfrontend/Clight.v index 086f4654..e6426fb8 100644 --- a/cfrontend/Clight.v +++ b/cfrontend/Clight.v @@ -146,9 +146,7 @@ Definition var_names (vars: list(ident * type)) : list ident := (** Functions can either be defined ([Internal]) or declared as external functions ([External]). *) -Inductive fundef : Type := - | Internal: function -> fundef - | External: external_function -> typelist -> type -> calling_convention -> fundef. +Definition fundef := Ctypes.fundef function. (** The type of a function definition. *) @@ -163,45 +161,16 @@ Definition type_of_fundef (f: fundef) : type := (** ** Programs *) -(** A program is composed of: +(** As defined in module [Ctypes], a program, or compilation unit, is + composed of: - a list of definitions of functions and global variables; - the names of functions and global variables that are public (not static); - the name of the function that acts as entry point ("main" function). -- a list of definitions for structure and union names; -- the corresponding composite environment; -*) - -Record program : Type := { - prog_defs: list (ident * globdef fundef type); - prog_public: list ident; - prog_main: ident; - prog_types: list composite_definition; - prog_comp_env: composite_env; - prog_comp_env_eq: build_composite_env prog_types = OK prog_comp_env -}. +- a list of definitions for structure and union names +- the corresponding composite environment +- a proof that this environment is consistent with the definitions. *) -Definition program_of_program (p: program) : AST.program fundef type := - {| AST.prog_defs := p.(prog_defs); - AST.prog_public := p.(prog_public); - AST.prog_main := p.(prog_main) |}. - -Coercion program_of_program: program >-> AST.program. - -Program Definition make_program (types: list composite_definition) - (defs: list (ident * globdef fundef type)) - (public: list ident) - (main: ident): res program := - match build_composite_env types with - | OK env => - OK {| prog_defs := defs; - prog_public := public; - prog_main := main; - prog_types := types; - prog_comp_env := env; - prog_comp_env_eq := _ |} - | Error msg => - Error msg - end. +Definition program := Ctypes.program function. (** * Operational semantics *) @@ -774,4 +743,3 @@ Proof. eapply external_call_trace_length; eauto. eapply external_call_trace_length; eauto. Qed. - diff --git a/cfrontend/Cminorgen.v b/cfrontend/Cminorgen.v index c2b59fbe..b9a28ee1 100644 --- a/cfrontend/Cminorgen.v +++ b/cfrontend/Cminorgen.v @@ -12,19 +12,10 @@ (** Translation from Csharpminor to Cminor. *) -Require Import FSets. -Require FSetAVL. -Require Import Orders. -Require Mergesort. -Require Import Coqlib. -Require Import Errors. -Require Import Maps. -Require Import Ordered. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Csharpminor. -Require Import Cminor. +Require Import FSets FSetAVL Orders Mergesort. +Require Import Coqlib Maps Ordered Errors Integers Floats. +Require Import AST Linking. +Require Import Csharpminor Cminor. Local Open Scope string_scope. Local Open Scope error_monad_scope. diff --git a/cfrontend/Cminorgenproof.v b/cfrontend/Cminorgenproof.v index 7a5d882e..2f551d68 100644 --- a/cfrontend/Cminorgenproof.v +++ b/cfrontend/Cminorgenproof.v @@ -12,61 +12,54 @@ (** Correctness proof for Cminor generation. *) -Require Import Coq.Program.Equality. -Require Import FSets. -Require Import Permutation. -Require Import Coqlib. +Require Import Coq.Program.Equality FSets Permutation. +Require Import FSets FSetAVL Orders Mergesort. +Require Import Coqlib Maps Ordered Errors Integers Floats. Require Intv. -Require Import Errors. -Require Import Maps. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import Memory. -Require Import Events. -Require Import Globalenvs. -Require Import Smallstep. -Require Import Switch. -Require Import Csharpminor. -Require Import Cminor. -Require Import Cminorgen. +Require Import AST Linking. +Require Import Values Memory Events Globalenvs Smallstep. +Require Import Csharpminor Switch Cminor Cminorgen. Open Local Scope error_monad_scope. +Definition match_prog (p: Csharpminor.program) (tp: Cminor.program) := + match_program (fun cu f tf => transl_fundef f = OK tf) eq p tp. + +Lemma transf_program_match: + forall p tp, transl_program p = OK tp -> match_prog p tp. +Proof. + intros. apply match_transform_partial_program; auto. +Qed. + Section TRANSLATION. Variable prog: Csharpminor.program. Variable tprog: program. -Hypothesis TRANSL: transl_program prog = OK tprog. +Hypothesis TRANSL: match_prog prog tprog. Let ge : Csharpminor.genv := Genv.globalenv prog. Let tge: genv := Genv.globalenv tprog. Lemma symbols_preserved: forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. -Proof (Genv.find_symbol_transf_partial transl_fundef _ TRANSL). +Proof (Genv.find_symbol_transf_partial TRANSL). -Lemma public_preserved: - forall (s: ident), Genv.public_symbol tge s = Genv.public_symbol ge s. -Proof (Genv.public_symbol_transf_partial transl_fundef _ TRANSL). +Lemma senv_preserved: + Senv.equiv ge tge. +Proof (Genv.senv_transf_partial TRANSL). Lemma function_ptr_translated: forall (b: block) (f: Csharpminor.fundef), 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_partial transl_fundef _ TRANSL). +Proof (Genv.find_funct_ptr_transf_partial 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 f = OK tf. -Proof (Genv.find_funct_transf_partial transl_fundef _ TRANSL). - -Lemma varinfo_preserved: - forall b, Genv.find_var_info tge b = Genv.find_var_info ge b. -Proof (Genv.find_var_info_transf_partial transl_fundef _ TRANSL). +Proof (Genv.find_funct_transf_partial TRANSL). Lemma sig_preserved_body: forall f tf cenv size, @@ -2029,8 +2022,7 @@ Proof. intros [f' [vres' [tm' [EC [VINJ [MINJ' [UNMAPPED [OUTOFREACH [INCR SEPARATED]]]]]]]]]. left; econstructor; split. apply plus_one. econstructor. eauto. - eapply external_call_symbols_preserved; eauto. - exact symbols_preserved. exact public_preserved. eexact varinfo_preserved. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. assert (MCS': match_callstack f' m' tm' (Frame cenv tfn e le te sp lo hi :: cs) (Mem.nextblock m') (Mem.nextblock tm')). @@ -2184,8 +2176,7 @@ Opaque PTree.set. intros [f' [vres' [tm' [EC [VINJ [MINJ' [UNMAPPED [OUTOFREACH [INCR SEPARATED]]]]]]]]]. left; econstructor; split. apply plus_one. econstructor. - eapply external_call_symbols_preserved; eauto. - exact symbols_preserved. exact public_preserved. eexact varinfo_preserved. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. econstructor; eauto. apply match_callstack_incr_bound with (Mem.nextblock m) (Mem.nextblock tm). eapply match_callstack_external_call; eauto. @@ -2224,11 +2215,11 @@ Proof. exploit function_ptr_translated; eauto. intros [tf [FIND TR]]. econstructor; split. econstructor. - apply (Genv.init_mem_transf_partial _ _ TRANSL). eauto. + apply (Genv.init_mem_transf_partial TRANSL). eauto. simpl. fold tge. rewrite symbols_preserved. replace (prog_main tprog) with (prog_main prog). eexact H0. symmetry. unfold transl_program in TRANSL. - eapply transform_partial_program_main; eauto. + eapply match_program_main; eauto. eexact FIND. rewrite <- H2. apply sig_preserved; auto. eapply match_callstate with (f := Mem.flat_inj (Mem.nextblock m0)) (cs := @nil frame) (cenv := PTree.empty Z). @@ -2250,7 +2241,7 @@ Theorem transl_program_correct: forward_simulation (Csharpminor.semantics prog) (Cminor.semantics tprog). Proof. eapply forward_simulation_star; eauto. - eexact public_preserved. + apply senv_preserved. eexact transl_initial_states. eexact transl_final_states. eexact transl_step_correct. diff --git a/cfrontend/Cshmgen.v b/cfrontend/Cshmgen.v index 825a563c..40b51bd3 100644 --- a/cfrontend/Cshmgen.v +++ b/cfrontend/Cshmgen.v @@ -20,17 +20,9 @@ Csharpminor's simpler control structures. *) -Require Import Coqlib. -Require Import Maps. -Require Import Errors. -Require Import Integers. -Require Import Floats. -Require Import AST. -Require Import Ctypes. -Require Import Cop. -Require Import Clight. -Require Import Cminor. -Require Import Csharpminor. +Require Import Coqlib Maps Errors Integers Floats. +Require Import AST Linking. +Require Import Ctypes Cop Clight Cminor Csharpminor. Open Local Scope string_scope. Open Local Scope error_monad_scope. @@ -125,6 +117,18 @@ Definition make_cmp_ne_zero (e: expr) := | _ => Ebinop (Ocmp Cne) e (make_intconst Int.zero) end. +(** Variants of [sizeof] and [alignof] that check that the given type is complete. *) + +Definition sizeof (ce: composite_env) (t: type) : res Z := + if complete_type ce t + then OK (Ctypes.sizeof ce t) + else Error (msg "incomplete type"). + +Definition alignof (ce: composite_env) (t: type) : res Z := + if complete_type ce t + then OK (Ctypes.alignof ce t) + else Error (msg "incomplete type"). + (** [make_cast from to e] applies to [e] the numeric conversions needed to transform a result of type [from] to a result of type [to]. *) @@ -238,16 +242,20 @@ Definition make_binarith (iop iopu fop sop lop lopu: binary_operation) Definition make_add (ce: composite_env) (e1: expr) (ty1: type) (e2: expr) (ty2: type) := match classify_add ty1 ty2 with | add_case_pi ty => - let n := make_intconst (Int.repr (Ctypes.sizeof ce ty)) in + do sz <- sizeof ce ty; + let n := make_intconst (Int.repr sz) in OK (Ebinop Oadd e1 (Ebinop Omul n e2)) | add_case_ip ty => - let n := make_intconst (Int.repr (Ctypes.sizeof ce ty)) in + do sz <- sizeof ce ty; + let n := make_intconst (Int.repr sz) in OK (Ebinop Oadd e2 (Ebinop Omul n e1)) | add_case_pl ty => - let n := make_intconst (Int.repr (Ctypes.sizeof ce ty)) in + do sz <- sizeof ce ty; + let n := make_intconst (Int.repr sz) in OK (Ebinop Oadd e1 (Ebinop Omul n (Eunop Ointoflong e2))) | add_case_lp ty => - let n := make_intconst (Int.repr (Ctypes.sizeof ce ty)) in + do sz <- sizeof ce ty; + let n := make_intconst (Int.repr sz) in OK (Ebinop Oadd e2 (Ebinop Omul n (Eunop Ointoflong e1))) | add_default => make_binarith Oadd Oadd Oaddf Oaddfs Oaddl Oaddl e1 ty1 e2 ty2 @@ -256,13 +264,16 @@ Definition make_add (ce: composite_env) (e1: expr) (ty1: type) (e2: expr) (ty2: Definition make_sub (ce: composite_env) (e1: expr) (ty1: type) (e2: expr) (ty2: type) := match classify_sub ty1 ty2 with | sub_case_pi ty => - let n := make_intconst (Int.repr (Ctypes.sizeof ce ty)) in + do sz <- sizeof ce ty; + let n := make_intconst (Int.repr sz) in OK (Ebinop Osub e1 (Ebinop Omul n e2)) | sub_case_pp ty => - let n := make_intconst (Int.repr (Ctypes.sizeof ce ty)) in + do sz <- sizeof ce ty; + let n := make_intconst (Int.repr sz) in OK (Ebinop Odiv (Ebinop Osub e1 e2) n) | sub_case_pl ty => - let n := make_intconst (Int.repr (Ctypes.sizeof ce ty)) in + do sz <- sizeof ce ty; + let n := make_intconst (Int.repr sz) in OK (Ebinop Osub e1 (Ebinop Omul n (Eunop Ointoflong e2))) | sub_default => make_binarith Osub Osub Osubf Osubfs Osubl Osubl e1 ty1 e2 ty2 @@ -351,8 +362,9 @@ Definition make_load (addr: expr) (ty_res: type) := by-copy assignment of a value of Clight type [ty]. *) Definition make_memcpy (ce: composite_env) (dst src: expr) (ty: type) := - Sbuiltin None (EF_memcpy (Ctypes.sizeof ce ty) (Ctypes.alignof_blockcopy ce ty)) - (dst :: src :: nil). + do sz <- sizeof ce ty; + OK (Sbuiltin None (EF_memcpy sz (Ctypes.alignof_blockcopy ce ty)) + (dst :: src :: nil)). (** [make_store addr ty rhs] stores the value of the Csharpminor expression [rhs] into the memory location denoted by the @@ -362,7 +374,7 @@ Definition make_memcpy (ce: composite_env) (dst src: expr) (ty: type) := Definition make_store (ce: composite_env) (addr: expr) (ty: type) (rhs: expr) := match access_mode ty with | By_value chunk => OK (Sstore chunk addr rhs) - | By_copy => OK (make_memcpy ce addr rhs ty) + | By_copy => make_memcpy ce addr rhs ty | _ => Error (msg "Cshmgen.make_store") end. @@ -457,9 +469,9 @@ Fixpoint transl_expr (ce: composite_env) (a: Clight.expr) {struct a} : res expr do addr <- make_field_access ce (typeof b) i tb; make_load addr ty | Clight.Esizeof ty' ty => - OK(make_intconst (Int.repr (sizeof ce ty'))) + do sz <- sizeof ce ty'; OK(make_intconst (Int.repr sz)) | Clight.Ealignof ty' ty => - OK(make_intconst (Int.repr (alignof ce ty'))) + do al <- alignof ce ty'; OK(make_intconst (Int.repr al)) end (** [transl_lvalue a] returns the Csharpminor code that evaluates @@ -621,7 +633,8 @@ with transl_lbl_stmt (ce: composite_env) (tyret: type) (nbrk ncnt: nat) (*** Translation of functions *) -Definition transl_var (ce: composite_env) (v: ident * type) := (fst v, sizeof ce (snd v)). +Definition transl_var (ce: composite_env) (v: ident * type) := + do sz <- sizeof ce (snd v); OK (fst v, sz). Definition signature_of_function (f: Clight.function) := {| sig_args := map typ_of_type (map snd (Clight.fn_params f)); @@ -630,18 +643,19 @@ Definition signature_of_function (f: Clight.function) := Definition transl_function (ce: composite_env) (f: Clight.function) : res function := do tbody <- transl_statement ce f.(Clight.fn_return) 1%nat 0%nat (Clight.fn_body f); + do tvars <- mmap (transl_var ce) (Clight.fn_vars f); OK (mkfunction (signature_of_function f) (map fst (Clight.fn_params f)) - (map (transl_var ce) (Clight.fn_vars f)) + tvars (map fst (Clight.fn_temps f)) tbody). -Definition transl_fundef (ce: composite_env) (f: Clight.fundef) : res fundef := +Definition transl_fundef (ce: composite_env) (id: ident) (f: Clight.fundef) : res fundef := match f with - | Clight.Internal g => + | Internal g => do tg <- transl_function ce g; OK(AST.Internal tg) - | Clight.External ef args res cconv => + | External ef args res cconv => if signature_eq (ef_sig ef) (signature_of_type args res cconv) then OK(AST.External ef) else Error(msg "Cshmgen.transl_fundef: wrong external signature") @@ -649,7 +663,7 @@ Definition transl_fundef (ce: composite_env) (f: Clight.fundef) : res fundef := (** ** Translation of programs *) -Definition transl_globvar (ty: type) := OK tt. +Definition transl_globvar (id: ident) (ty: type) := OK tt. Definition transl_program (p: Clight.program) : res program := transform_partial_program2 (transl_fundef p.(prog_comp_env)) transl_globvar p. diff --git a/cfrontend/Cshmgenproof.v b/cfrontend/Cshmgenproof.v index 4f067fad..8bc97b99 100644 --- a/cfrontend/Cshmgenproof.v +++ b/cfrontend/Cshmgenproof.v @@ -12,24 +12,40 @@ (** * Correctness of the translation from Clight to C#minor. *) -Require Import Coqlib. -Require Import Errors. -Require Import Maps. -Require Import Integers. -Require Import Floats. -Require Import AST. -Require Import Values. -Require Import Events. -Require Import Memory. -Require Import Globalenvs. -Require Import Smallstep. -Require Import Ctypes. -Require Import Cop. -Require Import Clight. -Require Import Cminor. -Require Import Csharpminor. +Require Import Coqlib Errors Maps Integers Floats. +Require Import AST Linking. +Require Import Values Events Memory Globalenvs Smallstep. +Require Import Ctypes Cop Clight Cminor Csharpminor. Require Import Cshmgen. +(** * Relational specification of the transformation *) + +Inductive match_fundef (p: Clight.program) : Clight.fundef -> Csharpminor.fundef -> Prop := + | match_fundef_internal: forall f tf, + transl_function p.(prog_comp_env) f = OK tf -> + match_fundef p (Ctypes.Internal f) (AST.Internal tf) + | match_fundef_external: forall ef args res cc, + ef_sig ef = signature_of_type args res cc -> + match_fundef p (Ctypes.External ef args res cc) (AST.External ef). + +Definition match_varinfo (v: type) (tv: unit) := True. + +Definition match_prog (p: Clight.program) (tp: Csharpminor.program) : Prop := + match_program_gen match_fundef match_varinfo p p tp. + +Lemma transf_program_match: + forall p tp, transl_program p = OK tp -> match_prog p tp. +Proof. + unfold transl_program; intros. + eapply match_transform_partial_program2. + eexact H. +- intros. destruct f; simpl in H0. ++ monadInv H0. constructor; auto. ++ destruct (signature_eq (ef_sig e) (signature_of_type t t0 c)); inv H0. + constructor; auto. +- intros; red; auto. +Qed. + (** * Properties of operations over types *) Remark transl_params_types: @@ -41,21 +57,20 @@ Qed. Lemma transl_fundef_sig1: forall ce f tf args res cc, - transl_fundef ce f = OK tf -> + match_fundef ce f tf -> classify_fun (type_of_fundef f) = fun_case_f args res cc -> funsig tf = signature_of_type args res cc. Proof. - intros. destruct f; simpl in *. - monadInv H. monadInv EQ. simpl. inversion H0. + intros. inv H. +- monadInv H1. simpl. inversion H0. unfold signature_of_function, signature_of_type. f_equal. apply transl_params_types. - destruct (signature_eq (ef_sig e) (signature_of_type t t0 c)); inv H. - simpl. congruence. +- simpl in H0. unfold funsig. congruence. Qed. Lemma transl_fundef_sig2: forall ce f tf args res cc, - transl_fundef ce f = OK tf -> + match_fundef ce f tf -> type_of_fundef f = Tfunction args res cc -> funsig tf = signature_of_type args res cc. Proof. @@ -63,15 +78,73 @@ Proof. rewrite H0; reflexivity. Qed. +Lemma transl_sizeof: + forall (cunit prog: Clight.program) t sz, + linkorder cunit prog -> + sizeof cunit.(prog_comp_env) t = OK sz -> + sz = Ctypes.sizeof prog.(prog_comp_env) t. +Proof. + intros. destruct H. + unfold sizeof in H0. destruct (complete_type (prog_comp_env cunit) t) eqn:C; inv H0. + symmetry. apply Ctypes.sizeof_stable; auto. +Qed. + +Lemma transl_alignof: + forall (cunit prog: Clight.program) t al, + linkorder cunit prog -> + alignof cunit.(prog_comp_env) t = OK al -> + al = Ctypes.alignof prog.(prog_comp_env) t. +Proof. + intros. destruct H. + unfold alignof in H0. destruct (complete_type (prog_comp_env cunit) t) eqn:C; inv H0. + symmetry. apply Ctypes.alignof_stable; auto. +Qed. + +Lemma transl_alignof_blockcopy: + forall (cunit prog: Clight.program) t sz, + linkorder cunit prog -> + sizeof cunit.(prog_comp_env) t = OK sz -> + sz = Ctypes.sizeof prog.(prog_comp_env) t /\ + alignof_blockcopy cunit.(prog_comp_env) t = alignof_blockcopy prog.(prog_comp_env) t. +Proof. + intros. destruct H. + unfold sizeof in H0. destruct (complete_type (prog_comp_env cunit) t) eqn:C; inv H0. + split. +- symmetry. apply Ctypes.sizeof_stable; auto. +- revert C. induction t; simpl; auto; + destruct (prog_comp_env cunit)!i as [co|] eqn:X; try discriminate; erewrite H1 by eauto; auto. +Qed. + +Lemma field_offset_stable: + forall (cunit prog: Clight.program) id co f, + linkorder cunit prog -> + cunit.(prog_comp_env)!id = Some co -> + prog.(prog_comp_env)!id = Some co /\ + field_offset prog.(prog_comp_env) f (co_members co) = field_offset cunit.(prog_comp_env) f (co_members co). +Proof. + intros. + assert (C: composite_consistent cunit.(prog_comp_env) co). + { apply build_composite_env_consistent with cunit.(prog_types) id; auto. + apply prog_comp_env_eq. } + destruct H as [_ A]. + split. auto. generalize (co_consistent_complete _ _ C). + unfold field_offset. generalize 0. induction (co_members co) as [ | [f1 t1] m]; simpl; intros. +- auto. +- InvBooleans. + rewrite ! (alignof_stable _ _ A) by auto. + rewrite ! (sizeof_stable _ _ A) by auto. + destruct (ident_eq f f1); eauto. +Qed. + (** * Properties of the translation functions *) (** Transformation of expressions and statements. *) Lemma transl_expr_lvalue: - forall ge e le m a loc ofs ta, + forall ge e le m a loc ofs ce ta, Clight.eval_lvalue ge e le m a loc ofs -> - transl_expr ge a = OK ta -> - (exists tb, transl_lvalue ge a = OK tb /\ make_load tb (typeof a) = OK ta). + transl_expr ce a = OK ta -> + (exists tb, transl_lvalue ce a = OK tb /\ make_load tb (typeof a) = OK ta). Proof. intros until ta; intros EVAL TR. inv EVAL; simpl in TR. (* var local *) @@ -140,7 +213,8 @@ Qed. Section CONSTRUCTORS. -Variable ce: composite_env. +Variables cunit prog: Clight.program. +Hypothesis LINK: linkorder cunit prog. Variable ge: genv. Lemma make_intconst_correct: @@ -487,27 +561,33 @@ End MAKE_BIN. Hint Extern 2 (@eq (option val) _ _) => (simpl; reflexivity) : cshm. -Lemma make_add_correct: binary_constructor_correct (make_add ce) (sem_add ce). +Lemma make_add_correct: binary_constructor_correct (make_add cunit.(prog_comp_env)) (sem_add prog.(prog_comp_env)). Proof. red; unfold make_add, sem_add; intros until m; intros SEM MAKE EV1 EV2; - destruct (classify_add tya tyb); inv MAKE. -- destruct va; try discriminate; destruct vb; inv SEM; eauto with cshm. -- destruct va; try discriminate; destruct vb; inv SEM; eauto with cshm. -- destruct va; try discriminate; destruct vb; inv SEM; eauto with cshm. -- destruct va; try discriminate; destruct vb; inv SEM; eauto with cshm. + destruct (classify_add tya tyb); try (monadInv MAKE). +- rewrite (transl_sizeof _ _ _ _ LINK EQ). + destruct va; try discriminate; destruct vb; inv SEM; eauto with cshm. +- rewrite (transl_sizeof _ _ _ _ LINK EQ). + destruct va; try discriminate; destruct vb; inv SEM; eauto with cshm. +- rewrite (transl_sizeof _ _ _ _ LINK EQ). + destruct va; try discriminate; destruct vb; inv SEM; eauto with cshm. +- rewrite (transl_sizeof _ _ _ _ LINK EQ). + destruct va; try discriminate; destruct vb; inv SEM; eauto with cshm. - eapply make_binarith_correct; eauto; intros; auto. Qed. -Lemma make_sub_correct: binary_constructor_correct (make_sub ce) (sem_sub ce). +Lemma make_sub_correct: binary_constructor_correct (make_sub cunit.(prog_comp_env)) (sem_sub prog.(prog_comp_env)). Proof. red; unfold make_sub, sem_sub; intros until m; intros SEM MAKE EV1 EV2; - destruct (classify_sub tya tyb); inv MAKE. -- destruct va; try discriminate; destruct vb; inv SEM; eauto with cshm. -- destruct va; try discriminate; destruct vb; inv SEM. + destruct (classify_sub tya tyb); try (monadInv MAKE). +- rewrite (transl_sizeof _ _ _ _ LINK EQ). + destruct va; try discriminate; destruct vb; inv SEM; eauto with cshm. +- rewrite (transl_sizeof _ _ _ _ LINK EQ). + destruct va; try discriminate; destruct vb; inv SEM. destruct (eq_block b0 b1); try discriminate. - set (sz := sizeof ce ty) in *. + set (sz := Ctypes.sizeof (prog_comp_env prog) ty) in *. destruct (zlt 0 sz); try discriminate. destruct (zle sz Int.max_signed); simpl in H0; inv H0. econstructor; eauto with cshm. @@ -519,7 +599,8 @@ Proof. predSpec Int.eq Int.eq_spec (Int.repr sz) Int.mone. rewrite H0 in E; rewrite Int.signed_mone in E; omegaContradiction. rewrite andb_false_r; auto. -- destruct va; try discriminate; destruct vb; inv SEM; eauto with cshm. +- rewrite (transl_sizeof _ _ _ _ LINK EQ). + destruct va; try discriminate; destruct vb; inv SEM; eauto with cshm. - eapply make_binarith_correct; eauto; intros; auto. Qed. @@ -673,8 +754,8 @@ Qed. Lemma transl_binop_correct: forall op a tya b tyb c va vb v e le m, - transl_binop ce op a tya b tyb = OK c -> - sem_binary_operation ce op va tya vb tyb m = Some v -> + transl_binop cunit.(prog_comp_env) op a tya b tyb = OK c -> + sem_binary_operation prog.(prog_comp_env) op va tya vb tyb m = Some v -> eval_expr ge e le m a va -> eval_expr ge e le m b vb -> eval_expr ge e le m c v. @@ -716,15 +797,18 @@ Proof. Qed. Lemma make_memcpy_correct: - forall ce f dst src ty k e le m b ofs v m', + forall f dst src ty k e le m b ofs v m' s, eval_expr ge e le m dst (Vptr b ofs) -> eval_expr ge e le m src v -> - assign_loc ce ty m b ofs v m' -> + assign_loc prog.(prog_comp_env) ty m b ofs v m' -> access_mode ty = By_copy -> - step ge (State f (make_memcpy ce dst src ty) k e le m) E0 (State f Sskip k e le m'). + make_memcpy cunit.(prog_comp_env) dst src ty = OK s -> + step ge (State f s k e le m) E0 (State f Sskip k e le m'). Proof. intros. inv H1; try congruence. - unfold make_memcpy. change le with (set_optvar None Vundef le) at 2. + monadInv H3. + exploit transl_alignof_blockcopy. eexact LINK. eauto. intros [A B]. rewrite A, B. + change le with (set_optvar None Vundef le) at 2. econstructor. econstructor. eauto. econstructor. eauto. constructor. econstructor; eauto. @@ -735,10 +819,10 @@ Qed. Lemma make_store_correct: forall addr ty rhs code e le m b ofs v m' f k, - make_store ce addr ty rhs = OK code -> + make_store cunit.(prog_comp_env) addr ty rhs = OK code -> eval_expr ge e le m addr (Vptr b ofs) -> eval_expr ge e le m rhs v -> - assign_loc ce ty m b ofs v m' -> + assign_loc prog.(prog_comp_env) ty m b ofs v m' -> step ge (State f code k e le m) E0 (State f Sskip k e le m'). Proof. unfold make_store. intros until k; intros MKSTORE EV1 EV2 ASSIGN. @@ -747,8 +831,8 @@ Proof. rewrite H in MKSTORE; inv MKSTORE. econstructor; eauto. (* by copy *) - rewrite H in MKSTORE; inv MKSTORE. - eapply make_memcpy_correct; eauto. + rewrite H in MKSTORE. + eapply make_memcpy_correct with (b := b) (v := Vptr b' ofs'); eauto. Qed. End CONSTRUCTORS. @@ -759,34 +843,30 @@ Section CORRECTNESS. Variable prog: Clight.program. Variable tprog: Csharpminor.program. -Hypothesis TRANSL: transl_program prog = OK tprog. +Hypothesis TRANSL: match_prog prog tprog. Let ge := globalenv prog. Let tge := Genv.globalenv tprog. Lemma symbols_preserved: forall s, Genv.find_symbol tge s = Genv.find_symbol ge s. -Proof (Genv.find_symbol_transf_partial2 (transl_fundef ge) transl_globvar _ TRANSL). +Proof (Genv.find_symbol_match TRANSL). + +Lemma senv_preserved: + Senv.equiv ge tge. +Proof (Genv.senv_match TRANSL). -Lemma public_preserved: - forall s, Genv.public_symbol tge s = Genv.public_symbol ge s. -Proof (Genv.public_symbol_transf_partial2 (transl_fundef ge) transl_globvar _ TRANSL). +Lemma function_ptr_translated: + forall v f, + Genv.find_funct_ptr ge v = Some f -> + exists cu tf, Genv.find_funct_ptr tge v = Some tf /\ match_fundef cu f tf /\ linkorder cu prog. +Proof (Genv.find_funct_ptr_match TRANSL). Lemma functions_translated: forall v f, Genv.find_funct ge v = Some f -> - exists tf, Genv.find_funct tge v = Some tf /\ transl_fundef ge f = OK tf. -Proof (Genv.find_funct_transf_partial2 (transl_fundef ge) 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 ge f = OK tf. -Proof (Genv.find_funct_ptr_transf_partial2 (transl_fundef ge) transl_globvar _ TRANSL). - -Lemma block_is_volatile_preserved: - forall b, Genv.block_is_volatile tge b = Genv.block_is_volatile ge b. -Proof (Genv.block_is_volatile_transf_partial2 (transl_fundef ge) transl_globvar _ TRANSL). + exists cu tf, Genv.find_funct tge v = Some tf /\ match_fundef cu f tf /\ linkorder cu prog. +Proof (Genv.find_funct_match TRANSL). (** * Matching between environments *) @@ -797,7 +877,7 @@ Record match_env (e: Clight.env) (te: Csharpminor.env) : Prop := mk_match_env { me_local: forall id b ty, - e!id = Some (b, ty) -> te!id = Some(b, sizeof ge ty); + e!id = Some (b, ty) -> te!id = Some(b, Ctypes.sizeof ge ty); me_local_inv: forall id b sz, te!id = Some (b, sz) -> exists ty, e!id = Some(b, ty) @@ -821,13 +901,13 @@ Proof. intros. set (R := fun (x: (block * type)) (y: (block * Z)) => match x, y with - | (b1, ty), (b2, sz) => b2 = b1 /\ sz = sizeof ge ty + | (b1, ty), (b2, sz) => b2 = b1 /\ sz = Ctypes.sizeof ge ty 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. exists (b, sizeof ge ty); split. eapply me_local; eauto. red; auto. + intros id [b ty] GET. exists (b, Ctypes.sizeof ge ty); split. eapply me_local; eauto. red; auto. intros id [b sz] GET. exploit me_local_inv; eauto. intros [ty EQ]. exploit me_local; eauto. intros EQ1. exists (b, ty); split. auto. red; split; congruence. @@ -863,17 +943,21 @@ Qed. local variables and initialization of the parameters. *) Lemma match_env_alloc_variables: - forall e1 m1 vars e2 m2, - Clight.alloc_variables ge e1 m1 vars e2 m2 -> - forall te1, + forall cunit, linkorder cunit prog -> + forall e1 m1 vars e2 m2, Clight.alloc_variables ge e1 m1 vars e2 m2 -> + forall tvars te1, + mmap (transl_var cunit.(prog_comp_env)) vars = OK tvars -> match_env e1 te1 -> exists te2, - Csharpminor.alloc_variables te1 m1 (map (transl_var ge) vars) te2 m2 + Csharpminor.alloc_variables te1 m1 tvars te2 m2 /\ match_env e2 te2. Proof. - induction 1; intros; simpl. - exists te1; split. constructor. auto. - exploit (IHalloc_variables (PTree.set id (b1, sizeof ge ty) te1)). + induction 2; simpl; intros. +- inv H0. exists te1; split. constructor. auto. +- monadInv H2. monadInv EQ. simpl in *. + exploit transl_sizeof. eexact H. eauto. intros SZ; rewrite SZ. + exploit (IHalloc_variables x0 (PTree.set id (b1, Ctypes.sizeof ge ty) te1)). + auto. constructor. (* me_local *) intros until ty0. repeat rewrite PTree.gsspec. @@ -903,6 +987,16 @@ Proof. destruct a as [id ty]. destruct vals; try discriminate. auto. Qed. +Lemma transl_vars_names: + forall ce vars tvars, + mmap (transl_var ce) vars = OK tvars -> + map fst tvars = var_names vars. +Proof. + intros. exploit mmap_inversion; eauto. generalize vars tvars. induction 1; simpl. +- auto. +- monadInv H0. simpl; congruence. +Qed. + (** * Proof of semantic preservation *) (** ** Semantic preservation for expressions *) @@ -929,6 +1023,8 @@ Qed. Section EXPR. +Variable cunit: Clight.program. +Hypothesis LINK: linkorder cunit prog. Variable e: Clight.env. Variable le: temp_env. Variable m: mem. @@ -938,11 +1034,11 @@ Hypothesis MENV: match_env e te. Lemma transl_expr_lvalue_correct: (forall a v, Clight.eval_expr ge e le m a v -> - forall ta (TR: transl_expr ge a = OK ta) , + forall ta (TR: transl_expr cunit.(prog_comp_env) a = OK ta) , Csharpminor.eval_expr tge te le m ta v) /\(forall a b ofs, Clight.eval_lvalue ge e le m a b ofs -> - forall ta (TR: transl_lvalue ge a = OK ta), + forall ta (TR: transl_lvalue cunit.(prog_comp_env) a = OK ta), Csharpminor.eval_expr tge te le m ta (Vptr b ofs)). Proof. apply eval_expr_lvalue_ind; intros; try (monadInv TR). @@ -965,9 +1061,9 @@ Proof. (* cast *) eapply make_cast_correct; eauto. (* sizeof *) - apply make_intconst_correct. + rewrite (transl_sizeof _ _ _ _ LINK EQ). apply make_intconst_correct. (* alignof *) - apply make_intconst_correct. + rewrite (transl_alignof _ _ _ _ LINK EQ). apply make_intconst_correct. (* rvalue out of lvalue *) exploit transl_expr_lvalue; eauto. intros [tb [TRLVAL MKLOAD]]. eapply make_load_correct; eauto. @@ -981,11 +1077,13 @@ Proof. (* deref *) simpl in TR. eauto. (* field struct *) - change (prog_comp_env prog) with (genv_cenv ge) in EQ0. - unfold make_field_access in EQ0; rewrite H1, H2 in EQ0; monadInv EQ0. + unfold make_field_access in EQ0. rewrite H1 in EQ0. + destruct (prog_comp_env cunit)!id as [co'|] eqn:CO; monadInv EQ0. + exploit field_offset_stable. eexact LINK. eauto. instantiate (1 := i). intros [A B]. + rewrite <- B in EQ1. eapply eval_Ebinop; eauto. apply make_intconst_correct. - simpl. congruence. + simpl. unfold ge in *; simpl in *. congruence. (* field union *) unfold make_field_access in EQ0; rewrite H1 in EQ0; monadInv EQ0. auto. @@ -994,21 +1092,21 @@ Qed. Lemma transl_expr_correct: forall a v, Clight.eval_expr ge e le m a v -> - forall ta, transl_expr ge a = OK ta -> + forall ta, transl_expr cunit.(prog_comp_env) a = OK ta -> Csharpminor.eval_expr tge te le m ta v. Proof (proj1 transl_expr_lvalue_correct). Lemma transl_lvalue_correct: forall a b ofs, Clight.eval_lvalue ge e le m a b ofs -> - forall ta, transl_lvalue ge a = OK ta -> + forall ta, transl_lvalue cunit.(prog_comp_env) a = OK ta -> Csharpminor.eval_expr tge te le m ta (Vptr b ofs). Proof (proj2 transl_expr_lvalue_correct). Lemma transl_arglist_correct: forall al tyl vl, Clight.eval_exprlist ge e le m al tyl vl -> - forall tal, transl_arglist ge al tyl = OK tal -> + forall tal, transl_arglist cunit.(prog_comp_env) al tyl = OK tal -> Csharpminor.eval_exprlist tge te le m tal vl. Proof. induction 1; intros. @@ -1062,71 +1160,75 @@ Proof. apply star_refl. Qed. -Inductive match_cont: type -> nat -> nat -> Clight.cont -> Csharpminor.cont -> Prop := - | match_Kstop: forall tyret nbrk ncnt, - match_cont tyret nbrk ncnt Clight.Kstop Kstop - | match_Kseq: forall tyret nbrk ncnt s k ts tk, - transl_statement ge tyret nbrk ncnt s = OK ts -> - match_cont tyret nbrk ncnt k tk -> - match_cont tyret nbrk ncnt +Inductive match_cont: composite_env -> type -> nat -> nat -> Clight.cont -> Csharpminor.cont -> Prop := + | match_Kstop: forall ce tyret nbrk ncnt, + match_cont tyret ce nbrk ncnt Clight.Kstop Kstop + | match_Kseq: forall ce tyret nbrk ncnt s k ts tk, + transl_statement ce tyret nbrk ncnt s = OK ts -> + match_cont ce tyret nbrk ncnt k tk -> + match_cont ce tyret nbrk ncnt (Clight.Kseq s k) (Kseq ts tk) - | match_Kloop1: forall tyret s1 s2 k ts1 ts2 nbrk ncnt tk, - transl_statement ge tyret 1%nat 0%nat s1 = OK ts1 -> - transl_statement ge tyret 0%nat (S ncnt) s2 = OK ts2 -> - match_cont tyret nbrk ncnt k tk -> - match_cont tyret 1%nat 0%nat + | match_Kloop1: forall ce tyret s1 s2 k ts1 ts2 nbrk ncnt tk, + transl_statement ce tyret 1%nat 0%nat s1 = OK ts1 -> + transl_statement ce tyret 0%nat (S ncnt) s2 = OK ts2 -> + match_cont ce tyret nbrk ncnt k tk -> + match_cont ce tyret 1%nat 0%nat (Clight.Kloop1 s1 s2 k) (Kblock (Kseq ts2 (Kseq (Sloop (Sseq (Sblock ts1) ts2)) (Kblock tk)))) - | match_Kloop2: forall tyret s1 s2 k ts1 ts2 nbrk ncnt tk, - transl_statement ge tyret 1%nat 0%nat s1 = OK ts1 -> - transl_statement ge tyret 0%nat (S ncnt) s2 = OK ts2 -> - match_cont tyret nbrk ncnt k tk -> - match_cont tyret 0%nat (S ncnt) + | match_Kloop2: forall ce tyret s1 s2 k ts1 ts2 nbrk ncnt tk, + transl_statement ce tyret 1%nat 0%nat s1 = OK ts1 -> + transl_statement ce tyret 0%nat (S ncnt) s2 = OK ts2 -> + match_cont ce tyret nbrk ncnt k tk -> + match_cont ce tyret 0%nat (S ncnt) (Clight.Kloop2 s1 s2 k) (Kseq (Sloop (Sseq (Sblock ts1) ts2)) (Kblock tk)) - | match_Kswitch: forall tyret nbrk ncnt k tk, - match_cont tyret nbrk ncnt k tk -> - match_cont tyret 0%nat (S ncnt) + | match_Kswitch: forall ce tyret nbrk ncnt k tk, + match_cont ce tyret nbrk ncnt k tk -> + match_cont ce tyret 0%nat (S ncnt) (Clight.Kswitch k) (Kblock tk) - | match_Kcall_some: forall tyret nbrk ncnt nbrk' ncnt' f e k id tf te le tk, - transl_function ge f = OK tf -> + | match_Kcall: forall ce tyret nbrk ncnt nbrk' ncnt' f e k id tf te le tk cu, + linkorder cu prog -> + transl_function cu.(prog_comp_env) f = OK tf -> match_env e te -> - match_cont (Clight.fn_return f) nbrk' ncnt' k tk -> - match_cont tyret nbrk ncnt + match_cont cu.(prog_comp_env) (Clight.fn_return f) nbrk' ncnt' k tk -> + match_cont ce tyret nbrk ncnt (Clight.Kcall id f e le k) (Kcall id tf te le tk). Inductive match_states: Clight.state -> Csharpminor.state -> Prop := | match_state: - forall f nbrk ncnt s k e le m tf ts tk te ts' tk' - (TRF: transl_function ge f = OK tf) - (TR: transl_statement ge (Clight.fn_return f) nbrk ncnt s = OK ts) + forall f nbrk ncnt s k e le m tf ts tk te ts' tk' cu + (LINK: linkorder cu prog) + (TRF: transl_function cu.(prog_comp_env) f = OK tf) + (TR: transl_statement cu.(prog_comp_env) (Clight.fn_return f) nbrk ncnt s = OK ts) (MTR: match_transl ts tk ts' tk') (MENV: match_env e te) - (MK: match_cont (Clight.fn_return f) nbrk ncnt k tk), + (MK: match_cont cu.(prog_comp_env) (Clight.fn_return f) nbrk ncnt k tk), match_states (Clight.State f s k e le m) (State tf ts' tk' te le m) | match_callstate: - forall fd args k m tfd tk targs tres cconv - (TR: transl_fundef ge fd = OK tfd) - (MK: match_cont Tvoid 0%nat 0%nat k tk) + forall fd args k m tfd tk targs tres cconv cu ce + (LINK: linkorder cu prog) + (TR: match_fundef cu fd tfd) + (MK: match_cont ce Tvoid 0%nat 0%nat k tk) (ISCC: Clight.is_call_cont k) (TY: type_of_fundef fd = Tfunction targs tres cconv), match_states (Clight.Callstate fd args k m) (Callstate tfd args tk m) | match_returnstate: - forall res k m tk - (MK: match_cont Tvoid 0%nat 0%nat k tk), + forall res k m tk ce + (MK: match_cont ce Tvoid 0%nat 0%nat k tk), match_states (Clight.Returnstate res k m) (Returnstate res tk m). Remark match_states_skip: - forall f e le te nbrk ncnt k tf tk m, - transl_function ge f = OK tf -> + forall f e le te nbrk ncnt k tf tk m cu, + linkorder cu prog -> + transl_function cu.(prog_comp_env) f = OK tf -> match_env e te -> - match_cont (Clight.fn_return f) nbrk ncnt k tk -> + match_cont cu.(prog_comp_env) (Clight.fn_return f) nbrk ncnt k tk -> match_states (Clight.State f Clight.Sskip k e le m) (State tf Sskip tk te le m). Proof. intros. econstructor; eauto. simpl; reflexivity. constructor. @@ -1135,89 +1237,90 @@ Qed. (** Commutation between label resolution and compilation *) Section FIND_LABEL. +Variable ce: composite_env. Variable lbl: label. Variable tyret: type. Lemma transl_find_label: forall s nbrk ncnt k ts tk - (TR: transl_statement ge tyret nbrk ncnt s = OK ts) - (MC: match_cont tyret nbrk ncnt k tk), + (TR: transl_statement ce tyret nbrk ncnt s = OK ts) + (MC: match_cont ce tyret nbrk ncnt k tk), match Clight.find_label lbl s k with | None => find_label lbl ts tk = None | Some (s', k') => exists ts', exists tk', exists nbrk', exists ncnt', find_label lbl ts tk = Some (ts', tk') - /\ transl_statement ge tyret nbrk' ncnt' s' = OK ts' - /\ match_cont tyret nbrk' ncnt' k' tk' + /\ transl_statement ce tyret nbrk' ncnt' s' = OK ts' + /\ match_cont ce tyret nbrk' ncnt' k' tk' end with transl_find_label_ls: forall ls nbrk ncnt k tls tk - (TR: transl_lbl_stmt ge tyret nbrk ncnt ls = OK tls) - (MC: match_cont tyret nbrk ncnt k tk), + (TR: transl_lbl_stmt ce tyret nbrk ncnt ls = OK tls) + (MC: match_cont ce tyret nbrk ncnt k tk), match Clight.find_label_ls lbl ls k with | None => find_label_ls lbl tls tk = None | Some (s', k') => exists ts', exists tk', exists nbrk', exists ncnt', find_label_ls lbl tls tk = Some (ts', tk') - /\ transl_statement ge tyret nbrk' ncnt' s' = OK ts' - /\ match_cont tyret nbrk' ncnt' k' tk' + /\ transl_statement ce tyret nbrk' ncnt' s' = OK ts' + /\ match_cont ce tyret nbrk' ncnt' k' tk' end. Proof. - intro s; case s; intros; try (monadInv TR); simpl. -(* skip *) +* intro s; case s; intros; try (monadInv TR); simpl. +- (* skip *) auto. -(* assign *) +- (* assign *) unfold make_store, make_memcpy in EQ3. - destruct (access_mode (typeof e)); inv EQ3; auto. -(* set *) + destruct (access_mode (typeof e)); monadInv EQ3; auto. +- (* set *) auto. -(* call *) +- (* call *) simpl in TR. destruct (classify_fun (typeof e)); monadInv TR. auto. -(* builtin *) +- (* builtin *) auto. -(* seq *) +- (* seq *) exploit (transl_find_label s0 nbrk ncnt (Clight.Kseq s1 k)); eauto. constructor; eauto. destruct (Clight.find_label lbl s0 (Clight.Kseq s1 k)) as [[s' k'] | ]. intros [ts' [tk' [nbrk' [ncnt' [A [B C]]]]]]. rewrite A. exists ts'; exists tk'; exists nbrk'; exists ncnt'; auto. intro. rewrite H. eapply transl_find_label; eauto. -(* ifthenelse *) +- (* ifthenelse *) exploit (transl_find_label s0); eauto. destruct (Clight.find_label lbl s0 k) as [[s' k'] | ]. intros [ts' [tk' [nbrk' [ncnt' [A [B C]]]]]]. rewrite A. exists ts'; exists tk'; exists nbrk'; exists ncnt'; auto. intro. rewrite H. eapply transl_find_label; eauto. -(* loop *) +- (* loop *) exploit (transl_find_label s0 1%nat 0%nat (Kloop1 s0 s1 k)); eauto. econstructor; eauto. destruct (Clight.find_label lbl s0 (Kloop1 s0 s1 k)) as [[s' k'] | ]. intros [ts' [tk' [nbrk' [ncnt' [A [B C]]]]]]. rewrite A. exists ts'; exists tk'; exists nbrk'; exists ncnt'; auto. intro. rewrite H. eapply transl_find_label; eauto. econstructor; eauto. -(* break *) +- (* break *) auto. -(* continue *) +- (* continue *) auto. -(* return *) +- (* return *) simpl in TR. destruct o; monadInv TR. auto. auto. -(* switch *) +- (* switch *) assert (exists b, ts = Sblock (Sswitch b x x0)). { destruct (classify_switch (typeof e)); inv EQ2; econstructor; eauto. } destruct H as [b EQ3]; rewrite EQ3; simpl. eapply transl_find_label_ls with (k := Clight.Kswitch k); eauto. econstructor; eauto. -(* label *) +- (* label *) destruct (ident_eq lbl l). exists x; exists tk; exists nbrk; exists ncnt; auto. eapply transl_find_label; eauto. -(* goto *) +- (* goto *) auto. - intro ls; case ls; intros; monadInv TR; simpl. -(* nil *) +* intro ls; case ls; intros; monadInv TR; simpl. +- (* nil *) auto. -(* cons *) +- (* cons *) exploit (transl_find_label s nbrk ncnt (Clight.Kseq (seq_of_labeled_statement l) k)); eauto. econstructor; eauto. apply transl_lbl_stmt_2; eauto. destruct (Clight.find_label lbl s (Clight.Kseq (seq_of_labeled_statement l) k)) as [[s' k'] | ]. @@ -1232,9 +1335,9 @@ End FIND_LABEL. (** Properties of call continuations *) Lemma match_cont_call_cont: - forall tyret' nbrk' ncnt' tyret nbrk ncnt k tk, - match_cont tyret nbrk ncnt k tk -> - match_cont tyret' nbrk' ncnt' (Clight.call_cont k) (call_cont tk). + forall ce' tyret' nbrk' ncnt' ce tyret nbrk ncnt k tk, + match_cont ce tyret nbrk ncnt k tk -> + match_cont ce' tyret' nbrk' ncnt' (Clight.call_cont k) (call_cont tk). Proof. induction 1; simpl; auto. constructor. @@ -1242,10 +1345,10 @@ Proof. Qed. Lemma match_cont_is_call_cont: - forall tyret nbrk ncnt k tk tyret' nbrk' ncnt', - match_cont tyret nbrk ncnt k tk -> + forall ce tyret nbrk ncnt k tk ce' tyret' nbrk' ncnt', + match_cont ce tyret nbrk ncnt k tk -> Clight.is_call_cont k -> - match_cont tyret' nbrk' ncnt' k tk /\ is_call_cont tk. + match_cont ce' tyret' nbrk' ncnt' k tk /\ is_call_cont tk. Proof. intros. inv H; simpl in H0; try contradiction; simpl. split; auto; constructor. @@ -1261,11 +1364,12 @@ Lemma transl_step: Proof. induction 1; intros T1 MST; inv MST. -(* assign *) +- (* assign *) monadInv TR. assert (SAME: ts' = ts /\ tk' = tk). - inversion MTR. auto. - subst ts. unfold make_store, make_memcpy in EQ3. destruct (access_mode (typeof a1)); congruence. + { inversion MTR. auto. + subst ts. unfold make_store, make_memcpy in EQ3. + destruct (access_mode (typeof a1)); monadInv EQ3; auto. } destruct SAME; subst ts' tk'. econstructor; split. apply plus_one. eapply make_store_correct; eauto. @@ -1273,62 +1377,61 @@ Proof. eapply transl_expr_correct; eauto. eapply match_states_skip; eauto. -(* set *) +- (* set *) monadInv TR. inv MTR. econstructor; split. apply plus_one. econstructor. eapply transl_expr_correct; eauto. eapply match_states_skip; eauto. -(* call *) +- (* call *) revert TR. simpl. case_eq (classify_fun (typeof a)); try congruence. intros targs tres cc CF TR. monadInv TR. inv MTR. - exploit functions_translated; eauto. intros [tfd [FIND TFD]]. + exploit functions_translated; eauto. intros (cu' & tfd & FIND & TFD & LINK'). rewrite H in CF. simpl in CF. inv CF. econstructor; split. apply plus_one. econstructor; eauto. - exploit transl_expr_correct; eauto. - exploit transl_arglist_correct; eauto. + eapply transl_expr_correct with (cunit := cu); eauto. + eapply transl_arglist_correct with (cunit := cu); eauto. erewrite typlist_of_arglist_eq by eauto. eapply transl_fundef_sig1; eauto. rewrite H3. auto. econstructor; eauto. - econstructor; eauto. + eapply match_Kcall with (ce := prog_comp_env cu') (cu := cu); eauto. simpl. auto. -(* builtin *) +- (* builtin *) monadInv TR. inv MTR. econstructor; split. apply plus_one. econstructor. eapply transl_arglist_correct; eauto. - eapply external_call_symbols_preserved_gen with (ge1 := ge). - exact symbols_preserved. exact public_preserved. exact block_is_volatile_preserved. eauto. + eapply external_call_symbols_preserved with (ge1 := ge). apply senv_preserved. eauto. eapply match_states_skip; eauto. -(* seq *) +- (* seq *) monadInv TR. inv MTR. econstructor; split. apply plus_one. constructor. econstructor; eauto. constructor. econstructor; eauto. -(* skip seq *) +- (* skip seq *) monadInv TR. inv MTR. inv MK. econstructor; split. apply plus_one. apply step_skip_seq. econstructor; eauto. constructor. -(* continue seq *) +- (* continue seq *) monadInv TR. inv MTR. inv MK. econstructor; split. apply plus_one. constructor. econstructor; eauto. simpl. reflexivity. constructor. -(* break seq *) +- (* break seq *) monadInv TR. inv MTR. inv MK. econstructor; split. apply plus_one. constructor. econstructor; eauto. simpl. reflexivity. constructor. -(* ifthenelse *) +- (* ifthenelse *) monadInv TR. inv MTR. exploit make_boolean_correct; eauto. exploit transl_expr_correct; eauto. @@ -1337,7 +1440,7 @@ Proof. apply plus_one. apply step_ifthenelse with (v := v) (b := b); auto. destruct b; econstructor; eauto; constructor. -(* loop *) +- (* loop *) monadInv TR. econstructor; split. eapply star_plus_trans. eapply match_transl_step; eauto. @@ -1347,9 +1450,9 @@ Proof. reflexivity. reflexivity. traceEq. econstructor; eauto. constructor. econstructor; eauto. -(* skip-or-continue loop *) +- (* skip-or-continue loop *) assert ((ts' = Sskip \/ ts' = Sexit ncnt) /\ tk' = tk). - destruct H; subst x; monadInv TR; inv MTR; auto. + { destruct H; subst x; monadInv TR; inv MTR; auto. } destruct H0. inv MK. econstructor; split. eapply plus_left. @@ -1357,7 +1460,7 @@ Proof. apply star_one. constructor. traceEq. econstructor; eauto. constructor. econstructor; eauto. -(* break loop1 *) +- (* break loop1 *) monadInv TR. inv MTR. inv MK. econstructor; split. eapply plus_left. constructor. @@ -1367,16 +1470,15 @@ Proof. reflexivity. reflexivity. traceEq. eapply match_states_skip; eauto. -(* skip loop2 *) +- (* skip loop2 *) monadInv TR. inv MTR. inv MK. econstructor; split. apply plus_one. constructor. econstructor; eauto. -Local Opaque ge. - simpl. rewrite H5; simpl. rewrite H7; simpl. eauto. + simpl. rewrite H6; simpl. rewrite H8; simpl. eauto. constructor. -(* break loop2 *) +- (* break loop2 *) monadInv TR. inv MTR. inv MK. econstructor; split. eapply plus_left. constructor. @@ -1384,32 +1486,32 @@ Local Opaque ge. traceEq. eapply match_states_skip; eauto. -(* return none *) +- (* return none *) monadInv TR. inv MTR. econstructor; split. apply plus_one. constructor. eapply match_env_free_blocks; eauto. - econstructor; eauto. + eapply match_returnstate with (ce := prog_comp_env cu); eauto. eapply match_cont_call_cont. eauto. -(* return some *) +- (* return some *) monadInv TR. inv MTR. econstructor; split. apply plus_one. constructor. eapply make_cast_correct; eauto. eapply transl_expr_correct; eauto. eapply match_env_free_blocks; eauto. - econstructor; eauto. + eapply match_returnstate with (ce := prog_comp_env cu); eauto. eapply match_cont_call_cont. eauto. -(* skip call *) +- (* skip call *) monadInv TR. inv MTR. exploit match_cont_is_call_cont; eauto. intros [A B]. econstructor; split. apply plus_one. apply step_skip_call. auto. eapply match_env_free_blocks; eauto. - constructor. eauto. + eapply match_returnstate with (ce := prog_comp_env cu); eauto. -(* switch *) +- (* switch *) monadInv TR. assert (E: exists b, ts = Sblock (Sswitch b x x0) /\ Switch.switch_argument b v n). { unfold sem_switch_arg in H0. @@ -1425,7 +1527,7 @@ Local Opaque ge. constructor. econstructor. eauto. -(* skip or break switch *) +- (* skip or break switch *) assert ((ts' = Sskip \/ ts' = Sexit nbrk) /\ tk' = tk). destruct H; subst x; monadInv TR; inv MTR; auto. destruct H0. inv MK. @@ -1433,57 +1535,54 @@ Local Opaque ge. apply plus_one. destruct H0; subst ts'. 2:constructor. constructor. eapply match_states_skip; eauto. - -(* continue switch *) +- (* continue switch *) monadInv TR. inv MTR. inv MK. econstructor; split. apply plus_one. constructor. econstructor; eauto. simpl. reflexivity. constructor. -(* label *) +- (* label *) monadInv TR. inv MTR. econstructor; split. apply plus_one. constructor. econstructor; eauto. constructor. -(* goto *) +- (* goto *) monadInv TR. inv MTR. generalize TRF. unfold transl_function. intro TRF'. monadInv TRF'. - exploit (transl_find_label lbl). eexact EQ. eapply match_cont_call_cont. eauto. + exploit (transl_find_label (prog_comp_env cu) lbl). eexact EQ. eapply match_cont_call_cont. eauto. rewrite H. intros [ts' [tk'' [nbrk' [ncnt' [A [B C]]]]]]. econstructor; split. apply plus_one. constructor. simpl. eexact A. econstructor; eauto. constructor. -(* internal function *) - inv H. monadInv TR. monadInv EQ. +- (* internal function *) + inv H. inv TR. monadInv H5. exploit match_cont_is_call_cont; eauto. intros [A B]. exploit match_env_alloc_variables; eauto. apply match_env_empty. intros [te1 [C D]]. econstructor; split. apply plus_one. eapply step_internal_function. - simpl. rewrite list_map_compose. simpl. assumption. - simpl. auto. - simpl. auto. - simpl. eauto. + simpl. erewrite transl_vars_names by eauto. assumption. + simpl. assumption. + simpl. assumption. + simpl; eauto. simpl. rewrite create_undef_temps_match. eapply bind_parameter_temps_match; eauto. simpl. econstructor; eauto. - unfold transl_function. rewrite EQ0; simpl. auto. + unfold transl_function. rewrite EQ; simpl. rewrite EQ1; simpl. auto. constructor. -(* external function *) - simpl in TR. - destruct (signature_eq (ef_sig ef) (signature_of_type targs tres cconv)); inv TR. +- (* external function *) + inv TR. exploit match_cont_is_call_cont; eauto. intros [A B]. econstructor; split. apply plus_one. constructor. eauto. - eapply external_call_symbols_preserved_gen with (ge1 := ge). - exact symbols_preserved. exact public_preserved. exact block_is_volatile_preserved. eauto. - econstructor; eauto. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. + eapply match_returnstate with (ce := ce); eauto. -(* returnstate *) +- (* returnstate *) inv MK. econstructor; split. apply plus_one. constructor. @@ -1495,17 +1594,14 @@ Lemma transl_initial_states: exists R, initial_state tprog R /\ match_states S R. Proof. intros. inv H. - exploit function_ptr_translated; eauto. intros [tf [A B]]. - assert (C: Genv.find_symbol tge (AST.prog_main tprog) = Some b). - rewrite symbols_preserved. replace (AST.prog_main tprog) with (prog_main prog). - auto. symmetry. unfold transl_program in TRANSL. - change (prog_main prog) with (AST.prog_main (program_of_program prog)). - eapply transform_partial_program2_main; eauto. - assert (funsig tf = signature_of_type Tnil type_int32s cc_default). - eapply transl_fundef_sig2; eauto. + exploit function_ptr_translated; eauto. intros (cu & tf & A & B & C). + assert (D: Genv.find_symbol tge (AST.prog_main tprog) = Some b). + { destruct TRANSL as (P & Q & R). rewrite Q. rewrite symbols_preserved. auto. } + assert (E: funsig tf = signature_of_type Tnil type_int32s cc_default). + { eapply transl_fundef_sig2; eauto. } econstructor; split. - econstructor; eauto. eapply Genv.init_mem_transf_partial2; eauto. - econstructor; eauto. constructor; auto. exact I. + econstructor; eauto. apply (Genv.init_mem_match TRANSL). eauto. + econstructor; eauto. instantiate (1 := prog_comp_env cu). constructor; auto. exact I. Qed. Lemma transl_final_states: @@ -1519,10 +1615,40 @@ Theorem transl_program_correct: forward_simulation (Clight.semantics2 prog) (Csharpminor.semantics tprog). Proof. eapply forward_simulation_plus. - eexact public_preserved. + apply senv_preserved. eexact transl_initial_states. eexact transl_final_states. eexact transl_step. Qed. End CORRECTNESS. + +(** ** Commutation with linking *) + +Instance TransfCshmgenLink : TransfLink match_prog. +Proof. + red; intros. destruct (link_linkorder _ _ _ H) as (LO1 & LO2). + generalize H. +Local Transparent Ctypes.Linker_program. + simpl; unfold link_program. + destruct (link (program_of_program p1) (program_of_program p2)) as [pp|] eqn:LP; try discriminate. + destruct (lift_option (link (prog_types p1) (prog_types p2))) as [[typs EQ]|P]; try discriminate. + destruct (link_build_composite_env (prog_types p1) (prog_types p2) typs + (prog_comp_env p1) (prog_comp_env p2) (prog_comp_env_eq p1) + (prog_comp_env_eq p2) EQ) as (env & P & Q). + intros E. + eapply Linking.link_match_program; eauto. +- intros. +Local Transparent Linker_fundef Linking.Linker_fundef. + inv H3; inv H4; simpl in H2. ++ discriminate. ++ destruct ef; inv H2. econstructor; split. simpl; eauto. left; constructor; auto. ++ destruct ef; inv H2. econstructor; split. simpl; eauto. right; constructor; auto. ++ destruct (external_function_eq ef ef0 && typelist_eq args args0 && + type_eq res res0 && calling_convention_eq cc cc0) eqn:E'; inv H2. + InvBooleans. subst ef0. econstructor; split. + simpl; rewrite dec_eq_true; eauto. + left; constructor. congruence. +- intros. exists tt. auto. +- replace (program_of_program p) with pp. auto. inv E; destruct pp; auto. +Qed. diff --git a/cfrontend/Csyntax.v b/cfrontend/Csyntax.v index 89d0b2bf..fd7a6b96 100644 --- a/cfrontend/Csyntax.v +++ b/cfrontend/Csyntax.v @@ -15,14 +15,9 @@ (** Abstract syntax for the Compcert C language *) -Require Import Coqlib. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import AST. -Require Import Errors. -Require Import Ctypes. -Require Import Cop. +Require Import Coqlib Maps Integers Floats Errors. +Require Import AST Linking Values. +Require Import Ctypes Cop. (** ** Expressions *) @@ -191,9 +186,7 @@ Definition var_names (vars: list(ident * type)) : list ident := (** Functions can either be defined ([Internal]) or declared as external functions ([External]). *) -Inductive fundef : Type := - | Internal: function -> fundef - | External: external_function -> typelist -> type -> calling_convention -> fundef. +Definition fundef := Ctypes.fundef function. (** The type of a function definition. *) @@ -206,50 +199,15 @@ Definition type_of_fundef (f: fundef) : type := | External id args res cc => Tfunction args res cc end. -(** ** Programs *) +(** ** Programs and compilation units *) -(** A "pre-program", as produced by the elaborator is composed of: +(** As defined in module [Ctypes], a program, or compilation unit, is + composed of: - a list of definitions of functions and global variables; - the names of functions and global variables that are public (not static); - the name of the function that acts as entry point ("main" function). - a list of definitions for structure and union names +- the corresponding composite environment +- a proof that this environment is consistent with the definitions. *) -A program is composed of the same information, plus the corresponding -composite environment, and a proof that this environment is consistent -with the composite definitions. *) - -Record pre_program : Type := { - pprog_defs: list (ident * globdef fundef type); - pprog_public: list ident; - pprog_main: ident; - pprog_types: list composite_definition -}. - -Record program : Type := { - prog_defs: list (ident * globdef fundef type); - prog_public: list ident; - prog_main: ident; - prog_types: list composite_definition; - prog_comp_env: composite_env; - prog_comp_env_eq: build_composite_env prog_types = OK prog_comp_env -}. - -Definition program_of_program (p: program) : AST.program fundef type := - {| AST.prog_defs := p.(prog_defs); - AST.prog_public := p.(prog_public); - AST.prog_main := p.(prog_main) |}. - -Coercion program_of_program: program >-> AST.program. - -Program Definition program_of_pre_program (p: pre_program) : res program := - match build_composite_env p.(pprog_types) with - | Error e => Error e - | OK ce => - OK {| prog_defs := p.(pprog_defs); - prog_public := p.(pprog_public); - prog_main := p.(pprog_main); - prog_types := p.(pprog_types); - prog_comp_env := ce; - prog_comp_env_eq := _ |} - end. - +Definition program := Ctypes.program function. diff --git a/cfrontend/Ctypes.v b/cfrontend/Ctypes.v index 78345b42..9faa6d40 100644 --- a/cfrontend/Ctypes.v +++ b/cfrontend/Ctypes.v @@ -15,10 +15,8 @@ (** Type expressions for the Compcert C and Clight languages *) -Require Import Coqlib. -Require Import Maps. -Require Import AST. -Require Import Errors. +Require Import Axioms Coqlib Maps Errors. +Require Import AST Linking. Require Archi. (** * Syntax of types *) @@ -157,6 +155,20 @@ Definition members : Type := list (ident * type). Inductive composite_definition : Type := Composite (id: ident) (su: struct_or_union) (m: members) (a: attr). +Definition name_composite_def (c: composite_definition) : ident := + match c with Composite id su m a => id end. + +Definition composite_def_eq (x y: composite_definition): {x=y} + {x<>y}. +Proof. + decide equality. +- decide equality. decide equality. apply N.eq_dec. apply bool_dec. +- apply list_eq_dec. decide equality. apply type_eq. apply ident_eq. +- decide equality. +- apply ident_eq. +Defined. + +Global Opaque composite_def_eq. + (** For type-checking, compilation and semantics purposes, the composite definitions are collected in the following [composite_env] environment. The [composite] record contains additional information compared with @@ -960,6 +972,29 @@ Record composite_consistent (env: composite_env) (co: composite) : Prop := { Definition composite_env_consistent (env: composite_env) : Prop := forall id co, env!id = Some co -> composite_consistent env co. +Lemma composite_consistent_stable: + forall (env env': composite_env) + (EXTENDS: forall id co, env!id = Some co -> env'!id = Some co) + co, + composite_consistent env co -> composite_consistent env' co. +Proof. + intros. destruct H as [A B C D]. constructor. + eapply complete_members_stable; eauto. + symmetry; rewrite B. f_equal. apply alignof_composite_stable; auto. + symmetry; rewrite C. f_equal. apply sizeof_composite_stable; auto. + symmetry; rewrite D. apply rank_members_stable; auto. +Qed. + +Lemma composite_of_def_consistent: + forall env id su m a co, + composite_of_def env id su m a = OK co -> + composite_consistent env co. +Proof. + unfold composite_of_def; intros. + destruct (env!id); try discriminate. destruct (complete_members env m) eqn:C; inv H. + constructor; auto. +Qed. + Theorem build_composite_env_consistent: forall defs env, build_composite_env defs = OK env -> composite_env_consistent env. Proof. @@ -973,28 +1008,15 @@ Proof. - destruct d1; monadInv H. eapply IHdefs; eauto. set (env1 := PTree.set id x env0) in *. - unfold composite_of_def in EQ. - destruct (env0!id) eqn:E; try discriminate. - destruct (complete_members env0 m) eqn:C; inversion EQ; clear EQ. + assert (env0!id = None). + { unfold composite_of_def in EQ. destruct (env0!id). discriminate. auto. } assert (forall id1 co1, env0!id1 = Some co1 -> env1!id1 = Some co1). { intros. unfold env1. rewrite PTree.gso; auto. congruence. } - red; intros. unfold env1 in H2; rewrite PTree.gsspec in H2; destruct (peq id0 id). + red; intros. apply composite_consistent_stable with env0; auto. + unfold env1 in H2; rewrite PTree.gsspec in H2; destruct (peq id0 id). + subst id0. inversion H2; clear H2. subst co. -(* - assert (A: alignof_composite env1 m = alignof_composite env0 m) - by (apply alignof_composite_stable; assumption). -*) - rewrite <- H1; constructor; simpl. -* eapply complete_members_stable; eauto. -* f_equal. symmetry. apply alignof_composite_stable; auto. -* f_equal. symmetry. apply sizeof_composite_stable; auto. -* symmetry. apply rank_members_stable; auto. -+ exploit H0; eauto. intros [P Q R S]. - constructor; intros. -* eapply complete_members_stable; eauto. -* rewrite Q. f_equal. symmetry. apply alignof_composite_stable; auto. -* rewrite R. f_equal. symmetry. apply sizeof_composite_stable; auto. -* rewrite S. symmetry; apply rank_members_stable; auto. + eapply composite_of_def_consistent; eauto. ++ eapply H0; eauto. Qed. (** Moreover, every composite definition is reflected in the composite environment. *) @@ -1018,6 +1040,29 @@ Proof. subst x; auto. Qed. +Theorem build_composite_env_domain: + forall env defs id co, + build_composite_env defs = OK env -> + env!id = Some co -> + In (Composite id (co_su co) (co_members co) (co_attr co)) defs. +Proof. + intros env0 defs0 id co. + assert (REC: forall l env env', + add_composite_definitions env l = OK env' -> + env'!id = Some co -> + env!id = Some co \/ In (Composite id (co_su co) (co_members co) (co_attr co)) l). + { induction l; simpl; intros. + - inv H; auto. + - destruct a; monadInv H. exploit IHl; eauto. + unfold composite_of_def in EQ. destruct (env!id0) eqn:E; try discriminate. + destruct (complete_members env m) eqn:C; simplify_eq EQ. clear EQ; intros EQ. + rewrite PTree.gsspec. intros [A|A]; auto. + destruct (peq id id0); auto. + inv A. rewrite <- H1; auto. + } + intros. exploit REC; eauto. rewrite PTree.gempty. intuition congruence. +Qed. + (** As a corollay, in a consistent environment, the rank of a composite type is strictly greater than the ranks of its member types. *) @@ -1054,3 +1099,441 @@ Proof. exploit (rank_type_members ce); eauto. omega. Qed. + +(** * Programs and compilation units *) + +(** The definitions in this section are parameterized over a type [F] of + internal function definitions, so that they apply both to CompCert C and to Clight. *) + +Set Implicit Arguments. + +Section PROGRAMS. + +Variable F: Type. + +(** Functions can either be defined ([Internal]) or declared as + external functions ([External]). *) + +Inductive fundef : Type := + | Internal: F -> fundef + | External: external_function -> typelist -> type -> calling_convention -> fundef. + +(** A program, or compilation unit, is composed of: +- a list of definitions of functions and global variables; +- the names of functions and global variables that are public (not static); +- the name of the function that acts as entry point ("main" function). +- a list of definitions for structure and union names +- the corresponding composite environment +- a proof that this environment is consistent with the definitions. *) + +Record program : Type := { + prog_defs: list (ident * globdef fundef type); + prog_public: list ident; + prog_main: ident; + prog_types: list composite_definition; + prog_comp_env: composite_env; + prog_comp_env_eq: build_composite_env prog_types = OK prog_comp_env +}. + +Definition program_of_program (p: program) : AST.program fundef type := + {| AST.prog_defs := p.(prog_defs); + AST.prog_public := p.(prog_public); + AST.prog_main := p.(prog_main) |}. + +Coercion program_of_program: program >-> AST.program. + +Program Definition make_program (types: list composite_definition) + (defs: list (ident * globdef fundef type)) + (public: list ident) + (main: ident) : res program := + match build_composite_env types with + | Error e => Error e + | OK ce => + OK {| prog_defs := defs; + prog_public := public; + prog_main := main; + prog_types := types; + prog_comp_env := ce; + prog_comp_env_eq := _ |} + end. + +End PROGRAMS. + +Arguments External {F} _ _ _ _. + +Unset Implicit Arguments. + +(** * Separate compilation and linking *) + +(** ** Linking types *) + +Instance Linker_types : Linker type := { + link := fun t1 t2 => if type_eq t1 t2 then Some t1 else None; + linkorder := fun t1 t2 => t1 = t2 +}. +Proof. + auto. + intros; congruence. + intros. destruct (type_eq x y); inv H. auto. +Defined. + +Global Opaque Linker_types. + +(** ** Linking composite definitions *) + +Definition check_compat_composite (l: list composite_definition) (cd: composite_definition) : bool := + List.forallb + (fun cd' => + if ident_eq (name_composite_def cd') (name_composite_def cd) then composite_def_eq cd cd' else true) + l. + +Definition filter_redefs (l1 l2: list composite_definition) := + let names1 := map name_composite_def l1 in + List.filter (fun cd => negb (In_dec ident_eq (name_composite_def cd) names1)) l2. + +Definition link_composite_defs (l1 l2: list composite_definition): option (list composite_definition) := + if List.forallb (check_compat_composite l2) l1 + then Some (l1 ++ filter_redefs l1 l2) + else None. + +Lemma link_composite_def_inv: + forall l1 l2 l, + link_composite_defs l1 l2 = Some l -> + (forall cd1 cd2, In cd1 l1 -> In cd2 l2 -> name_composite_def cd2 = name_composite_def cd1 -> cd2 = cd1) + /\ l = l1 ++ filter_redefs l1 l2 + /\ (forall x, In x l <-> In x l1 \/ In x l2). +Proof. + unfold link_composite_defs; intros. + destruct (forallb (check_compat_composite l2) l1) eqn:C; inv H. + assert (A: + forall cd1 cd2, In cd1 l1 -> In cd2 l2 -> name_composite_def cd2 = name_composite_def cd1 -> cd2 = cd1). + { rewrite forallb_forall in C. intros. + apply C in H. unfold check_compat_composite in H. rewrite forallb_forall in H. + apply H in H0. rewrite H1, dec_eq_true in H0. symmetry; eapply proj_sumbool_true; eauto. } + split. auto. split. auto. + unfold filter_redefs; intros. + rewrite in_app_iff. rewrite filter_In. intuition auto. + destruct (in_dec ident_eq (name_composite_def x) (map name_composite_def l1)); simpl; auto. + exploit list_in_map_inv; eauto. intros (y & P & Q). + assert (x = y) by eauto. subst y. auto. +Qed. + +Instance Linker_composite_defs : Linker (list composite_definition) := { + link := link_composite_defs; + linkorder := @List.incl composite_definition +}. +Proof. +- intros; apply incl_refl. +- intros; red; intros; eauto. +- intros. apply link_composite_def_inv in H; destruct H as (A & B & C). + split; red; intros; apply C; auto. +Defined. + +(** Connections with [build_composite_env]. *) + +Lemma add_composite_definitions_append: + forall l1 l2 env env'', + add_composite_definitions env (l1 ++ l2) = OK env'' <-> + exists env', add_composite_definitions env l1 = OK env' /\ add_composite_definitions env' l2 = OK env''. +Proof. + induction l1; simpl; intros. +- split; intros. exists env; auto. destruct H as (env' & A & B). congruence. +- destruct a; simpl. destruct (composite_of_def env id su m a); simpl. + apply IHl1. + split; intros. discriminate. destruct H as (env' & A & B); discriminate. +Qed. + +Lemma composite_eq: + forall su1 m1 a1 sz1 al1 r1 pos1 al2p1 szal1 + su2 m2 a2 sz2 al2 r2 pos2 al2p2 szal2, + su1 = su2 -> m1 = m2 -> a1 = a2 -> sz1 = sz2 -> al1 = al2 -> r1 = r2 -> + Build_composite su1 m1 a1 sz1 al1 r1 pos1 al2p1 szal1 = Build_composite su2 m2 a2 sz2 al2 r2 pos2 al2p2 szal2. +Proof. + intros. subst. + assert (pos1 = pos2) by apply proof_irr. + assert (al2p1 = al2p2) by apply proof_irr. + assert (szal1 = szal2) by apply proof_irr. + subst. reflexivity. +Qed. + +Lemma composite_of_def_eq: + forall env id co, + composite_consistent env co -> + env!id = None -> + composite_of_def env id (co_su co) (co_members co) (co_attr co) = OK co. +Proof. + intros. destruct H as [A B C D]. unfold composite_of_def. rewrite H0, A. + destruct co; simpl in *. f_equal. apply composite_eq; auto. rewrite C, B; auto. +Qed. + +Lemma composite_consistent_unique: + forall env co1 co2, + composite_consistent env co1 -> + composite_consistent env co2 -> + co_su co1 = co_su co2 -> + co_members co1 = co_members co2 -> + co_attr co1 = co_attr co2 -> + co1 = co2. +Proof. + intros. destruct H, H0. destruct co1, co2; simpl in *. apply composite_eq; congruence. +Qed. + +Lemma composite_of_def_stable: + forall (env env': composite_env) + (EXTENDS: forall id co, env!id = Some co -> env'!id = Some co) + id su m a co, + env'!id = None -> + composite_of_def env id su m a = OK co -> + composite_of_def env' id su m a = OK co. +Proof. + intros. + unfold composite_of_def in H0. + destruct (env!id) eqn:E; try discriminate. + destruct (complete_members env m) eqn:CM; try discriminate. + transitivity (composite_of_def env' id (co_su co) (co_members co) (co_attr co)). + inv H0; auto. + apply composite_of_def_eq; auto. + apply composite_consistent_stable with env; auto. + inv H0; constructor; auto. +Qed. + +Lemma link_add_composite_definitions: + forall l0 env0, + build_composite_env l0 = OK env0 -> + forall l env1 env1' env2, + add_composite_definitions env1 l = OK env1' -> + (forall id co, env1!id = Some co -> env2!id = Some co) -> + (forall id co, env0!id = Some co -> env2!id = Some co) -> + (forall id, env2!id = if In_dec ident_eq id (map name_composite_def l0) then env0!id else env1!id) -> + ((forall cd1 cd2, In cd1 l0 -> In cd2 l -> name_composite_def cd2 = name_composite_def cd1 -> cd2 = cd1)) -> + { env2' | + add_composite_definitions env2 (filter_redefs l0 l) = OK env2' + /\ (forall id co, env1'!id = Some co -> env2'!id = Some co) + /\ (forall id co, env0!id = Some co -> env2'!id = Some co) }. +Proof. + induction l; simpl; intros until env2; intros ACD AGREE1 AGREE0 AGREE2 UNIQUE. +- inv ACD. exists env2; auto. +- destruct a. destruct (composite_of_def env1 id su m a) as [x|e] eqn:EQ; try discriminate. + simpl in ACD. + generalize EQ. unfold composite_of_def at 1. + destruct (env1!id) eqn:E1; try congruence. + destruct (complete_members env1 m) eqn:CM1; try congruence. + intros EQ1. + simpl. destruct (in_dec ident_eq id (map name_composite_def l0)); simpl. ++ eapply IHl; eauto. +* intros. rewrite PTree.gsspec in H0. destruct (peq id0 id); auto. + inv H0. + exploit list_in_map_inv; eauto. intros ([id' su' m' a'] & P & Q). + assert (X: Composite id su m a = Composite id' su' m' a'). + { eapply UNIQUE. auto. auto. rewrite <- P; auto. } + inv X. + exploit build_composite_env_charact; eauto. intros (co' & U & V & W & X). + assert (co' = co). + { apply composite_consistent_unique with env2. + apply composite_consistent_stable with env0; auto. + eapply build_composite_env_consistent; eauto. + apply composite_consistent_stable with env1; auto. + inversion EQ1; constructor; auto. + inversion EQ1; auto. + inversion EQ1; auto. + inversion EQ1; auto. } + subst co'. apply AGREE0; auto. +* intros. rewrite AGREE2. destruct (in_dec ident_eq id0 (map name_composite_def l0)); auto. + rewrite PTree.gsspec. destruct (peq id0 id); auto. subst id0. contradiction. ++ assert (E2: env2!id = None). + { rewrite AGREE2. rewrite pred_dec_false by auto. auto. } + assert (E3: composite_of_def env2 id su m a = OK x). + { eapply composite_of_def_stable. eexact AGREE1. eauto. eauto. } + rewrite E3. simpl. eapply IHl; eauto. +* intros until co; rewrite ! PTree.gsspec. destruct (peq id0 id); auto. +* intros until co; rewrite ! PTree.gsspec. intros. destruct (peq id0 id); auto. + subst id0. apply AGREE0 in H0. congruence. +* intros. rewrite ! PTree.gsspec. destruct (peq id0 id); auto. subst id0. + rewrite pred_dec_false by auto. auto. +Qed. + +Theorem link_build_composite_env: + forall l1 l2 l env1 env2, + build_composite_env l1 = OK env1 -> + build_composite_env l2 = OK env2 -> + link l1 l2 = Some l -> + { env | + build_composite_env l = OK env + /\ (forall id co, env1!id = Some co -> env!id = Some co) + /\ (forall id co, env2!id = Some co -> env!id = Some co) }. +Proof. + intros. edestruct link_composite_def_inv as (A & B & C); eauto. + edestruct link_add_composite_definitions as (env & P & Q & R). + eexact H. + eexact H0. + instantiate (1 := env1). intros. rewrite PTree.gempty in H2; discriminate. + auto. + intros. destruct (in_dec ident_eq id (map name_composite_def l1)); auto. + rewrite PTree.gempty. destruct (env1!id) eqn:E1; auto. + exploit build_composite_env_domain. eexact H. eauto. + intros. apply (in_map name_composite_def) in H2. elim n; auto. + auto. + exists env; split; auto. subst l. apply add_composite_definitions_append. exists env1; auto. +Qed. + +(** ** Linking function definitions *) + +Definition link_fundef {F: Type} (fd1 fd2: fundef F) := + match fd1, fd2 with + | Internal _, Internal _ => None + | External ef1 targs1 tres1 cc1, External ef2 targs2 tres2 cc2 => + if external_function_eq ef1 ef2 + && typelist_eq targs1 targs2 + && type_eq tres1 tres2 + && calling_convention_eq cc1 cc2 + then Some (External ef1 targs1 tres1 cc1) + else None + | Internal f, External ef targs tres cc => + match ef with EF_external id sg => Some (Internal f) | _ => None end + | External ef targs tres cc, Internal f => + match ef with EF_external id sg => Some (Internal f) | _ => None end + end. + +Inductive linkorder_fundef {F: Type}: fundef F -> fundef F -> Prop := + | linkorder_fundef_refl: forall fd, + linkorder_fundef fd fd + | linkorder_fundef_ext_int: forall f id sg targs tres cc, + linkorder_fundef (External (EF_external id sg) targs tres cc) (Internal f). + +Instance Linker_fundef (F: Type): Linker (fundef F) := { + link := link_fundef; + linkorder := linkorder_fundef +}. +Proof. +- intros; constructor. +- intros. inv H; inv H0; constructor. +- intros x y z EQ. destruct x, y; simpl in EQ. ++ discriminate. ++ destruct e; inv EQ. split; constructor. ++ destruct e; inv EQ. split; constructor. ++ destruct (external_function_eq e e0 && typelist_eq t t1 && type_eq t0 t2 && calling_convention_eq c c0) eqn:A; inv EQ. + InvBooleans. subst. split; constructor. +Defined. + +Remark link_fundef_either: + forall (F: Type) (f1 f2 f: fundef F), link f1 f2 = Some f -> f = f1 \/ f = f2. +Proof. + simpl; intros. unfold link_fundef in H. destruct f1, f2; try discriminate. +- destruct e; inv H. auto. +- destruct e; inv H. auto. +- destruct (external_function_eq e e0 && typelist_eq t t1 && type_eq t0 t2 && calling_convention_eq c c0); inv H; auto. +Qed. + +Global Opaque Linker_fundef. + +(** ** Linking programs *) + +Definition lift_option {A: Type} (opt: option A) : { x | opt = Some x } + { opt = None }. +Proof. + destruct opt. left; exists a; auto. right; auto. +Defined. + +Definition link_program {F:Type} (p1 p2: program F): option (program F) := + match link (program_of_program p1) (program_of_program p2) with + | None => None + | Some p => + match lift_option (link p1.(prog_types) p2.(prog_types)) with + | inright _ => None + | inleft (exist typs EQ) => + match link_build_composite_env + p1.(prog_types) p2.(prog_types) typs + p1.(prog_comp_env) p2.(prog_comp_env) + p1.(prog_comp_env_eq) p2.(prog_comp_env_eq) EQ with + | exist env (conj P Q) => + Some {| prog_defs := p.(AST.prog_defs); + prog_public := p.(AST.prog_public); + prog_main := p.(AST.prog_main); + prog_types := typs; + prog_comp_env := env; + prog_comp_env_eq := P |} + end + end + end. + +Definition linkorder_program {F: Type} (p1 p2: program F) : Prop := + linkorder (program_of_program p1) (program_of_program p2) + /\ (forall id co, p1.(prog_comp_env)!id = Some co -> p2.(prog_comp_env)!id = Some co). + +Instance Linker_program (F: Type): Linker (program F) := { + link := link_program; + linkorder := linkorder_program +}. +Proof. +- intros; split. apply linkorder_refl. auto. +- intros. destruct H, H0. split. eapply linkorder_trans; eauto. + intros; auto. +- intros until z. unfold link_program. + destruct (link (program_of_program x) (program_of_program y)) as [p|] eqn:LP; try discriminate. + destruct (lift_option (link (prog_types x) (prog_types y))) as [[typs EQ]|EQ]; try discriminate. + destruct (link_build_composite_env (prog_types x) (prog_types y) typs + (prog_comp_env x) (prog_comp_env y) (prog_comp_env_eq x) + (prog_comp_env_eq y) EQ) as (env & P & Q & R). + destruct (link_linkorder _ _ _ LP). + intros X; inv X. + split; split; auto. +Defined. + +Global Opaque Linker_program. + +(** ** Commutation between linking and program transformations *) + +Section LINK_MATCH_PROGRAM. + +Context {F G: Type}. +Variable match_fundef: fundef F -> fundef G -> Prop. + +Hypothesis link_match_fundef: + forall f1 tf1 f2 tf2 f, + link f1 f2 = Some f -> + match_fundef f1 tf1 -> match_fundef f2 tf2 -> + exists tf, link tf1 tf2 = Some tf /\ match_fundef f tf. + +Let match_program (p: program F) (tp: program G) : Prop := + Linking.match_program (fun ctx f tf => match_fundef f tf) eq p tp + /\ prog_types tp = prog_types p. + +Theorem link_match_program: + forall p1 p2 tp1 tp2 p, + link p1 p2 = Some p -> match_program p1 tp1 -> match_program p2 tp2 -> + exists tp, link tp1 tp2 = Some tp /\ match_program p tp. +Proof. + intros. destruct H0, H1. +Local Transparent Linker_program. + simpl in H; unfold link_program in H. + destruct (link (program_of_program p1) (program_of_program p2)) as [pp|] eqn:LP; try discriminate. + assert (A: exists tpp, + link (program_of_program tp1) (program_of_program tp2) = Some tpp + /\ Linking.match_program (fun ctx f tf => match_fundef f tf) eq pp tpp). + { eapply Linking.link_match_program. + - intros. exploit link_match_fundef; eauto. intros (tf & A & B). exists tf; auto. + - intros. + Local Transparent Linker_types. + simpl in *. destruct (type_eq v1 v2); inv H4. subst v tv2. exists tv1; rewrite dec_eq_true; auto. + - eauto. + - eauto. + - eauto. + - apply (link_linkorder _ _ _ LP). + - apply (link_linkorder _ _ _ LP). } + destruct A as (tpp & TLP & MP). + simpl; unfold link_program. rewrite TLP. + destruct (lift_option (link (prog_types p1) (prog_types p2))) as [[typs EQ]|EQ]; try discriminate. + destruct (link_build_composite_env (prog_types p1) (prog_types p2) typs + (prog_comp_env p1) (prog_comp_env p2) (prog_comp_env_eq p1) + (prog_comp_env_eq p2) EQ) as (env & P & Q). + rewrite <- H2, <- H3 in EQ. + destruct (lift_option (link (prog_types tp1) (prog_types tp2))) as [[ttyps EQ']|EQ']; try congruence. + assert (ttyps = typs) by congruence. subst ttyps. + destruct (link_build_composite_env (prog_types tp1) (prog_types tp2) typs + (prog_comp_env tp1) (prog_comp_env tp2) (prog_comp_env_eq tp1) + (prog_comp_env_eq tp2) EQ') as (tenv & R & S). + assert (tenv = env) by congruence. subst tenv. + econstructor; split; eauto. inv H. split; auto. + unfold program_of_program; simpl. destruct pp, tpp; exact MP. +Qed. + +End LINK_MATCH_PROGRAM. diff --git a/cfrontend/Ctyping.v b/cfrontend/Ctyping.v index f59fb396..440e4e84 100644 --- a/cfrontend/Ctyping.v +++ b/cfrontend/Ctyping.v @@ -15,21 +15,11 @@ (** Typing rules and type-checking for the Compcert C language *) -Require Import Coqlib. Require Import String. -Require Import Maps. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import Memory. -Require Import Globalenvs. -Require Import Events. -Require Import AST. -Require Import Ctypes. -Require Import Cop. -Require Import Csyntax. -Require Import Csem. -Require Import Errors. +Require Import Coqlib Maps Integers Floats Errors. +Require Import AST Linking. +Require Import Values Memory Globalenvs Events. +Require Import Ctypes Cop Csyntax Csem. Local Open Scope error_monad_scope. @@ -911,8 +901,8 @@ Definition retype_fundef (ce: composite_env) (e: typenv) (fd: fundef) : res fund Definition typecheck_program (p: program) : res program := let e := bind_globdef (PTree.empty _) p.(prog_defs) in let ce := p.(prog_comp_env) in - do defs <- transf_globdefs (retype_fundef ce e) (fun v => OK v) p.(prog_defs); - OK {| prog_defs := defs; + do tp <- transform_partial_program (retype_fundef ce e) p; + OK {| prog_defs := tp.(AST.prog_defs); prog_public := p.(prog_public); prog_main := p.(prog_main); prog_types := p.(prog_types); @@ -1325,32 +1315,29 @@ Theorem typecheck_program_sound: forall p p', typecheck_program p = OK p' -> wt_program p'. Proof. unfold typecheck_program; intros. monadInv H. - rename x into defs. + rename x into tp. constructor; simpl. set (ce := prog_comp_env p) in *. set (e := bind_globdef (PTree.empty type) (prog_defs p)) in *. - set (e' := bind_globdef (PTree.empty type) defs) in *. - assert (MATCH: - list_forall2 (match_globdef (fun f tf => retype_fundef ce e f = OK tf) (fun v tv => tv = v)) (prog_defs p) defs). - { - revert EQ; generalize (prog_defs p) defs. - induction l as [ | [id gd] l ]; intros l'; simpl; intros. - inv EQ. constructor. - destruct gd as [f | v]. - destruct (retype_fundef ce e f) as [tf|msg] eqn:R; monadInv EQ. - constructor; auto. constructor; auto. - monadInv EQ. constructor; auto. destruct v; constructor; auto. } + set (e' := bind_globdef (PTree.empty type) (AST.prog_defs tp)) in *. + assert (M: match_program (fun ctx f tf => retype_fundef ce e f = OK tf) eq p tp) + by (eapply match_transform_partial_program; eauto). + destruct M as (MATCH & _). simpl in MATCH. assert (ENVS: e' = e). - { unfold e, e'. revert MATCH; generalize (prog_defs p) defs (PTree.empty type). + { unfold e, e'. revert MATCH; generalize (prog_defs p) (AST.prog_defs tp) (PTree.empty type). induction l as [ | [id gd] l ]; intros l' t M; inv M. - auto. inv H1; simpl; auto. replace (type_of_fundef f2) with (type_of_fundef f1); auto. - unfold retype_fundef in H4. destruct f1; monadInv H4; auto. monadInv EQ0; auto. + auto. + destruct b1 as [id' gd']; destruct H1; simpl in *. inv H0; simpl. + replace (type_of_fundef f2) with (type_of_fundef f1); auto. + unfold retype_fundef in H2. destruct f1; monadInv H2; auto. monadInv EQ0; auto. + inv H1. simpl. auto. } rewrite ENVS. - intros id f. revert MATCH; generalize (prog_defs p) defs. induction 1; simpl; intros. + intros id f. revert MATCH; generalize (prog_defs p) (AST.prog_defs tp). + induction 1; simpl; intros. contradiction. - destruct H0; auto. subst b1; inv H. destruct f1; simpl in H2. - monadInv H2. eapply retype_function_sound; eauto. congruence. + destruct H0; auto. subst b1; inv H. simpl in H1. inv H1. + destruct f1; monadInv H4. eapply retype_function_sound; eauto. Qed. (** * Subject reduction *) @@ -2122,28 +2109,3 @@ Proof. Qed. End PRESERVATION. - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/cfrontend/Initializersproof.v b/cfrontend/Initializersproof.v index e6fcad8c..d5f39d7d 100644 --- a/cfrontend/Initializersproof.v +++ b/cfrontend/Initializersproof.v @@ -649,7 +649,7 @@ Qed. Lemma transl_init_single_size: forall ty a data, transl_init_single ge ty a = OK data -> - Genv.init_data_size data = sizeof ge ty. + init_data_size data = sizeof ge ty. Proof. intros. monadInv H. destruct x0. - monadInv EQ2. @@ -666,7 +666,7 @@ Proof. inv EQ2; auto. Qed. -Notation idlsize := Genv.init_data_list_size. +Notation idlsize := init_data_list_size. Remark padding_size: forall frm to, frm <= to -> idlsize (tr_padding frm to) = to - frm. diff --git a/cfrontend/PrintClight.ml b/cfrontend/PrintClight.ml index 9600b3fa..8a321757 100644 --- a/cfrontend/PrintClight.ml +++ b/cfrontend/PrintClight.ml @@ -258,7 +258,7 @@ let print_function p id f = let print_fundef p id fd = match fd with - | External(EF_external(_,_), args, res, cconv) -> + | External((EF_external _ | EF_runtime _), args, res, cconv) -> fprintf p "extern %s;@ @ " (name_cdecl (extern_atom id) (Tfunction(args, res, cconv))) | External(_, _, _, _) -> diff --git a/cfrontend/PrintCsyntax.ml b/cfrontend/PrintCsyntax.ml index f68f520d..d884100b 100644 --- a/cfrontend/PrintCsyntax.ml +++ b/cfrontend/PrintCsyntax.ml @@ -264,6 +264,8 @@ let rec expr p (prec, e) = (camlstring_of_coqstring txt) exprlist (false, args) | Ebuiltin(EF_external(id, sg), _, args, _) -> fprintf p "%s@[<hov 1>(%a)@]" (camlstring_of_coqstring id) exprlist (true, args) + | Ebuiltin(EF_runtime(id, sg), _, args, _) -> + fprintf p "%s@[<hov 1>(%a)@]" (camlstring_of_coqstring id) exprlist (true, args) | Ebuiltin(EF_inline_asm(txt, sg, clob), _, args, _) -> extended_asm p txt None args clob | Ebuiltin(EF_debug(kind,txt,_),_,args,_) -> @@ -427,7 +429,7 @@ let print_function p id f = let print_fundef p id fd = match fd with - | External(EF_external(_,_), args, res, cconv) -> + | External((EF_external _ | EF_runtime _), args, res, cconv) -> fprintf p "extern %s;@ @ " (name_cdecl (extern_atom id) (Tfunction(args, res, cconv))) | External(_, _, _, _) -> diff --git a/cfrontend/SimplExpr.v b/cfrontend/SimplExpr.v index a3af8114..bfdd8ab9 100644 --- a/cfrontend/SimplExpr.v +++ b/cfrontend/SimplExpr.v @@ -512,9 +512,9 @@ Local Open Scope error_monad_scope. Definition transl_fundef (fd: Csyntax.fundef) : res fundef := match fd with - | Csyntax.Internal f => + | Internal f => do tf <- transl_function f; OK (Internal tf) - | Csyntax.External ef targs tres cc => + | External ef targs tres cc => OK (External ef targs tres cc) end. @@ -523,6 +523,6 @@ Definition transl_program (p: Csyntax.program) : res program := OK {| prog_defs := AST.prog_defs p1; prog_public := AST.prog_public p1; prog_main := AST.prog_main p1; - prog_types := Csyntax.prog_types p; - prog_comp_env := Csyntax.prog_comp_env p; - prog_comp_env_eq := Csyntax.prog_comp_env_eq p |}. + prog_types := prog_types p; + prog_comp_env := prog_comp_env p; + prog_comp_env_eq := prog_comp_env_eq p |}. diff --git a/cfrontend/SimplExprproof.v b/cfrontend/SimplExprproof.v index 8baa7d46..64e52df8 100644 --- a/cfrontend/SimplExprproof.v +++ b/cfrontend/SimplExprproof.v @@ -12,30 +12,34 @@ (** Correctness proof for expression simplification. *) -Require Import Coqlib. -Require Import Maps. -Require Import AST. -Require Import Errors. -Require Import Integers. -Require Import Values. -Require Import Memory. -Require Import Events. -Require Import Smallstep. -Require Import Globalenvs. -Require Import Ctypes. -Require Import Cop. -Require Import Csyntax. -Require Import Csem. -Require Import Cstrategy. -Require Import Clight. -Require Import SimplExpr. -Require Import SimplExprspec. +Require Import Coqlib Maps Errors Integers. +Require Import AST Linking. +Require Import Values Memory Events Globalenvs Smallstep. +Require Import Ctypes Cop Csyntax Csem Cstrategy Clight. +Require Import SimplExpr SimplExprspec. + +(** ** Relational specification of the translation. *) + +Definition match_prog (p: Csyntax.program) (tp: Clight.program) := + match_program (fun ctx f tf => tr_fundef f tf) eq p tp + /\ prog_types tp = prog_types p. + +Lemma transf_program_match: + forall p tp, transl_program p = OK tp -> match_prog p tp. +Proof. + unfold transl_program; intros. monadInv H. split; auto. + unfold program_of_program; simpl. destruct x; simpl. + eapply match_transform_partial_program_contextual. eexact EQ. + intros. apply transl_fundef_spec; auto. +Qed. + +(** ** Semantic preservation *) Section PRESERVATION. Variable prog: Csyntax.program. Variable tprog: Clight.program. -Hypothesis TRANSL: transl_program prog = OK tprog. +Hypothesis TRANSL: match_prog prog tprog. Let ge := Csem.globalenv prog. Let tge := Clight.globalenv tprog. @@ -45,22 +49,17 @@ Let tge := Clight.globalenv tprog. Lemma comp_env_preserved: Clight.genv_cenv tge = Csem.genv_cenv ge. Proof. - monadInv TRANSL. unfold tge; rewrite <- H0; auto. + simpl. destruct TRANSL. generalize (prog_comp_env_eq tprog) (prog_comp_env_eq prog). + congruence. Qed. Lemma symbols_preserved: forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. -Proof. - intros. eapply Genv.find_symbol_match. eapply transl_program_spec; eauto. - simpl. tauto. -Qed. +Proof (Genv.find_symbol_match (proj1 TRANSL)). -Lemma public_preserved: - forall (s: ident), Genv.public_symbol tge s = Genv.public_symbol ge s. -Proof. - intros. eapply Genv.public_symbol_match. eapply transl_program_spec; eauto. - simpl. tauto. -Qed. +Lemma senv_preserved: + Senv.equiv ge tge. +Proof (Genv.senv_match (proj1 TRANSL)). Lemma function_ptr_translated: forall b f, @@ -68,9 +67,8 @@ Lemma function_ptr_translated: exists tf, Genv.find_funct_ptr tge b = Some tf /\ tr_fundef f tf. Proof. - intros. eapply Genv.find_funct_ptr_match. - eapply transl_program_spec; eauto. - assumption. + intros. + edestruct (Genv.find_funct_ptr_match (proj1 TRANSL)) as (ctx & tf & A & B & C); eauto. Qed. Lemma functions_translated: @@ -79,27 +77,8 @@ Lemma functions_translated: exists tf, Genv.find_funct tge v = Some tf /\ tr_fundef f tf. Proof. - intros. eapply Genv.find_funct_match. - eapply transl_program_spec; eauto. - assumption. -Qed. - -Lemma varinfo_preserved: - forall b, Genv.find_var_info tge b = Genv.find_var_info ge b. -Proof. - intros. destruct (Genv.find_var_info ge b) as [v|] eqn:V. -- exploit Genv.find_var_info_match. eapply transl_program_spec; eauto. eassumption. - intros [tv [A B]]. inv B. assumption. -- destruct (Genv.find_var_info tge b) as [v'|] eqn:V'; auto. - exploit Genv.find_var_info_rev_match. eapply transl_program_spec; eauto. eassumption. - simpl. destruct (plt b (Genv.genv_next (Genv.globalenv prog))); try tauto. - intros [v [A B]]. inv B. change (Genv.globalenv prog) with (Csem.genv_genv ge) in A. congruence. -Qed. - -Lemma block_is_volatile_preserved: - forall b, Genv.block_is_volatile tge b = Genv.block_is_volatile ge b. -Proof. - intros. unfold Genv.block_is_volatile. rewrite varinfo_preserved. auto. + intros. + edestruct (Genv.find_funct_match (proj1 TRANSL)) as (ctx & tf & A & B & C); eauto. Qed. Lemma type_of_fundef_preserved: @@ -167,8 +146,7 @@ Proof. (* By_value, not volatile *) rewrite H1. split; auto. eapply deref_loc_value; eauto. (* By_value, volatile *) - rewrite H0; rewrite H1. eapply volatile_load_preserved with (ge1 := ge); auto. - exact symbols_preserved. exact public_preserved. exact block_is_volatile_preserved. + rewrite H0; rewrite H1. eapply volatile_load_preserved with (ge1 := ge); auto. apply senv_preserved. (* By reference *) rewrite H0. destruct (type_is_volatile ty); split; auto; eapply deref_loc_reference; eauto. (* By copy *) @@ -187,8 +165,7 @@ Proof. (* By_value, not volatile *) rewrite H1. split; auto. eapply assign_loc_value; eauto. (* By_value, volatile *) - rewrite H0; rewrite H1. eapply volatile_store_preserved with (ge1 := ge); auto. - exact symbols_preserved. exact public_preserved. exact block_is_volatile_preserved. + rewrite H0; rewrite H1. eapply volatile_store_preserved with (ge1 := ge); auto. apply senv_preserved. (* By copy *) rewrite H0. rewrite <- comp_env_preserved in *. destruct (type_is_volatile ty); split; auto; eapply assign_loc_copy; eauto. @@ -1907,8 +1884,7 @@ Proof. econstructor; split. left. eapply plus_left. constructor. apply star_one. econstructor; eauto. - eapply external_call_symbols_preserved; eauto. - exact symbols_preserved. exact public_preserved. exact varinfo_preserved. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. traceEq. econstructor; eauto. change sl2 with (nil ++ sl2). apply S. constructor. simpl; auto. auto. @@ -1918,8 +1894,7 @@ Proof. econstructor; split. left. eapply plus_left. constructor. apply star_one. econstructor; eauto. - eapply external_call_symbols_preserved; eauto. - exact symbols_preserved. exact public_preserved. exact varinfo_preserved. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. traceEq. econstructor; eauto. change sl2 with (nil ++ sl2). apply S. @@ -2215,8 +2190,7 @@ Proof. inv H5. econstructor; split. left; apply plus_one. econstructor; eauto. - eapply external_call_symbols_preserved; eauto. - exact symbols_preserved. exact public_preserved. exact varinfo_preserved. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. constructor; auto. (* return *) @@ -2246,15 +2220,14 @@ Lemma transl_initial_states: Csem.initial_state prog S -> exists S', Clight.initial_state tprog S' /\ match_states S S'. Proof. - intros. inv H. generalize TRANSL; intros TR; monadInv TR. rewrite H4. - exploit transl_program_spec; eauto. intros MP. + intros. inv H. exploit function_ptr_translated; eauto. intros [tf [FIND TR]]. econstructor; split. econstructor. - exploit Genv.init_mem_match; eauto. - change (Genv.globalenv tprog) with (genv_genv tge). - rewrite symbols_preserved. rewrite <- H4; simpl. - rewrite (transform_partial_program_main _ _ EQ). eauto. + eapply (Genv.init_mem_match (proj1 TRANSL)); eauto. + replace (prog_main tprog) with (prog_main prog). + rewrite symbols_preserved. eauto. + destruct TRANSL. destruct H as (A & B & C). simpl in B. auto. eexact FIND. rewrite <- H3. apply type_of_fundef_preserved. auto. constructor. auto. constructor. @@ -2271,7 +2244,7 @@ Theorem transl_program_correct: forward_simulation (Cstrategy.semantics prog) (Clight.semantics1 tprog). Proof. eapply forward_simulation_star_wf with (order := ltof _ measure). - eexact public_preserved. + eapply senv_preserved. eexact transl_initial_states. eexact transl_final_states. apply well_founded_ltof. @@ -2279,3 +2252,18 @@ Proof. Qed. End PRESERVATION. + +(** ** Commutation with linking *) + +Instance TransfSimplExprLink : TransfLink match_prog. +Proof. + red; intros. eapply Ctypes.link_match_program; eauto. +- intros. +Local Transparent Linker_fundef. + simpl in *; unfold link_fundef in *. inv H3; inv H4; try discriminate. + destruct ef; inv H2. exists (Internal tf); split; auto. constructor; auto. + destruct ef; inv H2. exists (Internal tf); split; auto. constructor; auto. + destruct (external_function_eq ef ef0 && typelist_eq targs targs0 && + type_eq tres tres0 && calling_convention_eq cconv cconv0); inv H2. + exists (External ef targs tres cconv); split; auto. constructor. +Qed. diff --git a/cfrontend/SimplExprspec.v b/cfrontend/SimplExprspec.v index b94465a1..453a4c9a 100644 --- a/cfrontend/SimplExprspec.v +++ b/cfrontend/SimplExprspec.v @@ -12,18 +12,9 @@ (** Relational specification of expression simplification. *) -Require Import Coqlib. -Require Import Errors. -Require Import Maps. -Require Import Integers. -Require Import Floats. -Require Import Memory. -Require Import AST. -Require Import Ctypes. -Require Import Cop. -Require Import Csyntax. -Require Import Clight. -Require Import SimplExpr. +Require Import Coqlib Maps Errors Integers Floats. +Require Import AST Linking Memory. +Require Import Ctypes Cop Csyntax Clight SimplExpr. Section SPEC. @@ -1077,8 +1068,7 @@ Opaque transl_expression transl_expr_stmt. monadInv TR; constructor; eauto. Qed. -(** Relational presentation for the transformation of functions, fundefs, and va -riables. *) +(** Relational presentation for the transformation of functions, fundefs, and variables. *) Inductive tr_function: Csyntax.function -> Clight.function -> Prop := | tr_function_intro: forall f tf, @@ -1092,9 +1082,9 @@ Inductive tr_function: Csyntax.function -> Clight.function -> Prop := Inductive tr_fundef: Csyntax.fundef -> Clight.fundef -> Prop := | tr_internal: forall f tf, tr_function f tf -> - tr_fundef (Csyntax.Internal f) (Clight.Internal tf) + tr_fundef (Internal f) (Internal tf) | tr_external: forall ef targs tres cconv, - tr_fundef (Csyntax.External ef targs tres cconv) (External ef targs tres cconv). + tr_fundef (External ef targs tres cconv) (External ef targs tres cconv). Lemma transl_function_spec: forall f tf, @@ -1117,30 +1107,5 @@ Proof. + constructor. Qed. -Lemma transl_globdefs_spec: - forall l l', - transf_globdefs transl_fundef (fun v : type => OK v) l = OK l' -> - list_forall2 (match_globdef tr_fundef (fun v1 v2 => v1 = v2)) l l'. -Proof. - induction l; simpl; intros. -- inv H. constructor. -- destruct a as [id gd]. destruct gd. - + destruct (transl_fundef f) as [tf | ?] eqn:E1; Errors.monadInv H. - constructor; eauto. constructor. eapply transl_fundef_spec; eauto. - + Errors.monadInv H. - constructor; eauto. destruct v; constructor; auto. -Qed. - -Theorem transl_program_spec: - forall p tp, - transl_program p = OK tp -> - match_program tr_fundef (fun v1 v2 => v1 = v2) nil (Csyntax.prog_main p) p tp. -Proof. - unfold transl_program, transform_partial_program; intros. Errors.monadInv H. Errors.monadInv EQ; simpl. - split; auto. exists x0; split. - eapply transl_globdefs_spec; eauto. - rewrite <- app_nil_end; auto. -Qed. - End SPEC. diff --git a/cfrontend/SimplLocals.v b/cfrontend/SimplLocals.v index c4b1054d..580f02c2 100644 --- a/cfrontend/SimplLocals.v +++ b/cfrontend/SimplLocals.v @@ -15,13 +15,9 @@ Require Import FSets. Require FSetAVL. -Require Import Coqlib. -Require Import Ordered. -Require Import Errors. -Require Import AST. -Require Import Ctypes. -Require Import Cop. -Require Import Clight. +Require Import Coqlib Ordered Errors. +Require Import AST Linking. +Require Import Ctypes Cop Clight. Require Compopts. Open Scope error_monad_scope. diff --git a/cfrontend/SimplLocalsproof.v b/cfrontend/SimplLocalsproof.v index a86e3a01..2cd82d8f 100644 --- a/cfrontend/SimplLocalsproof.v +++ b/cfrontend/SimplLocalsproof.v @@ -13,80 +13,58 @@ (** Semantic preservation for the SimplLocals pass. *) Require Import FSets. -Require FSetAVL. -Require Import Coqlib. -Require Import Errors. -Require Import Ordered. -Require Import AST. -Require Import Maps. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import Memory. -Require Import Globalenvs. -Require Import Events. -Require Import Smallstep. -Require Import Ctypes. -Require Import Cop. -Require Import Clight. -Require Import SimplLocals. +Require Import Coqlib Errors Ordered Maps Integers Floats. +Require Import AST Linking. +Require Import Values Memory Globalenvs Events Smallstep. +Require Import Ctypes Cop Clight SimplLocals. Module VSF := FSetFacts.Facts(VSet). Module VSP := FSetProperties.Properties(VSet). +Definition match_prog (p tp: program) : Prop := + match_program (fun ctx f tf => transf_fundef f = OK tf) eq p tp + /\ prog_types tp = prog_types p. + +Lemma match_transf_program: + forall p tp, transf_program p = OK tp -> match_prog p tp. +Proof. + unfold transf_program; intros. monadInv H. + split; auto. apply match_transform_partial_program. rewrite EQ. destruct x; auto. +Qed. + Section PRESERVATION. Variable prog: program. Variable tprog: program. -Hypothesis TRANSF: transf_program prog = OK tprog. +Hypothesis TRANSF: match_prog prog tprog. Let ge := globalenv prog. Let tge := globalenv tprog. Lemma comp_env_preserved: genv_cenv tge = genv_cenv ge. Proof. - monadInv TRANSF. unfold tge; rewrite <- H0; auto. -Qed. - -Lemma transf_programs: - AST.transform_partial_program transf_fundef (program_of_program prog) = OK (program_of_program tprog). -Proof. - monadInv TRANSF. rewrite EQ. destruct x; reflexivity. + unfold tge, ge. destruct prog, tprog; simpl. destruct TRANSF as [_ EQ]. simpl in EQ. congruence. Qed. Lemma symbols_preserved: forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. -Proof. - exact (Genv.find_symbol_transf_partial _ _ transf_programs). -Qed. +Proof (Genv.find_symbol_match (proj1 TRANSF)). -Lemma public_preserved: - forall (s: ident), Genv.public_symbol tge s = Genv.public_symbol ge s. -Proof. - exact (Genv.public_symbol_transf_partial _ _ transf_programs). -Qed. - -Lemma varinfo_preserved: - forall b, Genv.find_var_info tge b = Genv.find_var_info ge b. -Proof. - exact (Genv.find_var_info_transf_partial _ _ transf_programs). -Qed. +Lemma senv_preserved: + Senv.equiv ge tge. +Proof (Genv.senv_match (proj1 TRANSF)). Lemma functions_translated: forall (v: val) (f: fundef), Genv.find_funct ge v = Some f -> exists tf, Genv.find_funct tge v = Some tf /\ transf_fundef f = OK tf. -Proof. - exact (Genv.find_funct_transf_partial _ _ transf_programs). -Qed. +Proof (Genv.find_funct_transf_partial (proj1 TRANSF)). Lemma function_ptr_translated: forall (b: block) (f: 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. - exact (Genv.find_funct_ptr_transf_partial _ _ transf_programs). -Qed. +Proof (Genv.find_funct_ptr_transf_partial (proj1 TRANSF)). Lemma type_of_fundef_preserved: forall fd tfd, @@ -2073,8 +2051,7 @@ Proof. exploit external_call_mem_inject; eauto. apply match_globalenvs_preserves_globals; eauto with compat. intros [j' [tvres [tm' [P [Q [R [S [T [U V]]]]]]]]]. econstructor; split. - apply plus_one. econstructor; eauto. eapply external_call_symbols_preserved; eauto. - exact symbols_preserved. exact public_preserved. exact varinfo_preserved. + apply plus_one. econstructor; eauto. eapply external_call_symbols_preserved; eauto. apply senv_preserved. econstructor; eauto with compat. eapply match_envs_set_opttemp; eauto. eapply match_envs_extcall; eauto. @@ -2235,8 +2212,7 @@ Proof. eapply match_cont_globalenv. eexact (MCONT VSet.empty). intros [j' [tvres [tm' [P [Q [R [S [T [U V]]]]]]]]]. econstructor; split. - apply plus_one. econstructor; eauto. eapply external_call_symbols_preserved; eauto. - exact symbols_preserved. exact public_preserved. exact varinfo_preserved. + apply plus_one. econstructor; eauto. eapply external_call_symbols_preserved; eauto. apply senv_preserved. econstructor; eauto. intros. apply match_cont_incr_bounds with (Mem.nextblock m) (Mem.nextblock tm). eapply match_cont_extcall; eauto. xomega. xomega. @@ -2259,10 +2235,10 @@ Proof. exploit function_ptr_translated; eauto. intros [tf [A B]]. econstructor; split. econstructor. - eapply Genv.init_mem_transf_partial. eexact transf_programs. eauto. - change (prog_main tprog) with (AST.prog_main tprog). - rewrite (transform_partial_program_main _ _ transf_programs). + eapply (Genv.init_mem_transf_partial (proj1 TRANSF)). eauto. + replace (prog_main tprog) with (prog_main prog). instantiate (1 := b). rewrite <- H1. apply symbols_preserved. + generalize (match_program_main (proj1 TRANSF)). simpl; auto. eauto. rewrite <- H3; apply type_of_fundef_preserved; auto. econstructor; eauto. @@ -2292,10 +2268,27 @@ Theorem transf_program_correct: forward_simulation (semantics1 prog) (semantics2 tprog). Proof. eapply forward_simulation_plus. - eexact public_preserved. + apply senv_preserved. eexact initial_states_simulation. eexact final_states_simulation. eexact step_simulation. Qed. End PRESERVATION. + +(** ** Commutation with linking *) + +Instance TransfSimplLocalsLink : TransfLink match_prog. +Proof. + red; intros. eapply Ctypes.link_match_program; eauto. +- intros. +Local Transparent Linker_fundef. + simpl in *; unfold link_fundef in *. + destruct f1; monadInv H3; destruct f2; monadInv H4; try discriminate. + destruct e; inv H2. exists (Internal x); split; auto. simpl; rewrite EQ; auto. + destruct e; inv H2. exists (Internal x); split; auto. simpl; rewrite EQ; auto. + destruct (external_function_eq e e0 && typelist_eq t t1 && + type_eq t0 t2 && calling_convention_eq c c0); inv H2. + econstructor; split; eauto. +Qed. + diff --git a/common/AST.v b/common/AST.v index 16673c47..415e90e2 100644 --- a/common/AST.v +++ b/common/AST.v @@ -17,10 +17,7 @@ the abstract syntax trees of many of the intermediate languages. *) Require Import String. -Require Import Coqlib. -Require Import Errors. -Require Import Integers. -Require Import Floats. +Require Import Coqlib Maps Errors Integers Floats. Set Implicit Arguments. @@ -106,6 +103,12 @@ Record calling_convention : Type := mkcallconv { Definition cc_default := {| cc_vararg := false; cc_unproto := false; cc_structret := false |}. +Definition calling_convention_eq (x y: calling_convention) : {x=y} + {x<>y}. +Proof. + decide equality; apply bool_dec. +Defined. +Global Opaque calling_convention_eq. + Record signature : Type := mksignature { sig_args: list typ; sig_res: option typ; @@ -120,8 +123,7 @@ Definition proj_sig_res (s: signature) : typ := Definition signature_eq: forall (s1 s2: signature), {s1=s2} + {s1<>s2}. Proof. - generalize opt_typ_eq, list_typ_eq; intros; decide equality. - generalize bool_dec; intros. decide equality. + generalize opt_typ_eq, list_typ_eq, calling_convention_eq; decide equality. Defined. Global Opaque signature_eq. @@ -189,6 +191,36 @@ Inductive init_data: Type := | Init_space: Z -> init_data | Init_addrof: ident -> int -> init_data. (**r address of symbol + offset *) +Definition init_data_size (i: init_data) : Z := + match i with + | Init_int8 _ => 1 + | Init_int16 _ => 2 + | Init_int32 _ => 4 + | Init_int64 _ => 8 + | Init_float32 _ => 4 + | Init_float64 _ => 8 + | Init_addrof _ _ => 4 + | Init_space n => Zmax n 0 + 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. + +Lemma init_data_size_pos: + forall i, init_data_size i >= 0. +Proof. + destruct i; simpl; xomega. +Qed. + +Lemma init_data_list_size_pos: + forall il, init_data_list_size il >= 0. +Proof. + induction il; simpl. omega. generalize (init_data_size_pos a); omega. +Qed. + (** Information attached to global variables. *) Record globvar (V: Type) : Type := mkglobvar { @@ -226,6 +258,49 @@ Record program (F V: Type) : Type := mkprogram { Definition prog_defs_names (F V: Type) (p: program F V) : list ident := List.map fst p.(prog_defs). +(** The "definition map" of a program maps names of globals to their definitions. + If several definitions have the same name, the one appearing last in [p.(prog_defs)] wins. *) + +Definition prog_defmap (F V: Type) (p: program F V) : PTree.t (globdef F V) := + PTree_Properties.of_list p.(prog_defs). + +Section DEFMAP. + +Variables F V: Type. +Variable p: program F V. + +Lemma in_prog_defmap: + forall id g, (prog_defmap p)!id = Some g -> In (id, g) (prog_defs p). +Proof. + apply PTree_Properties.in_of_list. +Qed. + +Lemma prog_defmap_dom: + forall id, In id (prog_defs_names p) -> exists g, (prog_defmap p)!id = Some g. +Proof. + apply PTree_Properties.of_list_dom. +Qed. + +Lemma prog_defmap_unique: + forall defs1 id g defs2, + prog_defs p = defs1 ++ (id, g) :: defs2 -> + ~In id (map fst defs2) -> + (prog_defmap p)!id = Some g. +Proof. + unfold prog_defmap; intros. rewrite H. apply PTree_Properties.of_list_unique; auto. +Qed. + +Lemma prog_defmap_norepet: + forall id g, + list_norepet (prog_defs_names p) -> + In (id, g) (prog_defs p) -> + (prog_defmap p)!id = Some g. +Proof. + apply PTree_Properties.of_list_norepet. +Qed. + +End DEFMAP. + (** * Generic transformations over programs *) (** We now define a general iterator over programs that applies a given @@ -249,109 +324,44 @@ Definition transform_program (p: program A V) : program B V := p.(prog_public) p.(prog_main). -Lemma transform_program_function: - forall p i tf, - In (i, Gfun tf) (transform_program p).(prog_defs) -> - exists f, In (i, Gfun f) p.(prog_defs) /\ transf f = tf. -Proof. - simpl. unfold transform_program. intros. - exploit list_in_map_inv; eauto. - intros [[i' gd] [EQ IN]]. simpl in EQ. destruct gd; inv EQ. - exists f; auto. -Qed. - End TRANSF_PROGRAM. -(** General iterator over program that applies a given code transfomration - function to all function descriptions with their identifers and leaves - teh other parts of the program unchanged. *) - -Section TRANSF_PROGRAM_IDENT. - -Variable A B V: Type. -Variable transf: ident -> A -> B. - -Definition transform_program_globdef_ident (idg: ident * globdef A V) : ident * globdef B V := - match idg with - | (id, Gfun f) => (id, Gfun (transf id f)) - | (id, Gvar v) => (id, Gvar v) - end. - -Definition transform_program_ident (p: program A V): program B V := - mkprogram - (List.map transform_program_globdef_ident p.(prog_defs)) - p.(prog_public) - p.(prog_main). - -Lemma tranforma_program_function_ident: - forall p i tf, - In (i, Gfun tf) (transform_program_ident p).(prog_defs) -> - exists f, In (i, Gfun f) p.(prog_defs) /\ transf i f = tf. -Proof. - simpl. unfold transform_program_ident. intros. - exploit list_in_map_inv; eauto. - intros [[i' gd] [EQ IN]]. simpl in EQ. destruct gd; inv EQ. - exists f; auto. -Qed. - -End TRANSF_PROGRAM_IDENT. - -(** The following is a more general presentation of [transform_program] where - global variable information can be transformed, in addition to function - definitions. Moreover, the transformation functions can fail and - return an error message. Also the transformation functions are defined - for the case the identifier of the function is passed as additional - argument *) +(** The following is a more general presentation of [transform_program]: +- Global variable information can be transformed, in addition to function + definitions. +- The transformation functions can fail and return an error message. +- The transformation for function definitions receives a global context + (derived from the compilation unit being transformed) as additiona + argument. +- The transformation functions receive the name of the global as + additional argument. *) Local Open Scope error_monad_scope. Section TRANSF_PROGRAM_GEN. Variables A B V W: Type. -Variable transf_fun: A -> res B. -Variable transf_fun_ident: ident -> A -> res B. -Variable transf_var: V -> res W. -Variable transf_var_ident: ident -> V -> res W. +Variable transf_fun: ident -> A -> res B. +Variable transf_var: ident -> V -> res W. -Definition transf_globvar (g: globvar V) : res (globvar W) := - do info' <- transf_var g.(gvar_info); - OK (mkglobvar info' g.(gvar_init) g.(gvar_readonly) g.(gvar_volatile)). - -Definition transf_globvar_ident (i: ident) (g: globvar V) : res (globvar W) := - do info' <- transf_var_ident i g.(gvar_info); +Definition transf_globvar (i: ident) (g: globvar V) : res (globvar W) := + do info' <- transf_var i g.(gvar_info); OK (mkglobvar info' g.(gvar_init) g.(gvar_readonly) g.(gvar_volatile)). Fixpoint transf_globdefs (l: list (ident * globdef A V)) : res (list (ident * globdef B W)) := match l with | nil => OK nil | (id, Gfun f) :: l' => - match transf_fun f with + match transf_fun id f with | Error msg => Error (MSG "In function " :: CTX id :: MSG ": " :: msg) | OK tf => - do tl' <- transf_globdefs l'; OK ((id, Gfun tf) :: tl') - end - | (id, Gvar v) :: l' => - match transf_globvar v with - | Error msg => Error (MSG "In variable " :: CTX id :: MSG ": " :: msg) - | OK tv => - do tl' <- transf_globdefs l'; OK ((id, Gvar tv) :: tl') - end - end. - -Fixpoint transf_globdefs_ident (l: list (ident * globdef A V)) : res (list (ident * globdef B W)) := - match l with - | nil => OK nil - | (id, Gfun f) :: l' => - match transf_fun_ident id f with - | Error msg => Error (MSG "In function " :: CTX id :: MSG ": " :: msg) - | OK tf => - do tl' <- transf_globdefs_ident l'; OK ((id, Gfun tf) :: tl') + do tl' <- transf_globdefs l'; OK ((id, Gfun tf) :: tl') end | (id, Gvar v) :: l' => - match transf_globvar_ident id v with + match transf_globvar id v with | Error msg => Error (MSG "In variable " :: CTX id :: MSG ": " :: msg) | OK tv => - do tl' <- transf_globdefs_ident l'; OK ((id, Gvar tv) :: tl') + do tl' <- transf_globdefs l'; OK ((id, Gvar tv) :: tl') end end. @@ -359,213 +369,6 @@ Definition transform_partial_program2 (p: program A V) : res (program B W) := do gl' <- transf_globdefs p.(prog_defs); OK (mkprogram gl' p.(prog_public) p.(prog_main)). -Definition transform_partial_ident_program2 (p: program A V) : res (program B W) := - do gl' <- transf_globdefs_ident p.(prog_defs); - OK (mkprogram gl' p.(prog_public) p.(prog_main)). - -Lemma transform_partial_program2_function: - forall p tp i tf, - transform_partial_program2 p = OK tp -> - In (i, Gfun tf) tp.(prog_defs) -> - exists f, In (i, Gfun f) p.(prog_defs) /\ transf_fun f = OK tf. -Proof. - intros. monadInv H. simpl in H0. - revert x EQ H0. induction (prog_defs p); simpl; intros. - inv EQ. contradiction. - destruct a as [id [f|v]]. - destruct (transf_fun f) as [tf1|msg] eqn:?; monadInv EQ. - simpl in H0; destruct H0. inv H. exists f; auto. - exploit IHl; eauto. intros [f' [P Q]]; exists f'; auto. - destruct (transf_globvar v) as [tv1|msg] eqn:?; monadInv EQ. - simpl in H0; destruct H0. inv H. - exploit IHl; eauto. intros [f' [P Q]]; exists f'; auto. -Qed. - -Lemma transform_partial_ident_program2_function: - forall p tp i tf, - transform_partial_ident_program2 p = OK tp -> - In (i, Gfun tf) tp.(prog_defs) -> - exists f, In (i, Gfun f) p.(prog_defs) /\ transf_fun_ident i f = OK tf. -Proof. - intros. monadInv H. simpl in H0. - revert x EQ H0. induction (prog_defs p); simpl; intros. - inv EQ. contradiction. - destruct a as [id [f|v]]. - destruct (transf_fun_ident id f) as [tf1|msg] eqn:?; monadInv EQ. - simpl in H0; destruct H0. inv H. exists f; auto. - exploit IHl; eauto. intros [f' [P Q]]; exists f'; auto. - destruct (transf_globvar_ident id v) as [tv1|msg] eqn:?; monadInv EQ. - simpl in H0; destruct H0. inv H. - exploit IHl; eauto. intros [f' [P Q]]; exists f'; auto. -Qed. - -Lemma transform_partial_program2_variable: - forall p tp i tv, - transform_partial_program2 p = OK tp -> - In (i, Gvar tv) tp.(prog_defs) -> - exists v, - In (i, Gvar(mkglobvar v tv.(gvar_init) tv.(gvar_readonly) tv.(gvar_volatile))) p.(prog_defs) - /\ transf_var v = OK tv.(gvar_info). -Proof. - intros. monadInv H. simpl in H0. - revert x EQ H0. induction (prog_defs p); simpl; intros. - inv EQ. contradiction. - destruct a as [id [f|v]]. - destruct (transf_fun f) as [tf1|msg] eqn:?; monadInv EQ. - simpl in H0; destruct H0. inv H. - exploit IHl; eauto. intros [v' [P Q]]; exists v'; auto. - destruct (transf_globvar v) as [tv1|msg] eqn:?; monadInv EQ. - simpl in H0; destruct H0. inv H. - monadInv Heqr. simpl. exists (gvar_info v). split. left. destruct v; auto. auto. - exploit IHl; eauto. intros [v' [P Q]]; exists v'; auto. -Qed. - - -Lemma transform_partial_ident_program2_variable: - forall p tp i tv, - transform_partial_ident_program2 p = OK tp -> - In (i, Gvar tv) tp.(prog_defs) -> - exists v, - In (i, Gvar(mkglobvar v tv.(gvar_init) tv.(gvar_readonly) tv.(gvar_volatile))) p.(prog_defs) - /\ transf_var_ident i v = OK tv.(gvar_info). -Proof. - intros. monadInv H. simpl in H0. - revert x EQ H0. induction (prog_defs p); simpl; intros. - inv EQ. contradiction. - destruct a as [id [f|v]]. - destruct (transf_fun_ident id f) as [tf1|msg] eqn:?; monadInv EQ. - simpl in H0; destruct H0. inv H. - exploit IHl; eauto. intros [v' [P Q]]; exists v'; auto. - destruct (transf_globvar_ident id v) as [tv1|msg] eqn:?; monadInv EQ. - simpl in H0; destruct H0. inv H. - monadInv Heqr. simpl. exists (gvar_info v). split. left. destruct v; auto. auto. - exploit IHl; eauto. intros [v' [P Q]]; exists v'; auto. -Qed. - -Lemma transform_partial_program2_succeeds: - forall p tp i g, - transform_partial_program2 p = OK tp -> - In (i, g) p.(prog_defs) -> - match g with - | Gfun fd => exists tfd, transf_fun fd = OK tfd - | Gvar gv => exists tv, transf_var gv.(gvar_info) = OK tv - end. -Proof. - intros. monadInv H. - revert x EQ H0. induction (prog_defs p); simpl; intros. - contradiction. - destruct a as [id1 g1]. destruct g1. - destruct (transf_fun f) eqn:TF; try discriminate. monadInv EQ. - destruct H0. inv H. econstructor; eauto. eapply IHl; eauto. - destruct (transf_globvar v) eqn:TV; try discriminate. monadInv EQ. - destruct H0. inv H. monadInv TV. econstructor; eauto. eapply IHl; eauto. -Qed. - -Lemma transform_partial_ident_program2_succeeds: - forall p tp i g, - transform_partial_ident_program2 p = OK tp -> - In (i, g) p.(prog_defs) -> - match g with - | Gfun fd => exists tfd, transf_fun_ident i fd = OK tfd - | Gvar gv => exists tv, transf_var_ident i gv.(gvar_info) = OK tv - end. -Proof. - intros. monadInv H. - revert x EQ H0. induction (prog_defs p); simpl; intros. - contradiction. - destruct a as [id1 g1]. destruct g1. - destruct (transf_fun_ident id1 f) eqn:TF; try discriminate. monadInv EQ. - destruct H0. inv H. econstructor; eauto. eapply IHl; eauto. - destruct (transf_globvar_ident id1 v) eqn:TV; try discriminate. monadInv EQ. - destruct H0. inv H. monadInv TV. econstructor; eauto. eapply IHl; eauto. -Qed. - -Lemma transform_partial_program2_main: - forall p tp, - transform_partial_program2 p = OK tp -> - tp.(prog_main) = p.(prog_main). -Proof. - intros. monadInv H. reflexivity. -Qed. - -Lemma transform_partial_ident_program2_main: - forall p tp, - transform_partial_ident_program2 p = OK tp -> - tp.(prog_main) = p.(prog_main). -Proof. - intros. monadInv H. reflexivity. -Qed. - -Lemma transform_partial_program2_public: - forall p tp, - transform_partial_program2 p = OK tp -> - tp.(prog_public) = p.(prog_public). -Proof. - intros. monadInv H. reflexivity. -Qed. - -Lemma transform_partial_ident_program2_public: - forall p tp, - transform_partial_ident_program2 p = OK tp -> - tp.(prog_public) = p.(prog_public). -Proof. - intros. monadInv H. reflexivity. -Qed. - -(** Additionally, we can also "augment" the program with new global definitions - and a different "main" function. *) - -Section AUGMENT. - -Variable new_globs: list(ident * globdef B W). -Variable new_main: ident. - -Definition transform_partial_augment_program (p: program A V) : res (program B W) := - do gl' <- transf_globdefs p.(prog_defs); - OK(mkprogram (gl' ++ new_globs) p.(prog_public) new_main). - -Lemma transform_partial_augment_program_main: - forall p tp, - transform_partial_augment_program p = OK tp -> - tp.(prog_main) = new_main. -Proof. - intros. monadInv H. reflexivity. -Qed. - -Definition transform_partial_augment_ident_program (p: program A V) : res (program B W) := - do gl' <- transf_globdefs_ident p.(prog_defs); - OK(mkprogram (gl' ++ new_globs) p.(prog_public) new_main). - -Lemma transform_partial_augment_ident_program_main: - forall p tp, - transform_partial_augment_ident_program p = OK tp -> - tp.(prog_main) = new_main. -Proof. - intros. monadInv H. reflexivity. -Qed. - -End AUGMENT. - -Remark transform_partial_program2_augment: - forall p, - transform_partial_program2 p = - transform_partial_augment_program nil p.(prog_main) p. -Proof. - unfold transform_partial_program2, transform_partial_augment_program; intros. - destruct (transf_globdefs (prog_defs p)); auto. - simpl. f_equal. f_equal. rewrite <- app_nil_end. auto. -Qed. - -Remark transform_partial_ident_program2_augment: - forall p, - transform_partial_ident_program2 p = - transform_partial_augment_ident_program nil p.(prog_main) p. -Proof. - unfold transform_partial_ident_program2, transform_partial_augment_ident_program; intros. - destruct (transf_globdefs_ident (prog_defs p)); auto. - simpl. f_equal. f_equal. rewrite <- app_nil_end. auto. -Qed. - End TRANSF_PROGRAM_GEN. (** The following is a special case of [transform_partial_program2], @@ -574,178 +377,26 @@ End TRANSF_PROGRAM_GEN. Section TRANSF_PARTIAL_PROGRAM. Variable A B V: Type. -Variable transf_partial: A -> res B. -Variable transf_partial_ident: ident -> A -> res B. +Variable transf_fun: A -> res B. Definition transform_partial_program (p: program A V) : res (program B V) := - transform_partial_program2 transf_partial (fun v => OK v) p. - -Definition transform_partial_ident_program (p: program A V) : res (program B V) := - transform_partial_ident_program2 transf_partial_ident (fun _ v => OK v) p. - -Lemma transform_partial_program_main: - forall p tp, - transform_partial_program p = OK tp -> - tp.(prog_main) = p.(prog_main). -Proof. - apply transform_partial_program2_main. -Qed. - -Lemma transform_partial_ident_program_main: - forall p tp, - transform_partial_ident_program p = OK tp -> - tp.(prog_main) = p.(prog_main). -Proof. - apply transform_partial_ident_program2_main. -Qed. - -Lemma transform_partial_program_public: - forall p tp, - transform_partial_program p = OK tp -> - tp.(prog_public) = p.(prog_public). -Proof. - apply transform_partial_program2_public. -Qed. - -Lemma transform_partial_ident_program_public: - forall p tp, - transform_partial_ident_program p = OK tp -> - tp.(prog_public) = p.(prog_public). -Proof. - apply transform_partial_ident_program2_public. -Qed. - -Lemma transform_partial_program_function: - forall p tp i tf, - transform_partial_program p = OK tp -> - In (i, Gfun tf) tp.(prog_defs) -> - exists f, In (i, Gfun f) p.(prog_defs) /\ transf_partial f = OK tf. -Proof. - apply transform_partial_program2_function. -Qed. - -Lemma transform_partial_ident_program_function: - forall p tp i tf, - transform_partial_ident_program p = OK tp -> - In (i, Gfun tf) tp.(prog_defs) -> - exists f, In (i, Gfun f) p.(prog_defs) /\ transf_partial_ident i f = OK tf. -Proof. - apply transform_partial_ident_program2_function. -Qed. - -Lemma transform_partial_program_succeeds: - forall p tp i fd, - transform_partial_program p = OK tp -> - In (i, Gfun fd) p.(prog_defs) -> - exists tfd, transf_partial fd = OK tfd. -Proof. - unfold transform_partial_program; intros. - exploit transform_partial_program2_succeeds; eauto. -Qed. - -Lemma transform_partial_ident_program_succeeds: - forall p tp i fd, - transform_partial_ident_program p = OK tp -> - In (i, Gfun fd) p.(prog_defs) -> - exists tfd, transf_partial_ident i fd = OK tfd. -Proof. - unfold transform_partial_ident_program; intros. - exploit transform_partial_ident_program2_succeeds; eauto. -Qed. + transform_partial_program2 (fun i f => transf_fun f) (fun i v => OK v) p. End TRANSF_PARTIAL_PROGRAM. Lemma transform_program_partial_program: - forall (A B V: Type) (transf: A -> B) (p: program A V), - transform_partial_program (fun f => OK(transf f)) p = OK(transform_program transf p). -Proof. - intros. - unfold transform_partial_program, transform_partial_program2, transform_program; intros. - replace (transf_globdefs (fun f => OK (transf f)) (fun v => OK v) p.(prog_defs)) - with (OK (map (transform_program_globdef transf) p.(prog_defs))). - auto. - induction (prog_defs p); simpl. - auto. - destruct a as [id [f|v]]; rewrite <- IHl. - auto. - destruct v; auto. -Qed. - -Lemma transform_program_partial_ident_program: - forall (A B V: Type) (transf: ident -> A -> B) (p: program A V), - transform_partial_ident_program (fun id f => OK(transf id f)) p = OK(transform_program_ident transf p). -Proof. - intros. - unfold transform_partial_ident_program, transform_partial_ident_program2, transform_program; intros. - replace (transf_globdefs_ident (fun id f => OK (transf id f)) (fun _ v => OK v) p.(prog_defs)) - with (OK (map (transform_program_globdef_ident transf) p.(prog_defs))). - auto. - induction (prog_defs p); simpl. - auto. - destruct a as [id [f|v]]; rewrite <- IHl. - auto. - destruct v; auto. -Qed. - -(** The following is a relational presentation of - [transform_partial_augment_preogram]. Given relations between function - definitions and between variable information, it defines a relation - between programs stating that the two programs have appropriately related - shapes (global names are preserved and possibly augmented, etc) - and that identically-named function definitions - and variable information are related. *) - -Section MATCH_PROGRAM. - -Variable A B V W: Type. -Variable match_fundef: A -> B -> Prop. -Variable match_varinfo: V -> W -> Prop. - -Inductive match_globdef: ident * globdef A V -> ident * globdef B W -> Prop := - | match_glob_fun: forall id f1 f2, - match_fundef f1 f2 -> - match_globdef (id, Gfun f1) (id, Gfun f2) - | match_glob_var: forall id init ro vo info1 info2, - match_varinfo info1 info2 -> - match_globdef (id, Gvar (mkglobvar info1 init ro vo)) (id, Gvar (mkglobvar info2 init ro vo)). - -Definition match_program (new_globs : list (ident * globdef B W)) - (new_main : ident) - (p1: program A V) (p2: program B W) : Prop := - (exists tglob, list_forall2 match_globdef p1.(prog_defs) tglob /\ - p2.(prog_defs) = tglob ++ new_globs) /\ - p2.(prog_main) = new_main /\ - p2.(prog_public) = p1.(prog_public). - -End MATCH_PROGRAM. - -Lemma transform_partial_augment_program_match: - forall (A B V W: Type) - (transf_fun: A -> res B) - (transf_var: V -> res W) - (p: program A V) - (new_globs : list (ident * globdef B W)) - (new_main : ident) - (tp: program B W), - transform_partial_augment_program transf_fun transf_var new_globs new_main p = OK tp -> - match_program - (fun fd tfd => transf_fun fd = OK tfd) - (fun info tinfo => transf_var info = OK tinfo) - new_globs new_main - p tp. + forall (A B V: Type) (transf_fun: A -> B) (p: program A V), + transform_partial_program (fun f => OK (transf_fun f)) p = OK (transform_program transf_fun p). Proof. - unfold transform_partial_augment_program; intros. monadInv H. - red; simpl. split; auto. exists x; split; auto. - revert x EQ. generalize (prog_defs p). induction l; simpl; intros. - monadInv EQ. constructor. - destruct a as [id [f|v]]. - (* function *) - destruct (transf_fun f) as [tf|?] eqn:?; monadInv EQ. - constructor; auto. constructor; auto. - (* variable *) - unfold transf_globvar in EQ. - destruct (transf_var (gvar_info v)) as [tinfo|?] eqn:?; simpl in EQ; monadInv EQ. - constructor; auto. destruct v; simpl in *. constructor; auto. + intros. unfold transform_partial_program, transform_partial_program2. + assert (EQ: forall l, + transf_globdefs (fun i f => OK (transf_fun f)) (fun i (v: V) => OK v) l = + OK (List.map (transform_program_globdef transf_fun) l)). + { induction l as [ | [id g] l]; simpl. + - auto. + - destruct g; simpl; rewrite IHl; simpl. auto. destruct v; auto. + } + rewrite EQ; simpl. auto. Qed. (** * External functions *) @@ -763,6 +414,9 @@ Inductive external_function : Type := | EF_builtin (name: string) (sg: signature) (** A compiler built-in function. Behaves like an external, but can be inlined by the compiler. *) + | EF_runtime (name: string) (sg: signature) + (** A function from the run-time library. Behaves like an + external, but must not be redefined. *) | EF_vload (chunk: memory_chunk) (** A volatile read operation. If the adress given as first argument points within a volatile global variable, generate an @@ -808,6 +462,7 @@ Definition ef_sig (ef: external_function): signature := match ef with | EF_external name sg => sg | EF_builtin name sg => sg + | EF_runtime name sg => sg | EF_vload chunk => mksignature (Tint :: nil) (Some (type_of_chunk chunk)) cc_default | EF_vstore chunk => mksignature (Tint :: type_of_chunk chunk :: nil) None cc_default | EF_malloc => mksignature (Tint :: nil) (Some Tint) cc_default @@ -825,6 +480,7 @@ Definition ef_inline (ef: external_function) : bool := match ef with | EF_external name sg => false | EF_builtin name sg => true + | EF_runtime name sg => false | EF_vload chunk => true | EF_vstore chunk => true | EF_malloc => false diff --git a/common/Behaviors.v b/common/Behaviors.v index 1a6b8bd6..ef99b205 100644 --- a/common/Behaviors.v +++ b/common/Behaviors.v @@ -281,31 +281,29 @@ End PROGRAM_BEHAVIORS. Section FORWARD_SIMULATIONS. -Variable L1: semantics. -Variable L2: semantics. -Variable S: forward_simulation L1 L2. +Context L1 L2 index order match_states (S: fsim_properties L1 L2 index order match_states). Lemma forward_simulation_state_behaves: forall i s1 s2 beh1, - S i s1 s2 -> state_behaves L1 s1 beh1 -> + match_states i s1 s2 -> state_behaves L1 s1 beh1 -> exists beh2, state_behaves L2 s2 beh2 /\ behavior_improves beh1 beh2. Proof. intros. inv H0. -(* termination *) +- (* termination *) exploit simulation_star; eauto. intros [i' [s2' [A B]]]. exists (Terminates t r); split. econstructor; eauto. eapply fsim_match_final_states; eauto. apply behavior_improves_refl. -(* silent divergence *) +- (* silent divergence *) exploit simulation_star; eauto. intros [i' [s2' [A B]]]. exists (Diverges t); split. econstructor; eauto. eapply simulation_forever_silent; eauto. apply behavior_improves_refl. -(* reactive divergence *) +- (* reactive divergence *) exists (Reacts T); split. econstructor. eapply simulation_forever_reactive; eauto. apply behavior_improves_refl. -(* going wrong *) +- (* going wrong *) exploit simulation_star; eauto. intros [i' [s2' [A B]]]. destruct (state_behaves_exists L2 s2') as [beh' SB]. exists (behavior_app t beh'); split. @@ -315,16 +313,19 @@ Proof. simpl. decEq. traceEq. Qed. +End FORWARD_SIMULATIONS. + Theorem forward_simulation_behavior_improves: + forall L1 L2, forward_simulation L1 L2 -> forall beh1, program_behaves L1 beh1 -> exists beh2, program_behaves L2 beh2 /\ behavior_improves beh1 beh2. Proof. - intros. inv H. -(* initial state defined *) + intros L1 L2 FS. destruct FS as [init order match_states S]. intros. inv H. +- (* initial state defined *) exploit (fsim_match_initial_states S); eauto. intros [i [s' [INIT MATCH]]]. exploit forward_simulation_state_behaves; eauto. intros [beh2 [A B]]. exists beh2; split; auto. econstructor; eauto. -(* initial state undefined *) +- (* initial state undefined *) destruct (classic (exists s', initial_state L2 s')). destruct H as [s' INIT]. destruct (state_behaves_exists L2 s') as [beh' SB]. @@ -336,6 +337,7 @@ Proof. Qed. Corollary forward_simulation_same_safe_behavior: + forall L1 L2, forward_simulation L1 L2 -> forall beh, program_behaves L1 beh -> not_wrong beh -> program_behaves L2 beh. @@ -343,18 +345,14 @@ Proof. intros. exploit forward_simulation_behavior_improves; eauto. intros [beh' [A B]]. destruct B. congruence. - destruct H1 as [t [C D]]. subst. contradiction. + destruct H2 as [t [C D]]. subst. contradiction. Qed. -End FORWARD_SIMULATIONS. - (** * Backward simulations and program behaviors *) Section BACKWARD_SIMULATIONS. -Variable L1: semantics. -Variable L2: semantics. -Variable S: backward_simulation L1 L2. +Context L1 L2 index order match_states (S: bsim_properties L1 L2 index order match_states). Definition safe_along_behavior (s: state L1) (b: program_behavior) : Prop := forall t1 s' b2, Star L1 s t1 s' -> b = behavior_app t1 b2 -> @@ -402,8 +400,8 @@ Qed. Lemma backward_simulation_star: forall s2 t s2', Star L2 s2 t s2' -> - forall i s1 b, S i s1 s2 -> safe_along_behavior s1 (behavior_app t b) -> - exists i', exists s1', Star L1 s1 t s1' /\ S i' s1' s2'. + forall i s1 b, match_states i s1 s2 -> safe_along_behavior s1 (behavior_app t b) -> + exists i', exists s1', Star L1 s1 t s1' /\ match_states i' s1' s2'. Proof. induction 1; intros. exists i; exists s1; split; auto. apply star_refl. @@ -418,12 +416,12 @@ Qed. Lemma backward_simulation_forever_silent: forall i s1 s2, - Forever_silent L2 s2 -> S i s1 s2 -> safe L1 s1 -> + Forever_silent L2 s2 -> match_states i s1 s2 -> safe L1 s1 -> Forever_silent L1 s1. Proof. assert (forall i s1 s2, - Forever_silent L2 s2 -> S i s1 s2 -> safe L1 s1 -> - forever_silent_N (step L1) (bsim_order S) (globalenv L1) i s1). + Forever_silent L2 s2 -> match_states i s1 s2 -> safe L1 s1 -> + forever_silent_N (step L1) order (globalenv L1) i s1). cofix COINDHYP; intros. inv H. destruct (bsim_simulation S _ _ _ H2 _ H0 H1) as [i' [s2' [A B]]]. destruct A as [C | [C D]]. @@ -431,29 +429,29 @@ Proof. eapply star_safe; eauto. apply plus_star; auto. eapply forever_silent_N_star; eauto. eapply COINDHYP; eauto. eapply star_safe; eauto. - intros. eapply forever_silent_N_forever; eauto. apply bsim_order_wf. + intros. eapply forever_silent_N_forever; eauto. eapply bsim_order_wf; eauto. Qed. Lemma backward_simulation_forever_reactive: forall i s1 s2 T, - Forever_reactive L2 s2 T -> S i s1 s2 -> safe_along_behavior s1 (Reacts T) -> + Forever_reactive L2 s2 T -> match_states i s1 s2 -> safe_along_behavior s1 (Reacts T) -> Forever_reactive L1 s1 T. Proof. cofix COINDHYP; intros. inv H. - destruct (backward_simulation_star H2 _ (Reacts T0) H0) as [i' [s1' [A B]]]; eauto. + destruct (backward_simulation_star H2 (Reacts T0) H0) as [i' [s1' [A B]]]; eauto. econstructor; eauto. eapply COINDHYP; eauto. eapply star_safe_along; eauto. Qed. Lemma backward_simulation_state_behaves: forall i s1 s2 beh2, - S i s1 s2 -> state_behaves L2 s2 beh2 -> + match_states i s1 s2 -> state_behaves L2 s2 beh2 -> exists beh1, state_behaves L1 s1 beh1 /\ behavior_improves beh1 beh2. Proof. intros. destruct (classic (safe_along_behavior s1 beh2)). -(* 1. Safe along *) +- (* 1. Safe along *) exists beh2; split; [idtac|apply behavior_improves_refl]. inv H0. -(* termination *) ++ (* termination *) assert (Terminates t r = behavior_app t (Terminates E0 r)). simpl. rewrite E0_right; auto. rewrite H0 in H1. @@ -463,7 +461,7 @@ Proof. eapply safe_along_safe. eapply star_safe_along; eauto. intros [s1'' [C D]]. econstructor. eapply star_trans; eauto. traceEq. auto. -(* silent divergence *) ++ (* silent divergence *) assert (Diverges t = behavior_app t (Diverges E0)). simpl. rewrite E0_right; auto. rewrite H0 in H1. @@ -471,9 +469,9 @@ Proof. intros [i' [s1' [A B]]]. econstructor. eauto. eapply backward_simulation_forever_silent; eauto. eapply safe_along_safe. eapply star_safe_along; eauto. -(* reactive divergence *) ++ (* reactive divergence *) econstructor. eapply backward_simulation_forever_reactive; eauto. -(* goes wrong *) ++ (* goes wrong *) assert (Goes_wrong t = behavior_app t (Goes_wrong E0)). simpl. rewrite E0_right; auto. rewrite H0 in H1. @@ -484,7 +482,7 @@ Proof. elim (H4 _ FIN). elim (H3 _ _ STEP2). -(* 2. Not safe along *) +- (* 2. Not safe along *) exploit not_safe_along_behavior; eauto. intros [t [s1' [PREF [STEPS [NOSTEP NOFIN]]]]]. exists (Goes_wrong t); split. @@ -492,23 +490,26 @@ Proof. right. exists t; auto. Qed. +End BACKWARD_SIMULATIONS. + Theorem backward_simulation_behavior_improves: + forall L1 L2, backward_simulation L1 L2 -> forall beh2, program_behaves L2 beh2 -> exists beh1, program_behaves L1 beh1 /\ behavior_improves beh1 beh2. Proof. - intros. inv H. -(* L2's initial state is defined. *) + intros L1 L2 S beh2 H. destruct S as [index order match_states S]. inv H. +- (* L2's initial state is defined. *) destruct (classic (exists s1, initial_state L1 s1)) as [[s1 INIT] | NOINIT]. -(* L1's initial state is defined too. *) ++ (* L1's initial state is defined too. *) exploit (bsim_match_initial_states S); eauto. intros [i [s1' [INIT1' MATCH]]]. exploit backward_simulation_state_behaves; eauto. intros [beh1 [A B]]. exists beh1; split; auto. econstructor; eauto. -(* L1 has no initial state *) ++ (* L1 has no initial state *) exists (Goes_wrong E0); split. apply program_goes_initially_wrong. intros; red; intros. elim NOINIT; exists s0; auto. apply behavior_improves_bot. -(* L2 has no initial state *) +- (* L2 has no initial state *) exists (Goes_wrong E0); split. apply program_goes_initially_wrong. intros; red; intros. @@ -518,17 +519,16 @@ Proof. Qed. Corollary backward_simulation_same_safe_behavior: + forall L1 L2, backward_simulation L1 L2 -> (forall beh, program_behaves L1 beh -> not_wrong beh) -> (forall beh, program_behaves L2 beh -> program_behaves L1 beh). Proof. intros. exploit backward_simulation_behavior_improves; eauto. intros [beh' [A B]]. destruct B. congruence. - destruct H1 as [t [C D]]. subst. elim (H (Goes_wrong t)). auto. + destruct H2 as [t [C D]]. subst. elim (H0 (Goes_wrong t)). auto. Qed. -End BACKWARD_SIMULATIONS. - (** * Program behaviors for the "atomic" construction *) Section ATOMIC. @@ -635,7 +635,7 @@ Theorem atomic_behaviors: forall beh, program_behaves L beh <-> program_behaves (atomic L) beh. Proof. intros; split; intros. - (* L -> atomic L *) +- (* L -> atomic L *) exploit forward_simulation_behavior_improves. eapply atomic_forward_simulation. eauto. intros [beh2 [A B]]. red in B. destruct B as [EQ | [t [C D]]]. congruence. @@ -646,23 +646,23 @@ Proof. intros; red; intros. simpl in H. destruct H. eelim H4; eauto. apply program_goes_initially_wrong. intros; red; intros. simpl in H; destruct H. eelim H1; eauto. - (* atomic L -> L *) +- (* atomic L -> L *) inv H. - (* initial state defined *) ++ (* initial state defined *) destruct s as [t s]. simpl in H0. destruct H0; subst t. apply program_runs with s; auto. inv H1. - (* termination *) +* (* termination *) destruct s' as [t' s']. simpl in H2; destruct H2; subst t'. econstructor. eapply atomic_star_star; eauto. auto. - (* silent divergence *) +* (* silent divergence *) destruct s' as [t' s']. assert (t' = E0). inv H2. inv H1; auto. subst t'. econstructor. eapply atomic_star_star; eauto. change s' with (snd (E0,s')). apply atomic_forever_silent_forever_silent. auto. - (* reactive divergence *) +* (* reactive divergence *) econstructor. apply atomic_forever_reactive_forever_reactive. auto. - (* going wrong *) +* (* going wrong *) destruct s' as [t' s']. assert (t' = E0). destruct t'; auto. eelim H2. simpl. apply atomic_step_continue. @@ -672,7 +672,7 @@ Proof. elim (H2 E0 (E0,s'0)). constructor; auto. elim (H2 (e::nil) (t0,s'0)). constructor; auto. intros; red; intros. elim (H3 r). simpl; auto. - (* initial state undefined *) ++ (* initial state undefined *) apply program_goes_initially_wrong. intros; red; intros. elim (H0 (E0,s)); simpl; auto. Qed. diff --git a/common/Events.v b/common/Events.v index 7029a984..040029fb 100644 --- a/common/Events.v +++ b/common/Events.v @@ -619,9 +619,7 @@ Record extcall_properties (sem: extcall_sem) (sg: signature) : Prop := (** The semantics is invariant under change of global environment that preserves symbols. *) ec_symbols_preserved: forall ge1 ge2 vargs m1 t vres m2, - (forall id, Senv.find_symbol ge2 id = Senv.find_symbol ge1 id) -> - (forall id, Senv.public_symbol ge2 id = Senv.public_symbol ge1 id) -> - (forall b, Senv.block_is_volatile ge2 b = Senv.block_is_volatile ge1 b) -> + Senv.equiv ge1 ge2 -> sem ge1 vargs m1 t vres m2 -> sem ge2 vargs m1 t vres m2; @@ -704,17 +702,15 @@ Inductive volatile_load_sem (chunk: memory_chunk) (ge: Senv.t): Lemma volatile_load_preserved: forall ge1 ge2 chunk m b ofs t v, - (forall id, Senv.find_symbol ge2 id = Senv.find_symbol ge1 id) -> - (forall id, Senv.public_symbol ge2 id = Senv.public_symbol ge1 id) -> - (forall b, Senv.block_is_volatile ge2 b = Senv.block_is_volatile ge1 b) -> + Senv.equiv ge1 ge2 -> volatile_load ge1 chunk m b ofs t v -> volatile_load ge2 chunk m b ofs t v. Proof. - intros. inv H2; constructor; auto. - rewrite H1; auto. - rewrite H; auto. + intros. destruct H as (A & B & C). inv H0; constructor; auto. + rewrite C; auto. + rewrite A; auto. eapply eventval_match_preserved; eauto. - rewrite H1; auto. + rewrite C; auto. Qed. Lemma volatile_load_extends: @@ -773,7 +769,7 @@ Proof. - unfold proj_sig_res; simpl. inv H. inv H0. apply Val.load_result_type. eapply Mem.load_type; eauto. (* symbols *) -- inv H2. constructor. eapply volatile_load_preserved; eauto. +- inv H0. constructor. eapply volatile_load_preserved; eauto. (* valid blocks *) - inv H; auto. (* max perms *) @@ -817,17 +813,15 @@ Inductive volatile_store_sem (chunk: memory_chunk) (ge: Senv.t): Lemma volatile_store_preserved: forall ge1 ge2 chunk m1 b ofs v t m2, - (forall id, Senv.find_symbol ge2 id = Senv.find_symbol ge1 id) -> - (forall id, Senv.public_symbol ge2 id = Senv.public_symbol ge1 id) -> - (forall b, Senv.block_is_volatile ge2 b = Senv.block_is_volatile ge1 b) -> + Senv.equiv ge1 ge2 -> volatile_store ge1 chunk m1 b ofs v t m2 -> volatile_store ge2 chunk m1 b ofs v t m2. Proof. - intros. inv H2; constructor; auto. - rewrite H1; auto. - rewrite H; auto. + intros. destruct H as (A & B & C). inv H0; constructor; auto. + rewrite C; auto. + rewrite A; auto. eapply eventval_match_preserved; eauto. - rewrite H1; auto. + rewrite C; auto. Qed. Lemma volatile_store_readonly: @@ -925,7 +919,7 @@ Proof. (* well typed *) - unfold proj_sig_res; simpl. inv H; constructor. (* symbols preserved *) -- inv H2. constructor. eapply volatile_store_preserved; eauto. +- inv H0. constructor. eapply volatile_store_preserved; eauto. (* valid block *) - inv H. inv H1. auto. eauto with mem. (* perms *) @@ -972,19 +966,18 @@ Proof. Mem.store Mint32 m' b (-4) (Vint n) = Some m'' -> Mem.unchanged_on P m m''). { - intros; constructor; intros. - - split; intros; eauto with mem. - - assert (b0 <> b) by (eapply Mem.valid_not_valid_diff; eauto with mem). - erewrite Mem.store_mem_contents; eauto. rewrite Maps.PMap.gso by auto. - Local Transparent Mem.alloc. unfold Mem.alloc in H. injection H; intros A B. - rewrite <- B; simpl. rewrite A. rewrite Maps.PMap.gso by auto. auto. + intros. + apply Mem.unchanged_on_implies with (fun b1 ofs1 => b1 <> b). + apply Mem.unchanged_on_trans with m'. + eapply Mem.alloc_unchanged_on; eauto. + eapply Mem.store_unchanged_on; eauto. + intros. eapply Mem.valid_not_valid_diff; eauto with mem. } - constructor; intros. (* well typed *) - inv H. unfold proj_sig_res; simpl. auto. (* symbols preserved *) -- inv H2; econstructor; eauto. +- inv H0; econstructor; eauto. (* valid block *) - inv H. eauto with mem. (* perms *) @@ -1045,7 +1038,7 @@ Proof. (* well typed *) - inv H. unfold proj_sig_res. simpl. auto. (* symbols preserved *) -- inv H2; econstructor; eauto. +- inv H0; econstructor; eauto. (* valid block *) - inv H. eauto with mem. (* perms *) @@ -1124,7 +1117,7 @@ Proof. - (* return type *) intros. inv H. constructor. - (* change of globalenv *) - intros. inv H2. econstructor; eauto. + intros. inv H0. econstructor; eauto. - (* valid blocks *) intros. inv H. eauto with mem. - (* perms *) @@ -1235,7 +1228,7 @@ Proof. (* well typed *) - inv H. simpl. auto. (* symbols *) -- inv H2. econstructor; eauto. +- destruct H as (A & B & C). inv H0. econstructor; eauto. eapply eventval_list_match_preserved; eauto. (* valid blocks *) - inv H; auto. @@ -1280,7 +1273,7 @@ Proof. (* well typed *) - inv H. unfold proj_sig_res; simpl. eapply eventval_match_type; eauto. (* symbols *) -- inv H2. econstructor; eauto. +- destruct H as (A & B & C). inv H0. econstructor; eauto. eapply eventval_match_preserved; eauto. (* valid blocks *) - inv H; auto. @@ -1324,7 +1317,7 @@ Proof. (* well typed *) - inv H. simpl. auto. (* symbols *) -- inv H2. econstructor; eauto. +- inv H0. econstructor; eauto. (* valid blocks *) - inv H; auto. (* perms *) @@ -1351,8 +1344,9 @@ Qed. (** ** Semantics of external functions. *) -(** For functions defined outside the program ([EF_external] and [EF_builtin]), - we do not define their semantics, but only assume that it satisfies +(** For functions defined outside the program ([EF_external], + [EF_builtin] and [EF_runtime]), we do not define their + semantics, but only assume that it satisfies [extcall_properties]. *) Parameter external_functions_sem: String.string -> signature -> extcall_sem. @@ -1384,6 +1378,7 @@ Definition external_call (ef: external_function): extcall_sem := match ef with | EF_external name sg => external_functions_sem name sg | EF_builtin name sg => external_functions_sem name sg + | EF_runtime name sg => external_functions_sem name sg | EF_vload chunk => volatile_load_sem chunk | EF_vstore chunk => volatile_store_sem chunk | EF_malloc => extcall_malloc_sem @@ -1402,6 +1397,7 @@ Proof. intros. unfold external_call, ef_sig; destruct ef. apply external_functions_properties. apply external_functions_properties. + apply external_functions_properties. apply volatile_load_ok. apply volatile_store_ok. apply extcall_malloc_ok. @@ -1414,7 +1410,7 @@ Proof. Qed. Definition external_call_well_typed ef := ec_well_typed (external_call_spec ef). -Definition external_call_symbols_preserved_gen ef := ec_symbols_preserved (external_call_spec ef). +Definition external_call_symbols_preserved ef := ec_symbols_preserved (external_call_spec ef). Definition external_call_valid_block ef := ec_valid_block (external_call_spec ef). Definition external_call_max_perm ef := ec_max_perm (external_call_spec ef). Definition external_call_readonly ef := ec_readonly (external_call_spec ef). @@ -1424,20 +1420,6 @@ Definition external_call_trace_length ef := ec_trace_length (external_call_spec Definition external_call_receptive ef := ec_receptive (external_call_spec ef). Definition external_call_determ ef := ec_determ (external_call_spec ef). -(** Special cases of [external_call_symbols_preserved_gen]. *) - -Lemma external_call_symbols_preserved: - forall ef F1 F2 V (ge1: Genv.t F1 V) (ge2: Genv.t F2 V) vargs m1 t vres m2, - external_call ef ge1 vargs m1 t vres m2 -> - (forall id, Genv.find_symbol ge2 id = Genv.find_symbol ge1 id) -> - (forall id, Genv.public_symbol ge2 id = Genv.public_symbol ge1 id) -> - (forall b, Genv.find_var_info ge2 b = Genv.find_var_info ge1 b) -> - external_call ef ge2 vargs m1 t vres m2. -Proof. - intros. apply external_call_symbols_preserved_gen with (ge1 := ge1); auto. - intros. simpl. unfold Genv.block_is_volatile. rewrite H2. auto. -Qed. - (** Corollary of [external_call_valid_block]. *) Lemma external_call_nextblock: @@ -1596,9 +1578,7 @@ Qed. Lemma external_call_symbols_preserved': forall ef F1 F2 V (ge1: Genv.t F1 V) (ge2: Genv.t F2 V) vargs m1 t vres m2, external_call' ef ge1 vargs m1 t vres m2 -> - (forall id, Genv.find_symbol ge2 id = Genv.find_symbol ge1 id) -> - (forall id, Genv.public_symbol ge2 id = Genv.public_symbol ge1 id) -> - (forall b, Genv.find_var_info ge2 b = Genv.find_var_info ge1 b) -> + Senv.equiv ge1 ge2 -> external_call' ef ge2 vargs m1 t vres m2. Proof. intros. inv H. exists v; auto. eapply external_call_symbols_preserved; eauto. diff --git a/common/Globalenvs.v b/common/Globalenvs.v index 5f78ea6b..a8d0512c 100644 --- a/common/Globalenvs.v +++ b/common/Globalenvs.v @@ -3,7 +3,6 @@ (* The Compcert verified compiler *) (* *) (* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* with contributions from Andrew Tolmach (Portland State University) *) (* *) (* Copyright Institut National de Recherche en Informatique et en *) (* Automatique. All rights reserved. This file is distributed *) @@ -36,14 +35,8 @@ Require Recdef. Require Import Zwf. -Require Import Coqlib. -Require Import Errors. -Require Import Maps. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import Memory. +Require Import Axioms Coqlib Errors Maps AST Linking. +Require Import Integers Floats Values Memory. 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. @@ -113,6 +106,11 @@ Proof. intros. unfold symbol_address. destruct (find_symbol ge id); auto. Qed. +Definition equiv (se1 se2: t) : Prop := + (forall id, find_symbol se2 id = find_symbol se1 id) + /\ (forall id, public_symbol se2 id = public_symbol se1 id) + /\ (forall b, block_is_volatile se2 b = block_is_volatile se1 b). + End Senv. Module Genv. @@ -129,14 +127,10 @@ Variable V: Type. (**r The type of information attached to variables *) Record t: Type := mkgenv { genv_public: list ident; (**r which symbol names are public *) genv_symb: PTree.t block; (**r mapping symbol -> block *) - genv_funs: PTree.t F; (**r mapping function pointer -> definition *) - genv_vars: PTree.t (globvar V); (**r mapping variable pointer -> info *) + genv_defs: PTree.t (globdef F V); (**r mapping block -> definition *) genv_next: block; (**r next symbol pointer *) genv_symb_range: forall id b, PTree.get id genv_symb = Some b -> Plt b genv_next; - genv_funs_range: forall b f, PTree.get b genv_funs = Some f -> Plt b genv_next; - genv_vars_range: forall b v, PTree.get b genv_vars = Some v -> Plt b genv_next; - genv_funs_vars: forall b1 b2 f v, - PTree.get b1 genv_funs = Some f -> PTree.get b2 genv_vars = Some v -> b1 <> b2; + genv_defs_range: forall b g, PTree.get b genv_defs = Some g -> Plt b genv_next; genv_vars_inj: forall id1 id2 b, PTree.get id1 genv_symb = Some b -> PTree.get id2 genv_symb = Some b -> id1 = id2 }. @@ -166,11 +160,16 @@ Definition public_symbol (ge: t) (id: ident) : bool := | Some _ => In_dec ident_eq id ge.(genv_public) end. +(** [find_def ge b] returns the global definition associated with the given address. *) + +Definition find_def (ge: t) (b: block) : option (globdef F V) := + PTree.get b ge.(genv_defs). + (** [find_funct_ptr ge b] returns the function description associated with the given address. *) Definition find_funct_ptr (ge: t) (b: block) : option F := - PTree.get b ge.(genv_funs). + match find_def ge b with Some (Gfun f) => Some f | _ => None end. (** [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. *) @@ -192,7 +191,7 @@ Definition invert_symbol (ge: t) (b: block) : option ident := at address [b]. *) Definition find_var_info (ge: t) (b: block) : option (globvar V) := - PTree.get b ge.(genv_vars). + match find_def ge b with Some (Gvar v) => Some v | _ => None end. (** [block_is_volatile ge b] returns [true] if [b] points to a global variable of volatile type, [false] otherwise. *) @@ -209,16 +208,9 @@ Program Definition add_global (ge: t) (idg: ident * globdef F V) : t := @mkgenv ge.(genv_public) (PTree.set idg#1 ge.(genv_next) ge.(genv_symb)) - (match idg#2 with - | Gfun f => PTree.set ge.(genv_next) f ge.(genv_funs) - | Gvar v => ge.(genv_funs) - end) - (match idg#2 with - | Gfun f => ge.(genv_vars) - | Gvar v => PTree.set ge.(genv_next) v ge.(genv_vars) - end) + (PTree.set ge.(genv_next) idg#2 ge.(genv_defs)) (Psucc ge.(genv_next)) - _ _ _ _ _. + _ _ _. Next Obligation. destruct ge; simpl in *. rewrite PTree.gsspec in H. destruct (peq id i). inv H. apply Plt_succ. @@ -226,34 +218,12 @@ Next Obligation. Qed. Next Obligation. destruct ge; simpl in *. - destruct g. - rewrite PTree.gsspec in H. - destruct (peq b genv_next0). inv H. apply Plt_succ. - apply Plt_trans_succ; eauto. + rewrite PTree.gsspec in H. destruct (peq b genv_next0). + inv H. apply Plt_succ. apply Plt_trans_succ; eauto. Qed. Next Obligation. destruct ge; simpl in *. - destruct g. - apply Plt_trans_succ; eauto. - rewrite PTree.gsspec in H. - destruct (peq b genv_next0). inv H. apply Plt_succ. - apply Plt_trans_succ; eauto. -Qed. -Next Obligation. - destruct ge; simpl in *. - destruct g. - rewrite PTree.gsspec in H. - destruct (peq b1 genv_next0). inv H. - apply sym_not_equal; apply Plt_ne; eauto. - eauto. - rewrite PTree.gsspec in H0. - destruct (peq b2 genv_next0). inv H0. - apply Plt_ne; eauto. - eauto. -Qed. -Next Obligation. - destruct ge; simpl in *. rewrite PTree.gsspec in H. rewrite PTree.gsspec in H0. destruct (peq id1 i); destruct (peq id2 i). congruence. @@ -269,17 +239,11 @@ Lemma add_globals_app: forall gl2 gl1 ge, add_globals ge (gl1 ++ gl2) = add_globals (add_globals ge gl1) gl2. Proof. - induction gl1; simpl; intros. auto. rewrite IHgl1; auto. + intros. apply fold_left_app. Qed. Program Definition empty_genv (pub: list ident): t := - @mkgenv pub (PTree.empty _) (PTree.empty _) (PTree.empty _) 1%positive _ _ _ _ _. -Next Obligation. - rewrite PTree.gempty in H. discriminate. -Qed. -Next Obligation. - rewrite PTree.gempty in H. discriminate. -Qed. + @mkgenv pub (PTree.empty _) (PTree.empty _) 1%positive _ _ _. Next Obligation. rewrite PTree.gempty in H. discriminate. Qed. @@ -400,84 +364,62 @@ Proof. intros; simpl. apply dec_eq_true. Qed. -Theorem find_symbol_exists: - forall p id g, - In (id, g) (prog_defs p) -> - exists b, find_symbol (globalenv p) id = Some b. +Theorem find_funct_ptr_iff: + forall ge b f, find_funct_ptr ge b = Some f <-> find_def ge b = Some (Gfun f). Proof. - intros. unfold globalenv. eapply add_globals_ensures; eauto. -(* preserves *) - intros. unfold find_symbol; simpl. rewrite PTree.gsspec. destruct (peq id id0). - econstructor; eauto. - auto. -(* ensures *) - intros. unfold find_symbol; simpl. rewrite PTree.gss. econstructor; eauto. + intros. unfold find_funct_ptr. destruct (find_def ge b) as [[f1|v1]|]; intuition congruence. Qed. -Theorem find_funct_ptr_exists_2: - forall p gl1 id f gl2, - prog_defs p = gl1 ++ (id, Gfun f) :: gl2 -> ~In id (map fst gl2) -> - exists b, - find_symbol (globalenv p) id = Some b - /\ find_funct_ptr (globalenv p) b = Some f. +Theorem find_var_info_iff: + forall ge b v, find_var_info ge b = Some v <-> find_def ge b = Some (Gvar v). Proof. - intros; unfold globalenv. rewrite H. eapply add_globals_unique_ensures; eauto. -(* preserves *) - intros. unfold find_symbol, find_funct_ptr in *; simpl. - destruct H1 as [b [A B]]. exists b; split. - rewrite PTree.gso; auto. - destruct g1 as [f1 | v1]. rewrite PTree.gso. auto. - apply Plt_ne. eapply genv_funs_range; eauto. - auto. -(* ensures *) - intros. unfold find_symbol, find_funct_ptr in *; simpl. - exists (genv_next ge); split. apply PTree.gss. apply PTree.gss. + intros. unfold find_var_info. destruct (find_def ge b) as [[f1|v1]|]; intuition congruence. Qed. -Corollary find_funct_ptr_exists: - forall p id f, - list_norepet (prog_defs_names p) -> - In (id, Gfun f) (prog_defs p) -> - exists b, - find_symbol (globalenv p) id = Some b - /\ find_funct_ptr (globalenv p) b = Some f. +Theorem find_def_symbol: + forall p id g, + (prog_defmap p)!id = Some g <-> exists b, find_symbol (globalenv p) id = Some b /\ find_def (globalenv p) b = Some g. Proof. - intros. exploit in_norepet_unique; eauto. intros (gl1 & gl2 & X & Y). - eapply find_funct_ptr_exists_2; eauto. + intros. + set (P := fun m ge => m!id = Some g <-> exists b, find_symbol ge id = Some b /\ find_def ge b = Some g). + assert (REC: forall l m ge, + P m ge -> + P (fold_left (fun m idg => PTree.set idg#1 idg#2 m) l m) + (add_globals ge l)). + { induction l as [ | [id1 g1] l]; intros; simpl. + - auto. + - apply IHl. unfold P, add_global, find_symbol, find_def; simpl. + rewrite ! PTree.gsspec. destruct (peq id id1). + + subst id1. split; intros. + inv H0. exists (genv_next ge); split; auto. apply PTree.gss. + destruct H0 as (b & A & B). inv A. rewrite PTree.gss in B. auto. + + red in H; rewrite H. split. + intros (b & A & B). exists b; split; auto. rewrite PTree.gso; auto. + apply Plt_ne. eapply genv_symb_range; eauto. + intros (b & A & B). rewrite PTree.gso in B. exists b; auto. + apply Plt_ne. eapply genv_symb_range; eauto. + } + apply REC. unfold P, find_symbol, find_def; simpl. + rewrite ! PTree.gempty. split. + congruence. + intros (b & A & B); congruence. Qed. -Theorem find_var_exists_2: - forall p gl1 id v gl2, - prog_defs p = gl1 ++ (id, Gvar v) :: gl2 -> ~In id (map fst gl2) -> - exists b, - find_symbol (globalenv p) id = Some b - /\ find_var_info (globalenv p) b = Some v. +Theorem find_symbol_exists: + forall p id g, + In (id, g) (prog_defs p) -> + exists b, find_symbol (globalenv p) id = Some b. Proof. - intros; unfold globalenv. rewrite H. eapply add_globals_unique_ensures; eauto. + intros. unfold globalenv. eapply add_globals_ensures; eauto. (* preserves *) - intros. unfold find_symbol, find_var_info in *; simpl. - destruct H1 as [b [A B]]. exists b; split. - rewrite PTree.gso; auto. - destruct g1 as [f1 | v1]. auto. rewrite PTree.gso. auto. - apply Plt_ne. eapply genv_vars_range; eauto. + intros. unfold find_symbol; simpl. rewrite PTree.gsspec. destruct (peq id id0). + econstructor; eauto. + auto. (* ensures *) - intros. unfold find_symbol, find_var_info in *; simpl. - exists (genv_next ge); split. apply PTree.gss. apply PTree.gss. -Qed. - -Corollary find_var_exists: - forall p id v, - list_norepet (prog_defs_names p) -> - In (id, Gvar v) (prog_defs p) -> - exists b, - find_symbol (globalenv p) id = Some b - /\ find_var_info (globalenv p) b = Some v. -Proof. - intros. exploit in_norepet_unique; eauto. intros (gl1 & gl2 & X & Y). - eapply find_var_exists_2; eauto. + intros. unfold find_symbol; simpl. rewrite PTree.gss. econstructor; eauto. Qed. -Lemma find_symbol_inversion : forall p x b, +Theorem find_symbol_inversion : forall p x b, find_symbol (globalenv p) x = Some b -> In x (prog_defs_names p). Proof. @@ -490,22 +432,30 @@ Proof. unfold find_symbol; simpl; intros. rewrite PTree.gempty in H. discriminate. Qed. -Theorem find_funct_ptr_inversion: - forall p b f, - find_funct_ptr (globalenv p) b = Some f -> - exists id, In (id, Gfun f) (prog_defs p). +Theorem find_def_inversion: + forall p b g, + find_def (globalenv p) b = Some g -> + exists id, In (id, g) (prog_defs p). Proof. - intros until f. unfold globalenv. apply add_globals_preserves. + intros until g. unfold globalenv. apply add_globals_preserves. (* preserves *) - unfold find_funct_ptr; simpl; intros. destruct g; auto. + unfold find_def; simpl; intros. rewrite PTree.gsspec in H1. destruct (peq b (genv_next ge)). inv H1. exists id; auto. auto. (* base *) - unfold find_funct_ptr; simpl; intros. rewrite PTree.gempty in H. discriminate. + unfold find_def; simpl; intros. rewrite PTree.gempty in H. discriminate. Qed. -Theorem find_funct_inversion: +Corollary find_funct_ptr_inversion: + forall p b f, + find_funct_ptr (globalenv p) b = Some f -> + exists id, In (id, Gfun f) (prog_defs p). +Proof. + intros. apply find_def_inversion with b. apply find_funct_ptr_iff; auto. +Qed. + +Corollary find_funct_inversion: forall p v f, find_funct (globalenv p) v = Some f -> exists id, In (id, Gfun f) (prog_defs p). @@ -533,25 +483,6 @@ Proof. intros. exploit find_funct_inversion; eauto. intros [id IN]. eauto. 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, Gfun f) p.(prog_defs). -Proof. - intros until f. unfold globalenv, find_symbol, find_funct_ptr. apply add_globals_preserves. -(* preserves *) - intros. simpl in *. rewrite PTree.gsspec in H1. destruct (peq id id0). - inv H1. destruct g as [f1|v1]. rewrite PTree.gss in H2. inv H2. auto. - eelim Plt_strict. eapply genv_funs_range; eauto. - destruct g as [f1|v1]. rewrite PTree.gso in H2. auto. - apply Plt_ne. eapply genv_symb_range; eauto. - auto. -(* initial *) - intros. simpl in *. rewrite PTree.gempty in H. discriminate. -Qed. - - Theorem global_addresses_distinct: forall ge id1 id2 b1 b2, id1 <> id2 -> @@ -626,7 +557,7 @@ Theorem block_is_volatile_below: forall ge b, block_is_volatile ge b = true -> Plt b ge.(genv_next). Proof. unfold block_is_volatile; intros. destruct (find_var_info ge b) as [gv|] eqn:FV. - eapply genv_vars_range; eauto. + rewrite find_var_info_iff in FV. eapply genv_defs_range; eauto. discriminate. Qed. @@ -652,24 +583,6 @@ 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_int64 _ => 8 - | 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) @@ -697,12 +610,6 @@ Fixpoint store_init_data_list (m: mem) (b: block) (p: Z) (idl: list init_data) 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 perm_globvar (gv: globvar V) : permission := if gv.(gvar_volatile) then Nonempty else if gv.(gvar_readonly) then Readable @@ -818,22 +725,32 @@ Proof. congruence. Qed. -Remark store_init_data_list_perm: - forall k prm b' q idl b m p m', - store_init_data_list m b p idl = Some m' -> +Remark store_init_data_perm: + forall k prm b' q i b m p m', + store_init_data m b p i = Some m' -> (Mem.perm m b' q k prm <-> Mem.perm m' b' q k prm). Proof. - induction idl; simpl; intros until m'. - intros. inv H. tauto. - caseEq (store_init_data m b p a); try congruence. intros. - rewrite <- (IHidl _ _ _ _ H0). + intros. assert (forall chunk v, - Mem.store chunk m b p v = Some m0 -> - (Mem.perm m b' q k prm <-> Mem.perm m0 b' q k prm)). + Mem.store chunk m b p v = Some m' -> + (Mem.perm m b' q k prm <-> Mem.perm m' b' q k prm)). intros; split; eauto with mem. - destruct a; simpl in H; eauto. + destruct i; simpl in H; eauto. inv H; tauto. - destruct (find_symbol ge i). eauto. discriminate. + destruct (find_symbol ge i); try discriminate. eauto. +Qed. + +Remark store_init_data_list_perm: + forall k prm b' q idl b m p m', + store_init_data_list m b p idl = Some m' -> + (Mem.perm m b' q k prm <-> Mem.perm m' b' q k prm). +Proof. + induction idl as [ | i1 idl]; simpl; intros. +- inv H; tauto. +- destruct (store_init_data m b p i1) as [m1|] eqn:S1; try discriminate. + transitivity (Mem.perm m1 b' q k prm). + eapply store_init_data_perm; eauto. + eapply IHidl; eauto. Qed. Remark alloc_global_perm: @@ -883,36 +800,146 @@ Qed. (** Data preservation properties *) -Remark store_zeros_load_outside: - forall m b p n m', +Remark store_zeros_unchanged: + forall (P: block -> Z -> Prop) m b p n m', store_zeros m b p n = Some m' -> - forall chunk b' p', - b' <> b \/ p' + size_chunk chunk <= p \/ p + n <= p' -> - Mem.load chunk m' b' p' = Mem.load chunk m b' p'. + (forall i, p <= i < p + n -> ~ P b i) -> + Mem.unchanged_on P m m'. Proof. intros until n. functional induction (store_zeros m b p n); intros. - inv H; auto. - transitivity (Mem.load chunk m' b' p'). - apply IHo. auto. intuition omega. - eapply Mem.load_store_other; eauto. simpl. intuition omega. - discriminate. +- inv H; apply Mem.unchanged_on_refl. +- apply Mem.unchanged_on_trans with m'. ++ eapply Mem.store_unchanged_on; eauto. simpl. intros. apply H0. omega. ++ apply IHo; auto. intros; apply H0; omega. +- discriminate. +Qed. + +Remark store_init_data_unchanged: + forall (P: block -> Z -> Prop) b i m p m', + store_init_data m b p i = Some m' -> + (forall ofs, p <= ofs < p + init_data_size i -> ~ P b ofs) -> + Mem.unchanged_on P m m'. +Proof. + intros. destruct i; simpl in *; + try (eapply Mem.store_unchanged_on; eauto; fail). + inv H; apply Mem.unchanged_on_refl. + destruct (find_symbol ge i); try congruence. + eapply Mem.store_unchanged_on; eauto. +Qed. + +Remark store_init_data_list_unchanged: + forall (P: block -> Z -> Prop) b il m p m', + store_init_data_list m b p il = Some m' -> + (forall ofs, p <= ofs -> ~ P b ofs) -> + Mem.unchanged_on P m m'. +Proof. + induction il; simpl; intros. +- inv H. apply Mem.unchanged_on_refl. +- destruct (store_init_data m b p a) as [m1|] eqn:?; try congruence. + apply Mem.unchanged_on_trans with m1. + eapply store_init_data_unchanged; eauto. intros; apply H0; tauto. + eapply IHil; eauto. intros; apply H0. generalize (init_data_size_pos a); omega. Qed. -Remark store_zeros_loadbytes_outside: +(** Properties related to [loadbytes] *) + +Definition readbytes_as_zero (m: mem) (b: block) (ofs len: Z) : Prop := + forall p n, + ofs <= p -> p + Z.of_nat n <= ofs + len -> + Mem.loadbytes m b p (Z.of_nat n) = Some (list_repeat n (Byte Byte.zero)). + +Lemma store_zeros_loadbytes: forall m b p n m', store_zeros m b p n = Some m' -> - forall b' p' n', - b' <> b \/ p' + n' <= p \/ p + n <= p' -> - Mem.loadbytes m' b' p' n' = Mem.loadbytes m b' p' n'. + readbytes_as_zero m' b p n. Proof. - intros until n. functional induction (store_zeros m b p n); intros. - inv H; auto. - transitivity (Mem.loadbytes m' b' p' n'). - apply IHo. auto. intuition omega. - eapply Mem.loadbytes_store_other; eauto. simpl. intuition omega. - discriminate. + intros until n; functional induction (store_zeros m b p n); red; intros. +- destruct n0. simpl. apply Mem.loadbytes_empty. omega. + rewrite inj_S in H1. omegaContradiction. +- destruct (zeq p0 p). + + subst p0. destruct n0. simpl. apply Mem.loadbytes_empty. omega. + rewrite inj_S in H1. rewrite inj_S. + replace (Z.succ (Z.of_nat n0)) with (1 + Z.of_nat n0) by omega. + change (list_repeat (S n0) (Byte Byte.zero)) + with ((Byte Byte.zero :: nil) ++ list_repeat n0 (Byte Byte.zero)). + apply Mem.loadbytes_concat. + eapply Mem.loadbytes_unchanged_on with (P := fun b1 ofs1 => ofs1 = p). + eapply store_zeros_unchanged; eauto. intros; omega. + intros; omega. + change (Byte Byte.zero :: nil) with (encode_val Mint8unsigned Vzero). + change 1 with (size_chunk Mint8unsigned). + eapply Mem.loadbytes_store_same; eauto. + eapply IHo; eauto. omega. omega. omega. omega. + + eapply IHo; eauto. omega. omega. +- discriminate. Qed. +Definition bytes_of_init_data (i: init_data): list memval := + match i with + | Init_int8 n => inj_bytes (encode_int 1%nat (Int.unsigned n)) + | Init_int16 n => inj_bytes (encode_int 2%nat (Int.unsigned n)) + | Init_int32 n => inj_bytes (encode_int 4%nat (Int.unsigned n)) + | Init_int64 n => inj_bytes (encode_int 8%nat (Int64.unsigned n)) + | Init_float32 n => inj_bytes (encode_int 4%nat (Int.unsigned (Float32.to_bits n))) + | Init_float64 n => inj_bytes (encode_int 8%nat (Int64.unsigned (Float.to_bits n))) + | Init_space n => list_repeat (Z.to_nat n) (Byte Byte.zero) + | Init_addrof id ofs => + match find_symbol ge id with + | Some b => inj_value Q32 (Vptr b ofs) + | None => list_repeat 4%nat Undef + end + end. + +Lemma store_init_data_loadbytes: + forall m b p i m', + store_init_data m b p i = Some m' -> + readbytes_as_zero m b p (init_data_size i) -> + Mem.loadbytes m' b p (init_data_size i) = Some (bytes_of_init_data i). +Proof. + intros; destruct i; simpl in H; try apply (Mem.loadbytes_store_same _ _ _ _ _ _ H). +- inv H. simpl. + assert (EQ: Z.of_nat (Z.to_nat z) = Z.max z 0). + { destruct (zle 0 z). rewrite Z2Nat.id; xomega. destruct z; try discriminate. simpl. xomega. } + rewrite <- EQ. apply H0. omega. simpl. omega. +- simpl; destruct (find_symbol ge i) as [b'|]; try discriminate. + apply (Mem.loadbytes_store_same _ _ _ _ _ _ H). +Qed. + +Fixpoint bytes_of_init_data_list (il: list init_data): list memval := + match il with + | nil => nil + | i :: il => bytes_of_init_data i ++ bytes_of_init_data_list il + end. + +Lemma store_init_data_list_loadbytes: + forall b il m p m', + store_init_data_list m b p il = Some m' -> + readbytes_as_zero m b p (init_data_list_size il) -> + Mem.loadbytes m' b p (init_data_list_size il) = Some (bytes_of_init_data_list il). +Proof. + induction il as [ | i1 il]; simpl; intros. +- apply Mem.loadbytes_empty. omega. +- generalize (init_data_size_pos i1) (init_data_list_size_pos il); intros P1 PL. + destruct (store_init_data m b p i1) as [m1|] eqn:S; try discriminate. + apply Mem.loadbytes_concat. + eapply Mem.loadbytes_unchanged_on with (P := fun b1 ofs1 => ofs1 < p + init_data_size i1). + eapply store_init_data_list_unchanged; eauto. + intros; omega. + intros; omega. + eapply store_init_data_loadbytes; eauto. + red; intros; apply H0. omega. omega. + apply IHil with m1; auto. + red; intros. + eapply Mem.loadbytes_unchanged_on with (P := fun b1 ofs1 => p + init_data_size i1 <= ofs1). + eapply store_init_data_unchanged; eauto. + intros; omega. + intros; omega. + apply H0. omega. omega. + auto. auto. +Qed. + +(** Properties related to [load] *) + Definition read_as_zero (m: mem) (b: block) (ofs len: Z) : Prop := forall chunk p, ofs <= p -> p + size_chunk chunk <= ofs + len -> @@ -926,32 +953,16 @@ Definition read_as_zero (m: mem) (b: block) (ofs len: Z) : Prop := | Many32 | Many64 => Vundef end). -Remark store_zeros_loadbytes: - forall m b p n m', - store_zeros m b p n = Some m' -> - forall p' n', - p <= p' -> p' + Z.of_nat n' <= p + n -> - Mem.loadbytes m' b p' (Z.of_nat n') = Some (list_repeat n' (Byte Byte.zero)). +Remark read_as_zero_unchanged: + forall (P: block -> Z -> Prop) m b ofs len m', + read_as_zero m b ofs len -> + Mem.unchanged_on P m m' -> + (forall i, ofs <= i < ofs + len -> P b i) -> + read_as_zero m' b ofs len. Proof. - intros until n; functional induction (store_zeros m b p n); intros. -- destruct n'. simpl. apply Mem.loadbytes_empty. omega. - rewrite inj_S in H1. omegaContradiction. -- destruct (zeq p' p). - + subst p'. destruct n'. simpl. apply Mem.loadbytes_empty. omega. - rewrite inj_S in H1. rewrite inj_S. - replace (Z.succ (Z.of_nat n')) with (1 + Z.of_nat n') by omega. - change (list_repeat (S n') (Byte Byte.zero)) - with ((Byte Byte.zero :: nil) ++ list_repeat n' (Byte Byte.zero)). - apply Mem.loadbytes_concat. - erewrite store_zeros_loadbytes_outside; eauto. - change (Byte Byte.zero :: nil) with (encode_val Mint8unsigned Vzero). - change 1 with (size_chunk Mint8unsigned). - eapply Mem.loadbytes_store_same; eauto. - right; omega. - eapply IHo; eauto. omega. omega. omega. omega. - + eapply IHo; eauto. omega. omega. -- discriminate. -Qed. + intros; red; intros. eapply Mem.load_unchanged_on; eauto. + intros; apply H1. omega. +Qed. Lemma store_zeros_read_as_zero: forall m b p n m', @@ -965,35 +976,6 @@ Proof. f_equal. destruct chunk; reflexivity. Qed. -Remark store_init_data_outside: - forall b i m p m', - store_init_data m b p i = Some m' -> - forall chunk b' q, - b' <> b \/ q + size_chunk chunk <= p \/ p + init_data_size i <= q -> - Mem.load chunk m' b' q = Mem.load chunk m b' q. -Proof. - intros. destruct i; simpl in *; - try (eapply Mem.load_store_other; eauto; fail). - inv H; auto. - destruct (find_symbol ge i); try congruence. - eapply Mem.load_store_other; eauto; intuition. -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. destruct (store_init_data m b p a) as [m1|] eqn:?; try congruence. - transitivity (Mem.load chunk m1 b' q). - eapply IHil; eauto. generalize (init_data_size_pos a). intuition omega. - eapply store_init_data_outside; eauto. tauto. -Qed. - Fixpoint load_store_init_data (m: mem) (b: block) (p: Z) (il: list init_data) {struct il} : Prop := match il with | nil => True @@ -1023,12 +1005,6 @@ Fixpoint load_store_init_data (m: mem) (b: block) (p: Z) (il: list init_data) {s /\ load_store_init_data m b (p + Zmax n 0) il' end. -Remark init_data_list_size_pos: - forall il, init_data_list_size il >= 0. -Proof. - induction il; simpl. omega. generalize (init_data_size_pos a); omega. -Qed. - Lemma store_init_data_list_charact: forall b il m p m', store_init_data_list m b p il = Some m' -> @@ -1040,17 +1016,22 @@ Proof. store_init_data_list m1 b (p + size_chunk chunk) il = Some m' -> 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. + intros. + eapply Mem.load_unchanged_on with (P := fun b' ofs' => ofs' < p + size_chunk chunk). + eapply store_init_data_list_unchanged; eauto. intros; omega. + intros; tauto. eapply Mem.load_store_same; eauto. } induction il; simpl. auto. intros. destruct (store_init_data m b p a) as [m1|] eqn:?; try congruence. exploit IHil; eauto. - red; intros. transitivity (Mem.load chunk m b p0). - eapply store_init_data_outside. eauto. auto. - apply H0. generalize (init_data_size_pos a); omega. omega. auto. + set (P := fun (b': block) ofs' => p + init_data_size a <= ofs'). + apply read_as_zero_unchanged with (m := m) (P := P). + red; intros; apply H0; auto. generalize (init_data_size_pos a); omega. omega. + eapply store_init_data_unchanged with (P := P); eauto. + intros; unfold P. omega. + intros; unfold P. omega. intro D. destruct a; simpl in Heqo; intuition. eapply (A Mint8unsigned (Vint i)); eauto. @@ -1059,56 +1040,60 @@ Proof. eapply (A Mint64 (Vlong i)); eauto. eapply (A Mfloat32 (Vsingle f)); eauto. eapply (A Mfloat64 (Vfloat f)); eauto. - inv Heqo. red; intros. transitivity (Mem.load chunk m1 b p0). - eapply store_init_data_list_outside; eauto. right. simpl. xomega. - apply H0; auto. simpl. generalize (init_data_list_size_pos il); xomega. + set (P := fun (b': block) ofs' => ofs' < p + init_data_size (Init_space z)). + inv Heqo. apply read_as_zero_unchanged with (m := m1) (P := P). + red; intros. apply H0; auto. simpl. generalize (init_data_list_size_pos il); xomega. + eapply store_init_data_list_unchanged; eauto. + intros; unfold P. omega. + intros; unfold P. simpl; xomega. destruct (find_symbol ge i); try congruence. exists b0; split; auto. eapply (A Mint32 (Vptr b0 i0)); eauto. Qed. -Remark load_alloc_global: - forall chunk b p id g m m', +Remark alloc_global_unchanged: + forall (P: block -> Z -> Prop) m id g m', alloc_global m (id, g) = Some m' -> - Mem.valid_block m b -> - Mem.load chunk m' b p = Mem.load chunk m b p. + Mem.unchanged_on P m m'. Proof. intros. destruct g as [f|v]; simpl in H. - (* function *) - destruct (Mem.alloc m 0 1) as [m1 b'] eqn:?. - assert (b <> b'). apply Mem.valid_not_valid_diff with m; eauto with mem. - transitivity (Mem.load chunk m1 b p). - eapply Mem.load_drop; eauto. - eapply Mem.load_alloc_unchanged; eauto. - (* variable *) +- (* function *) + destruct (Mem.alloc m 0 1) as [m1 b] eqn:?. + set (Q := fun b' (ofs: Z) => b' <> b). + apply Mem.unchanged_on_implies with Q. + apply Mem.unchanged_on_trans with m1. + eapply Mem.alloc_unchanged_on; eauto. + eapply Mem.drop_perm_unchanged_on; eauto. + intros; red. apply Mem.valid_not_valid_diff with m; eauto with mem. +- (* variable *) set (init := gvar_init v) in *. set (sz := init_data_list_size init) in *. - destruct (Mem.alloc m 0 sz) as [m1 b'] eqn:?. - destruct (store_zeros m1 b' 0 sz) as [m2|] eqn:?; try discriminate. - destruct (store_init_data_list m2 b' 0 init) as [m3|] eqn:?; try discriminate. - assert (b <> b'). apply Mem.valid_not_valid_diff with m; eauto with mem. - transitivity (Mem.load chunk m3 b p). - eapply Mem.load_drop; eauto. - transitivity (Mem.load chunk m2 b p). - eapply store_init_data_list_outside; eauto. - transitivity (Mem.load chunk m1 b p). - eapply store_zeros_load_outside; eauto. - eapply Mem.load_alloc_unchanged; eauto. -Qed. - -Remark load_alloc_globals: - forall chunk b p gl m m', + destruct (Mem.alloc m 0 sz) as [m1 b] eqn:?. + destruct (store_zeros m1 b 0 sz) as [m2|] eqn:?; try discriminate. + destruct (store_init_data_list m2 b 0 init) as [m3|] eqn:?; try discriminate. + set (Q := fun b' (ofs: Z) => b' <> b). + apply Mem.unchanged_on_implies with Q. + apply Mem.unchanged_on_trans with m1. + eapply Mem.alloc_unchanged_on; eauto. + apply Mem.unchanged_on_trans with m2. + eapply store_zeros_unchanged; eauto. + apply Mem.unchanged_on_trans with m3. + eapply store_init_data_list_unchanged; eauto. + eapply Mem.drop_perm_unchanged_on; eauto. + intros; red. apply Mem.valid_not_valid_diff with m; eauto with mem. +Qed. + +Remark alloc_globals_unchanged: + forall (P: block -> Z -> Prop) gl m m', alloc_globals m gl = Some m' -> - Mem.valid_block m b -> - Mem.load chunk m' b p = Mem.load chunk m b p. + Mem.unchanged_on P m m'. Proof. induction gl; simpl; intros. - congruence. - destruct (alloc_global m a) as [m''|] eqn:?; try discriminate. - transitivity (Mem.load chunk m'' b p). - apply IHgl; auto. unfold Mem.valid_block in *. - erewrite alloc_global_nextblock; eauto. - apply Plt_trans with (Mem.nextblock m); auto. apply Plt_succ. - destruct a as [id g]. eapply load_alloc_global; eauto. +- inv H. apply Mem.unchanged_on_refl. +- destruct (alloc_global m a) as [m''|] eqn:?; try discriminate. + destruct a as [id g]. + apply Mem.unchanged_on_trans with m''. + eapply alloc_global_unchanged; eauto. + apply IHgl; auto. Qed. Remark load_store_init_data_invariant: @@ -1119,125 +1104,101 @@ Remark load_store_init_data_invariant: Proof. induction il; intro p; simpl. auto. - repeat rewrite H. destruct a; intuition. red; intros; rewrite H; auto. -Qed. - -Definition variables_initialized (g: t) (m: mem) := - forall b gv, - find_var_info g b = Some gv -> - Mem.range_perm m b 0 (init_data_list_size gv.(gvar_init)) Cur (perm_globvar gv) - /\ (forall ofs k p, Mem.perm m b ofs k p -> - 0 <= ofs < init_data_list_size gv.(gvar_init) /\ perm_order (perm_globvar gv) p) - /\ (gv.(gvar_volatile) = false -> load_store_init_data m b 0 gv.(gvar_init)). - -Definition functions_initialized (g: t) (m: mem) := - forall b fd, - find_funct_ptr g b = Some fd -> - Mem.perm m b 0 Cur Nonempty - /\ (forall ofs k p, Mem.perm m b ofs k p -> ofs = 0 /\ perm_order Nonempty p). + rewrite ! H. destruct a; intuition. red; intros; rewrite H; auto. +Qed. + +Definition globals_initialized (g: t) (m: mem) := + forall b gd, + find_def g b = Some gd -> + match gd with + | Gfun f => + Mem.perm m b 0 Cur Nonempty + /\ (forall ofs k p, Mem.perm m b ofs k p -> ofs = 0 /\ p = Nonempty) + | Gvar v => + Mem.range_perm m b 0 (init_data_list_size v.(gvar_init)) Cur (perm_globvar v) + /\ (forall ofs k p, Mem.perm m b ofs k p -> + 0 <= ofs < init_data_list_size v.(gvar_init) /\ perm_order (perm_globvar v) p) + /\ (v.(gvar_volatile) = false -> load_store_init_data m b 0 v.(gvar_init)) + /\ (v.(gvar_volatile) = false -> Mem.loadbytes m b 0 (init_data_list_size v.(gvar_init)) = Some (bytes_of_init_data_list v.(gvar_init))) + end. Lemma alloc_global_initialized: - forall ge m id g m', - genv_next ge = Mem.nextblock m -> - alloc_global m (id, g) = Some m' -> - variables_initialized ge m -> - functions_initialized ge m -> - variables_initialized (add_global ge (id, g)) m' - /\ functions_initialized (add_global ge (id, g)) m' - /\ genv_next (add_global ge (id, g)) = Mem.nextblock m'. + forall g m id gd m', + genv_next g = Mem.nextblock m -> + alloc_global m (id, gd) = Some m' -> + globals_initialized g m -> + globals_initialized (add_global g (id, gd)) m' + /\ genv_next (add_global g (id, gd)) = Mem.nextblock m'. Proof. intros. exploit alloc_global_nextblock; eauto. intros NB. split. -(* variables-initialized *) - destruct g as [f|v]. -(* function *) - red; intros. unfold find_var_info in H3. simpl in H3. - exploit H1; eauto. intros [A [B C]]. - assert (D: Mem.valid_block m b). - red. exploit genv_vars_range; eauto. rewrite H; auto. - split. red; intros. erewrite <- alloc_global_perm; eauto. - split. intros. eapply B. erewrite alloc_global_perm; eauto. - intros. apply load_store_init_data_invariant with m; auto. - intros. eapply load_alloc_global; eauto. -(* variable *) - red; intros. unfold find_var_info in H3. simpl in H3. rewrite PTree.gsspec in H3. - destruct (peq b (genv_next ge0)). - (* same *) - inv H3. simpl in H0. - set (init := gvar_init gv) in *. +- (* globals-initialized *) + red; intros. unfold find_def in H2; simpl in H2. + rewrite PTree.gsspec in H2. destruct (peq b (genv_next g)). ++ inv H2. destruct gd0 as [f|v]; simpl in H0. +* destruct (Mem.alloc m 0 1) as [m1 b] eqn:ALLOC. + exploit Mem.alloc_result; eauto. intros RES. + rewrite H, <- RES. split. + eapply Mem.perm_drop_1; eauto. omega. + intros. + assert (0 <= ofs < 1). { eapply Mem.perm_alloc_3; eauto. eapply Mem.perm_drop_4; eauto. } + exploit Mem.perm_drop_2; eauto. intros ORD. + split. omega. inv ORD; auto. +* set (init := gvar_init v) in *. set (sz := init_data_list_size init) in *. - destruct (Mem.alloc m 0 sz) as [m1 b'] eqn:?. - destruct (store_zeros m1 b' 0 sz) as [m2|] eqn:?; try discriminate. - destruct (store_init_data_list m2 b' 0 init) as [m3|] eqn:?; try discriminate. + destruct (Mem.alloc m 0 sz) as [m1 b] eqn:?. + destruct (store_zeros m1 b 0 sz) as [m2|] eqn:?; try discriminate. + destruct (store_init_data_list m2 b 0 init) as [m3|] eqn:?; try discriminate. exploit Mem.alloc_result; eauto. intro RES. - replace (genv_next ge0) with b' by congruence. + replace (genv_next g) with b by congruence. split. red; intros. eapply Mem.perm_drop_1; eauto. split. intros. assert (0 <= ofs < sz). - eapply Mem.perm_alloc_3; eauto. - erewrite store_zeros_perm; [idtac|eauto]. - erewrite store_init_data_list_perm; [idtac|eauto]. - eapply Mem.perm_drop_4; eauto. - split. auto. eapply Mem.perm_drop_2; eauto. - intros. apply load_store_init_data_invariant with m3. - intros. eapply Mem.load_drop; eauto. - right; right; right. unfold perm_globvar. rewrite H3. - destruct (gvar_readonly gv); auto with mem. - eapply store_init_data_list_charact; eauto. + { eapply Mem.perm_alloc_3; eauto. + erewrite store_zeros_perm by eauto. + erewrite store_init_data_list_perm by eauto. + eapply Mem.perm_drop_4; eauto. } + split; auto. + eapply Mem.perm_drop_2; eauto. + split. intros NOTVOL. apply load_store_init_data_invariant with m3. + intros. eapply Mem.load_drop; eauto. right; right; right. + unfold perm_globvar. rewrite NOTVOL. destruct (gvar_readonly v); auto with mem. + eapply store_init_data_list_charact; eauto. eapply store_zeros_read_as_zero; eauto. - (* older var *) - exploit H1; eauto. intros [A [B C]]. - assert (D: Mem.valid_block m b). - red. exploit genv_vars_range; eauto. rewrite H; auto. - split. red; intros. erewrite <- alloc_global_perm; eauto. - split. intros. eapply B. erewrite alloc_global_perm; eauto. - intros. apply load_store_init_data_invariant with m; auto. - intros. eapply load_alloc_global; eauto. -(* functions-initialized *) - split. destruct g as [f|v]. -(* function *) - red; intros. unfold find_funct_ptr in H3. simpl in H3. rewrite PTree.gsspec in H3. - destruct (peq b (genv_next ge0)). - (* same *) - inv H3. simpl in H0. - destruct (Mem.alloc m 0 1) as [m1 b'] eqn:?. - exploit Mem.alloc_result; eauto. intro RES. - replace (genv_next ge0) with b' by congruence. - split. eapply Mem.perm_drop_1; eauto. omega. - intros. - assert (0 <= ofs < 1). - eapply Mem.perm_alloc_3; eauto. - eapply Mem.perm_drop_4; eauto. - split. omega. eapply Mem.perm_drop_2; eauto. - (* older function *) - exploit H2; eauto. intros [A B]. - assert (D: Mem.valid_block m b). - red. exploit genv_funs_range; eauto. rewrite H; auto. - split. erewrite <- alloc_global_perm; eauto. - intros. eapply B. erewrite alloc_global_perm; eauto. -(* variables *) - red; intros. unfold find_funct_ptr in H3. simpl in H3. - exploit H2; eauto. intros [A B]. - assert (D: Mem.valid_block m b). - red. exploit genv_funs_range; eauto. rewrite H; auto. - split. erewrite <- alloc_global_perm; eauto. - intros. eapply B. erewrite alloc_global_perm; eauto. -(* nextblock *) - rewrite NB. simpl. rewrite H. auto. + intros NOTVOL. + transitivity (Mem.loadbytes m3 b 0 sz). + eapply Mem.loadbytes_drop; eauto. right; right; right. + unfold perm_globvar. rewrite NOTVOL. destruct (gvar_readonly v); auto with mem. + eapply store_init_data_list_loadbytes; eauto. + eapply store_zeros_loadbytes; eauto. ++ assert (U: Mem.unchanged_on (fun _ _ => True) m m') by (eapply alloc_global_unchanged; eauto). + assert (VALID: Mem.valid_block m b). + { red. rewrite <- H. eapply genv_defs_range; eauto. } + exploit H1; eauto. + destruct gd0 as [f|v]. +* intros [A B]; split; intros. + eapply Mem.perm_unchanged_on; eauto. exact I. + eapply B. eapply Mem.perm_unchanged_on_2; eauto. exact I. +* intros (A & B & C & D). split; [| split; [| split]]. + red; intros. eapply Mem.perm_unchanged_on; eauto. exact I. + intros. eapply B. eapply Mem.perm_unchanged_on_2; eauto. exact I. + intros. apply load_store_init_data_invariant with m; auto. + intros. eapply Mem.load_unchanged_on_1; eauto. intros; exact I. + intros. eapply Mem.loadbytes_unchanged_on; eauto. intros; exact I. +- simpl. congruence. Qed. Lemma alloc_globals_initialized: forall gl ge m m', - genv_next ge = Mem.nextblock m -> alloc_globals m gl = Some m' -> - variables_initialized ge m -> - functions_initialized ge m -> - variables_initialized (add_globals ge gl) m' /\ functions_initialized (add_globals ge gl) m'. + genv_next ge = Mem.nextblock m -> + globals_initialized ge m -> + globals_initialized (add_globals ge gl) m'. Proof. induction gl; simpl; intros. - inv H0; auto. - destruct a as [id g]. destruct (alloc_global m (id, g)) as [m1|] eqn:?; try discriminate. - exploit alloc_global_initialized; eauto. intros [P [Q R]]. +- inv H; auto. +- destruct a as [id g]. destruct (alloc_global m (id, g)) as [m1|] eqn:?; try discriminate. + exploit alloc_global_initialized; eauto. intros [P Q]. eapply IHgl; eauto. Qed. @@ -1265,13 +1226,21 @@ Proof. eapply genv_symb_range; eauto. Qed. +Theorem find_def_not_fresh: + forall p b g m, + init_mem p = Some m -> + find_def (globalenv p) b = Some g -> Mem.valid_block m b. +Proof. + intros. red. erewrite <- init_mem_genv_next; eauto. + eapply genv_defs_range; eauto. +Qed. + Theorem find_funct_ptr_not_fresh: forall p b f m, init_mem p = Some m -> find_funct_ptr (globalenv p) b = Some f -> Mem.valid_block m b. Proof. - intros. red. erewrite <- init_mem_genv_next; eauto. - eapply genv_funs_range; eauto. + intros. rewrite find_funct_ptr_iff in H0. eapply find_def_not_fresh; eauto. Qed. Theorem find_var_info_not_fresh: @@ -1279,8 +1248,18 @@ Theorem find_var_info_not_fresh: init_mem p = Some m -> find_var_info (globalenv p) b = Some gv -> Mem.valid_block m b. Proof. - intros. red. erewrite <- init_mem_genv_next; eauto. - eapply genv_vars_range; eauto. + intros. rewrite find_var_info_iff in H0. eapply find_def_not_fresh; eauto. +Qed. + +Lemma init_mem_characterization_gen: + forall p m, + init_mem p = Some m -> + globals_initialized (globalenv p) (globalenv p) m. +Proof. + intros. apply alloc_globals_initialized with Mem.empty. + auto. + rewrite Mem.nextblock_empty. auto. + red; intros. unfold find_def in H0; simpl in H0; rewrite PTree.gempty in H0; discriminate. Qed. Theorem init_mem_characterization: @@ -1290,12 +1269,13 @@ Theorem init_mem_characterization: Mem.range_perm m b 0 (init_data_list_size gv.(gvar_init)) Cur (perm_globvar gv) /\ (forall ofs k p, Mem.perm m b ofs k p -> 0 <= ofs < init_data_list_size gv.(gvar_init) /\ perm_order (perm_globvar gv) p) - /\ (gv.(gvar_volatile) = false -> load_store_init_data (globalenv p) m b 0 gv.(gvar_init)). + /\ (gv.(gvar_volatile) = false -> + load_store_init_data (globalenv p) m b 0 gv.(gvar_init)) + /\ (gv.(gvar_volatile) = false -> + Mem.loadbytes m b 0 (init_data_list_size gv.(gvar_init)) = Some (bytes_of_init_data_list (globalenv p) gv.(gvar_init))). Proof. - intros. eapply alloc_globals_initialized; eauto. - rewrite Mem.nextblock_empty. auto. - red; intros. unfold find_var_info in H1. simpl in H1. rewrite PTree.gempty in H1. congruence. - red; intros. unfold find_funct_ptr in H1. simpl in H1. rewrite PTree.gempty in H1. congruence. + intros. rewrite find_var_info_iff in H. + exploit init_mem_characterization_gen; eauto. Qed. Theorem init_mem_characterization_2: @@ -1303,12 +1283,10 @@ Theorem init_mem_characterization_2: find_funct_ptr (globalenv p) b = Some fd -> init_mem p = Some m -> Mem.perm m b 0 Cur Nonempty - /\ (forall ofs k p, Mem.perm m b ofs k p -> ofs = 0 /\ perm_order Nonempty p). + /\ (forall ofs k p, Mem.perm m b ofs k p -> ofs = 0 /\ p = Nonempty). Proof. - intros. unfold init_mem in H0. eapply alloc_globals_initialized; eauto. - rewrite Mem.nextblock_empty. auto. - red; intros. unfold find_var_info in H1. simpl in H1. rewrite PTree.gempty in H1. congruence. - red; intros. unfold find_funct_ptr in H1. simpl in H1. rewrite PTree.gempty in H1. congruence. + intros. rewrite find_funct_ptr_iff in H. + exploit init_mem_characterization_gen; eauto. Qed. (** ** Compatibility with memory injections *) @@ -1426,302 +1404,296 @@ Proof. apply Ple_refl. Qed. -Section INITMEM_AUGMENT_INJ. +(** ** Sufficient and necessary conditions for the initial memory to exist. *) + +(** Alignment properties *) + +Definition init_data_alignment (i: init_data) : Z := + match i with + | Init_int8 n => 1 + | Init_int16 n => 2 + | Init_int32 n => 4 + | Init_int64 n => 8 + | Init_float32 n => 4 + | Init_float64 n => 4 + | Init_addrof symb ofs => 4 + | Init_space n => 1 + end. + +Fixpoint init_data_list_aligned (p: Z) (il: list init_data) {struct il} : Prop := + match il with + | nil => True + | i1 :: il => (init_data_alignment i1 | p) /\ init_data_list_aligned (p + init_data_size i1) il + end. + +Section INITMEM_INVERSION. Variable ge: t. -Variable thr: block. -Lemma store_zeros_augment: - forall m1 m2 b p n m2', - Mem.inject (Mem.flat_inj thr) m1 m2 -> - Ple thr b -> - store_zeros m2 b p n = Some m2' -> - Mem.inject (Mem.flat_inj thr) m1 m2'. +Lemma store_init_data_aligned: + forall m b p i m', + store_init_data ge m b p i = Some m' -> + (init_data_alignment i | p). Proof. - intros until n. functional induction (store_zeros m2 b p n); intros. - inv H1; auto. - apply IHo; auto. exploit Mem.store_outside_inject; eauto. simpl. - intros. exfalso. unfold Mem.flat_inj in H2. destruct (plt b' thr). - inv H2. unfold Plt, Ple in *. zify; omega. - discriminate. - discriminate. + intros. + assert (DFL: forall chunk v, + Mem.store chunk m b p v = Some m' -> + align_chunk chunk = init_data_alignment i -> + (init_data_alignment i | p)). + { intros. apply Mem.store_valid_access_3 in H0. destruct H0. congruence. } + destruct i; simpl in H; eauto. + simpl. apply Z.divide_1_l. + destruct (find_symbol ge i); try discriminate. eauto. Qed. -Lemma store_init_data_augment: - forall m1 m2 b p id m2', - Mem.inject (Mem.flat_inj thr) m1 m2 -> - Ple thr b -> - store_init_data ge m2 b p id = Some m2' -> - Mem.inject (Mem.flat_inj thr) m1 m2'. -Proof. - intros until m2'. intros INJ BND ST. - assert (P: forall chunk ofs v m2', - Mem.store chunk m2 b ofs v = Some m2' -> - Mem.inject (Mem.flat_inj thr) m1 m2'). - intros. eapply Mem.store_outside_inject; eauto. - intros. unfold Mem.flat_inj in H0. - destruct (plt b' thr); inv H0. unfold Plt, Ple in *. zify; omega. - destruct id; simpl in ST; try (eapply P; eauto; fail). - congruence. - revert ST. caseEq (find_symbol ge i); try congruence. intros; eapply P; eauto. +Lemma store_init_data_list_aligned: + forall b il m p m', + store_init_data_list ge m b p il = Some m' -> + init_data_list_aligned p il. +Proof. + induction il as [ | i1 il]; simpl; intros. +- auto. +- destruct (store_init_data ge m b p i1) as [m1|] eqn:S1; try discriminate. + split; eauto. eapply store_init_data_aligned; eauto. Qed. -Lemma store_init_data_list_augment: - forall b idl m1 m2 p m2', - Mem.inject (Mem.flat_inj thr) m1 m2 -> - Ple thr b -> - store_init_data_list ge m2 b p idl = Some m2' -> - Mem.inject (Mem.flat_inj thr) m1 m2'. +Lemma store_init_data_list_free_idents: + forall b i o il m p m', + store_init_data_list ge m b p il = Some m' -> + In (Init_addrof i o) il -> + exists b', find_symbol ge i = Some b'. Proof. - induction idl; simpl. - intros; congruence. - intros until m2'; intros INJ FB. - caseEq (store_init_data ge m2 b p a); try congruence. intros. - eapply IHidl. eapply store_init_data_augment; eauto. auto. eauto. + induction il as [ | i1 il]; simpl; intros. +- contradiction. +- destruct (store_init_data ge m b p i1) as [m1|] eqn:S1; try discriminate. + destruct H0. ++ subst i1. simpl in S1. destruct (find_symbol ge i) as [b'|]. exists b'; auto. discriminate. ++ eapply IHil; eauto. Qed. -Lemma alloc_global_augment: - forall idg m1 m2 m2', - alloc_global ge m2 idg = Some m2' -> - Mem.inject (Mem.flat_inj thr) m1 m2 -> - Ple thr (Mem.nextblock m2) -> - Mem.inject (Mem.flat_inj thr) m1 m2'. -Proof. - intros. destruct idg as [id [f|v]]; simpl in H. - (* function *) - destruct (Mem.alloc m2 0 1) as [m3 b] eqn:?. - assert (Ple thr b). rewrite (Mem.alloc_result _ _ _ _ _ Heqp). auto. - eapply Mem.drop_outside_inject. 2: eauto. - eapply Mem.alloc_right_inject; eauto. - intros. unfold Mem.flat_inj in H3. destruct (plt b' thr); inv H3. - unfold Plt, Ple in *. zify; omega. - (* variable *) - set (init := gvar_init v) in *. - set (sz := init_data_list_size init) in *. - destruct (Mem.alloc m2 0 sz) as [m3 b] eqn:?. - destruct (store_zeros m3 b 0 sz) as [m4|] eqn:?; try discriminate. - destruct (store_init_data_list ge m4 b 0 init) as [m5|] eqn:?; try discriminate. - assert (Ple thr b). rewrite (Mem.alloc_result _ _ _ _ _ Heqp). auto. - eapply Mem.drop_outside_inject. 2: eauto. - eapply store_init_data_list_augment. 3: eauto. 2: eauto. - eapply store_zeros_augment. 3: eauto. 2: eauto. - eapply Mem.alloc_right_inject; eauto. - intros. unfold Mem.flat_inj in H3. destruct (plt b' thr); inv H3. - unfold Plt, Ple in *. zify; omega. -Qed. - -Lemma alloc_globals_augment: - forall gl m1 m2 m2', - alloc_globals ge m2 gl = Some m2' -> - Mem.inject (Mem.flat_inj thr) m1 m2 -> - Ple thr (Mem.nextblock m2) -> - Mem.inject (Mem.flat_inj thr) m1 m2'. -Proof. - induction gl; simpl. - intros. congruence. - intros until m2'. caseEq (alloc_global ge m2 a); try congruence. intros. - eapply IHgl with (m2 := m); eauto. - eapply alloc_global_augment; eauto. - rewrite (alloc_global_nextblock _ _ _ H). - apply Ple_trans with (Mem.nextblock m2); auto. apply Ple_succ. +End INITMEM_INVERSION. + +Theorem init_mem_inversion: + forall p m id v, + init_mem p = Some m -> + In (id, Gvar v) p.(prog_defs) -> + init_data_list_aligned 0 v.(gvar_init) + /\ forall i o, In (Init_addrof i o) v.(gvar_init) -> exists b, find_symbol (globalenv p) i = Some b. +Proof. + intros until v. unfold init_mem. set (ge := globalenv p). + revert m. generalize Mem.empty. generalize (prog_defs p). + induction l as [ | idg1 defs ]; simpl; intros m m'; intros. +- contradiction. +- destruct (alloc_global ge m idg1) as [m''|] eqn:A; try discriminate. + destruct H0. ++ subst idg1; simpl in A. + set (il := gvar_init v) in *. set (sz := init_data_list_size il) in *. + destruct (Mem.alloc m 0 sz) as [m1 b]. + destruct (store_zeros m1 b 0 sz) as [m2|]; try discriminate. + destruct (store_init_data_list ge m2 b 0 il) as [m3|] eqn:B; try discriminate. + split. eapply store_init_data_list_aligned; eauto. intros; eapply store_init_data_list_free_idents; eauto. ++ eapply IHdefs; eauto. +Qed. + +Section INITMEM_EXISTS. + +Variable ge: t. + +Lemma store_zeros_exists: + forall m b p n, + Mem.range_perm m b p (p + n) Cur Writable -> + exists m', store_zeros m b p n = Some m'. +Proof. + intros until n. functional induction (store_zeros m b p n); intros PERM. +- exists m; auto. +- apply IHo. red; intros. eapply Mem.perm_store_1; eauto. apply PERM. omega. +- destruct (Mem.valid_access_store m Mint8unsigned b p Vzero) as (m' & STORE). + split. red; intros. apply Mem.perm_cur. apply PERM. simpl in H. omega. + simpl. apply Z.divide_1_l. + congruence. Qed. -End INITMEM_AUGMENT_INJ. +Lemma store_init_data_exists: + forall m b p i, + Mem.range_perm m b p (p + init_data_size i) Cur Writable -> + (init_data_alignment i | p) -> + (forall id ofs, i = Init_addrof id ofs -> exists b, find_symbol ge id = Some b) -> + exists m', store_init_data ge m b p i = Some m'. +Proof. + intros. + assert (DFL: forall chunk v, + init_data_size i = size_chunk chunk -> + init_data_alignment i = align_chunk chunk -> + exists m', Mem.store chunk m b p v = Some m'). + { intros. destruct (Mem.valid_access_store m chunk b p v) as (m' & STORE). + split. rewrite <- H2; auto. rewrite <- H3; auto. + exists m'; auto. } + destruct i; eauto. + simpl. exists m; auto. + simpl. exploit H1; eauto. intros (b1 & FS). rewrite FS. eauto. +Qed. + +Lemma store_init_data_list_exists: + forall b il m p, + Mem.range_perm m b p (p + init_data_list_size il) Cur Writable -> + init_data_list_aligned p il -> + (forall id ofs, In (Init_addrof id ofs) il -> exists b, find_symbol ge id = Some b) -> + exists m', store_init_data_list ge m b p il = Some m'. +Proof. + induction il as [ | i1 il ]; simpl; intros. +- exists m; auto. +- destruct H0. + destruct (@store_init_data_exists m b p i1) as (m1 & S1); eauto. + red; intros. apply H. generalize (init_data_list_size_pos il); omega. + rewrite S1. + apply IHil; eauto. + red; intros. erewrite <- store_init_data_perm by eauto. apply H. generalize (init_data_size_pos i1); omega. +Qed. + +Lemma alloc_global_exists: + forall m idg, + match idg with + | (id, Gfun f) => True + | (id, Gvar v) => + init_data_list_aligned 0 v.(gvar_init) + /\ forall i o, In (Init_addrof i o) v.(gvar_init) -> exists b, find_symbol ge i = Some b + end -> + exists m', alloc_global ge m idg = Some m'. +Proof. + intros m [id [f|v]]; intros; simpl. +- destruct (Mem.alloc m 0 1) as [m1 b] eqn:ALLOC. + destruct (Mem.range_perm_drop_2 m1 b 0 1 Nonempty) as [m2 DROP]. + red; intros; eapply Mem.perm_alloc_2; eauto. + exists m2; auto. +- destruct H as [P Q]. + set (sz := init_data_list_size (gvar_init v)). + destruct (Mem.alloc m 0 sz) as [m1 b] eqn:ALLOC. + assert (P1: Mem.range_perm m1 b 0 sz Cur Freeable) by (red; intros; eapply Mem.perm_alloc_2; eauto). + destruct (@store_zeros_exists m1 b 0 sz) as [m2 ZEROS]. + red; intros. apply Mem.perm_implies with Freeable; auto with mem. + rewrite ZEROS. + assert (P2: Mem.range_perm m2 b 0 sz Cur Freeable). + { red; intros. erewrite <- store_zeros_perm by eauto. eauto. } + destruct (@store_init_data_list_exists b (gvar_init v) m2 0) as [m3 STORE]; auto. + red; intros. apply Mem.perm_implies with Freeable; auto with mem. + rewrite STORE. + assert (P3: Mem.range_perm m3 b 0 sz Cur Freeable). + { red; intros. erewrite <- store_init_data_list_perm by eauto. eauto. } + destruct (Mem.range_perm_drop_2 m3 b 0 sz (perm_globvar v)) as [m4 DROP]; auto. + exists m4; auto. +Qed. + +End INITMEM_EXISTS. + +Theorem init_mem_exists: + forall p, + (forall id v, In (id, Gvar v) (prog_defs p) -> + init_data_list_aligned 0 v.(gvar_init) + /\ forall i o, In (Init_addrof i o) v.(gvar_init) -> exists b, find_symbol (globalenv p) i = Some b) -> + exists m, init_mem p = Some m. +Proof. + intros. set (ge := globalenv p) in *. + unfold init_mem. revert H. generalize (prog_defs p) Mem.empty. + induction l as [ | idg l]; simpl; intros. +- exists m; auto. +- destruct (@alloc_global_exists ge m idg) as [m1 A1]. + destruct idg as [id [f|v]]; eauto. + fold ge. rewrite A1. eapply IHl; eauto. +Qed. End GENV. (** * Commutation with program transformations *) -(** ** Commutation with matching between programs. *) - -Section MATCH_PROGRAMS. - -Variables A B V W: Type. -Variable match_fun: A -> B -> Prop. -Variable match_varinfo: V -> W -> Prop. +Section MATCH_GENVS. -Inductive match_globvar: globvar V -> globvar W -> Prop := - | match_globvar_intro: forall info1 info2 init ro vo, - match_varinfo info1 info2 -> - match_globvar (mkglobvar info1 init ro vo) (mkglobvar info2 init ro vo). +Context {A B V W: Type} (R: globdef A V -> globdef B W -> Prop). -Record match_genvs (new_globs : list (ident * globdef B W)) - (ge1: t A V) (ge2: t B W): Prop := { +Record match_genvs (ge1: t A V) (ge2: t B W): Prop := { mge_next: - genv_next ge2 = advance_next new_globs (genv_next ge1); + genv_next ge2 = genv_next ge1; mge_symb: - forall id, ~ In id (map fst new_globs) -> - PTree.get id (genv_symb ge2) = PTree.get id (genv_symb ge1); - mge_funs: - forall b f, PTree.get b (genv_funs ge1) = Some f -> - exists tf, PTree.get b (genv_funs ge2) = Some tf /\ match_fun f tf; - mge_rev_funs: - forall b tf, PTree.get b (genv_funs ge2) = Some tf -> - if plt b (genv_next ge1) then - exists f, PTree.get b (genv_funs ge1) = Some f /\ match_fun f tf - else - In (Gfun tf) (map snd new_globs); - mge_vars: - forall b v, PTree.get b (genv_vars ge1) = Some v -> - exists tv, PTree.get b (genv_vars ge2) = Some tv /\ match_globvar v tv; - mge_rev_vars: - forall b tv, PTree.get b (genv_vars ge2) = Some tv -> - if plt b (genv_next ge1) then - exists v, PTree.get b (genv_vars ge1) = Some v /\ match_globvar v tv - else - In (Gvar tv) (map snd new_globs) + forall id, PTree.get id (genv_symb ge2) = PTree.get id (genv_symb ge1); + mge_defs: + forall b, option_rel R (PTree.get b (genv_defs ge1)) (PTree.get b (genv_defs ge2)) }. Lemma add_global_match: - forall ge1 ge2 idg1 idg2, - match_genvs nil ge1 ge2 -> - match_globdef match_fun match_varinfo idg1 idg2 -> - match_genvs nil (add_global ge1 idg1) (add_global ge2 idg2). -Proof. - intros. destruct H. simpl in mge_next0. - inv H0. -(* two functions *) - constructor; simpl. - congruence. - intros. rewrite mge_next0. - repeat rewrite PTree.gsspec. destruct (peq id0 id); auto. - rewrite mge_next0. intros. rewrite PTree.gsspec in H0. rewrite PTree.gsspec. - destruct (peq b (genv_next ge1)). - exists f2; split; congruence. - eauto. - rewrite mge_next0. intros. rewrite PTree.gsspec in H0. rewrite PTree.gsspec. - destruct (peq b (genv_next ge1)). - subst b. rewrite pred_dec_true. exists f1; split; congruence. apply Plt_succ. - pose proof (mge_rev_funs0 b tf H0). - destruct (plt b (genv_next ge1)). rewrite pred_dec_true. auto. apply Plt_trans_succ; auto. - contradiction. - eauto. - intros. - pose proof (mge_rev_vars0 b tv H0). - destruct (plt b (genv_next ge1)). rewrite pred_dec_true. auto. - apply Plt_trans with (genv_next ge1); auto. apply Plt_succ. - contradiction. -(* two variables *) - constructor; simpl. - congruence. - intros. rewrite mge_next0. - repeat rewrite PTree.gsspec. destruct (peq id0 id); auto. - eauto. - intros. - pose proof (mge_rev_funs0 b tf H0). - destruct (plt b (genv_next ge1)). rewrite pred_dec_true. auto. apply Plt_trans_succ; auto. - contradiction. - rewrite mge_next0. intros. rewrite PTree.gsspec in H0. rewrite PTree.gsspec. - destruct (peq b (genv_next ge1)). - econstructor; split. eauto. inv H0. constructor; auto. - eauto. - rewrite mge_next0. intros. rewrite PTree.gsspec in H0. rewrite PTree.gsspec. - destruct (peq b (genv_next ge1)). - subst b. rewrite pred_dec_true. - econstructor; split. eauto. inv H0. constructor; auto. apply Plt_succ. - pose proof (mge_rev_vars0 b tv H0). - destruct (plt b (genv_next ge1)). rewrite pred_dec_true. auto. apply Plt_trans_succ; auto. - contradiction. + forall ge1 ge2 id g1 g2, + match_genvs ge1 ge2 -> + R g1 g2 -> + match_genvs (add_global ge1 (id, g1)) (add_global ge2 (id, g2)). +Proof. + intros. destruct H. constructor; simpl; intros. +- congruence. +- rewrite mge_next0, ! PTree.gsspec. destruct (peq id0 id); auto. +- rewrite mge_next0, ! PTree.gsspec. destruct (peq b (genv_next ge1)). + constructor; auto. + auto. Qed. Lemma add_globals_match: - forall gl1 gl2, list_forall2 (match_globdef match_fun match_varinfo) gl1 gl2 -> - forall ge1 ge2, match_genvs nil ge1 ge2 -> - match_genvs nil (add_globals ge1 gl1) (add_globals ge2 gl2). + forall gl1 gl2, + list_forall2 (fun idg1 idg2 => fst idg1 = fst idg2 /\ R (snd idg1) (snd idg2)) gl1 gl2 -> + forall ge1 ge2, match_genvs ge1 ge2 -> + match_genvs (add_globals ge1 gl1) (add_globals ge2 gl2). Proof. induction 1; intros; simpl. auto. + destruct a1 as [id1 g1]; destruct b1 as [id2 g2]; simpl in *; destruct H; subst id2. apply IHlist_forall2. apply add_global_match; auto. Qed. -Lemma add_global_augment_match: - forall new_globs ge1 ge2 idg, - match_genvs new_globs ge1 ge2 -> - match_genvs (new_globs ++ (idg :: nil)) ge1 (add_global ge2 idg). -Proof. - intros. destruct H. - assert (LE: Ple (genv_next ge1) (genv_next ge2)). - { rewrite mge_next0; apply advance_next_le. } - constructor; simpl. - rewrite mge_next0. unfold advance_next. rewrite fold_left_app. simpl. auto. - intros. rewrite map_app in H. rewrite in_app in H. simpl in H. - destruct (peq id idg#1). subst. intuition. rewrite PTree.gso. - apply mge_symb0. intuition. auto. - intros. destruct idg as [id1 [f1|v1]]; simpl; eauto. - rewrite PTree.gso. eauto. - exploit genv_funs_range; eauto. intros. - unfold Plt, Ple in *; zify; omega. - intros. rewrite map_app. destruct idg as [id1 [f1|v1]]; simpl in H. - rewrite PTree.gsspec in H. destruct (peq b (genv_next ge2)). - rewrite pred_dec_false. rewrite in_app. simpl; right; left. congruence. - subst b. unfold Plt, Ple in *; zify; omega. - exploit mge_rev_funs0; eauto. destruct (plt b (genv_next ge1)); auto. - rewrite in_app. tauto. - exploit mge_rev_funs0; eauto. destruct (plt b (genv_next ge1)); auto. - rewrite in_app. tauto. - intros. destruct idg as [id1 [f1|v1]]; simpl; eauto. - rewrite PTree.gso. eauto. exploit genv_vars_range; eauto. - unfold Plt, Ple in *; zify; omega. - intros. rewrite map_app. destruct idg as [id1 [f1|v1]]; simpl in H. - exploit mge_rev_vars0; eauto. destruct (plt b (genv_next ge1)); auto. - rewrite in_app. tauto. - rewrite PTree.gsspec in H. destruct (peq b (genv_next ge2)). - rewrite pred_dec_false. rewrite in_app. simpl; right; left. congruence. - subst b. unfold Plt, Ple in *; zify; omega. - exploit mge_rev_vars0; eauto. destruct (plt b (genv_next ge1)); auto. - rewrite in_app. tauto. -Qed. - -Lemma add_globals_augment_match: - forall gl new_globs ge1 ge2, - match_genvs new_globs ge1 ge2 -> - match_genvs (new_globs ++ gl) ge1 (add_globals ge2 gl). -Proof. - induction gl; simpl. - intros. rewrite app_nil_r. auto. - intros. change (a :: gl) with ((a :: nil) ++ gl). rewrite <- app_ass. - apply IHgl. apply add_global_augment_match. auto. -Qed. - -Variable new_globs : list (ident * globdef B W). -Variable new_main : ident. - -Variable p: program A V. -Variable p': program B W. -Hypothesis progmatch: - match_program match_fun match_varinfo new_globs new_main p p'. +End MATCH_GENVS. + +Section MATCH_PROGRAMS. + +Context {C F1 V1 F2 V2: Type} {LC: Linker C} {LF: Linker F1} {LV: Linker V1}. +Variable match_fundef: C -> F1 -> F2 -> Prop. +Variable match_varinfo: V1 -> V2 -> Prop. +Variable ctx: C. +Variable p: program F1 V1. +Variable tp: program F2 V2. +Hypothesis progmatch: match_program_gen match_fundef match_varinfo ctx p tp. Lemma globalenvs_match: - match_genvs new_globs (globalenv p) (globalenv p'). + match_genvs (match_globdef match_fundef match_varinfo ctx) (globalenv p) (globalenv tp). +Proof. + intros. apply add_globals_match. apply progmatch. + constructor; simpl; intros; auto. rewrite ! PTree.gempty. constructor. +Qed. + +Theorem find_def_match_2: + forall b, option_rel (match_globdef match_fundef match_varinfo ctx) + (find_def (globalenv p) b) (find_def (globalenv tp) b). +Proof (mge_defs globalenvs_match). + +Theorem find_def_match: + forall b g, + find_def (globalenv p) b = Some g -> + exists tg, + find_def (globalenv tp) b = Some tg /\ match_globdef match_fundef match_varinfo ctx g tg. Proof. - unfold globalenv. destruct progmatch as [[tglob [P Q]] R]. - rewrite Q. rewrite add_globals_app. - change new_globs with (nil ++ new_globs) at 1. - apply add_globals_augment_match. - apply add_globals_match; auto. - constructor; simpl; auto; intros; rewrite PTree.gempty in H; congruence. + intros. generalize (find_def_match_2 b). rewrite H; intros R; inv R. + exists y; auto. Qed. Theorem find_funct_ptr_match: - forall (b : block) (f : A), + forall b f, 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 -> - if plt b (genv_next (globalenv p)) then - exists f, find_funct_ptr (globalenv p) b = Some f /\ match_fun f tf - else - In (Gfun tf) (map snd new_globs). -Proof (mge_rev_funs globalenvs_match). + exists cunit tf, + find_funct_ptr (globalenv tp) b = Some tf /\ match_fundef cunit f tf /\ linkorder cunit ctx. +Proof. + intros. rewrite find_funct_ptr_iff in *. apply find_def_match in H. + destruct H as (tg & P & Q). inv Q. + exists ctx', f2; intuition auto. apply find_funct_ptr_iff; auto. +Qed. Theorem find_funct_match: - forall (v : val) (f : A), + forall v f, find_funct (globalenv p) v = Some f -> - exists tf : B, find_funct (globalenv p') v = Some tf /\ match_fun f tf. + exists cunit tf, + find_funct (globalenv tp) v = Some tf /\ match_fundef cunit f tf /\ linkorder cunit ctx. Proof. intros. exploit find_funct_inv; eauto. intros [b EQ]. subst v. rewrite find_funct_find_funct_ptr in H. @@ -1729,569 +1701,180 @@ Proof. apply find_funct_ptr_match. auto. Qed. -Theorem find_funct_rev_match: - 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) - \/ (In (Gfun tf) (map snd new_globs)). -Proof. - 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 in H. - destruct (plt b (genv_next (globalenv p))); auto. -Qed. - Theorem find_var_info_match: - forall (b : block) (v : globvar V), + forall b v, find_var_info (globalenv p) b = Some v -> exists tv, - find_var_info (globalenv p') b = Some tv /\ match_globvar v tv. -Proof (mge_vars globalenvs_match). - -Theorem find_var_info_rev_match: - forall (b : block) (tv : globvar W), - find_var_info (globalenv p') b = Some tv -> - if plt b (genv_next (globalenv p)) then - exists v, find_var_info (globalenv p) b = Some v /\ match_globvar v tv - else - In (Gvar tv) (map snd new_globs). -Proof (mge_rev_vars globalenvs_match). + find_var_info (globalenv tp) b = Some tv /\ match_globvar match_varinfo v tv. +Proof. + intros. rewrite find_var_info_iff in *. apply find_def_match in H. + destruct H as (tg & P & Q). inv Q. + exists v2; split; auto. apply find_var_info_iff; auto. +Qed. Theorem find_symbol_match: forall (s : ident), - ~In s (map fst new_globs) -> - find_symbol (globalenv p') s = find_symbol (globalenv p) s. + find_symbol (globalenv tp) s = find_symbol (globalenv p) s. Proof. - intros. destruct globalenvs_match. unfold find_symbol. auto. + intros. destruct globalenvs_match. apply mge_symb0. Qed. -Theorem public_symbol_match: - forall (s : ident), - ~In s (map fst new_globs) -> - public_symbol (globalenv p') s = public_symbol (globalenv p) s. +Theorem senv_match: + Senv.equiv (to_senv (globalenv p)) (to_senv (globalenv tp)). Proof. - intros. unfold public_symbol. rewrite find_symbol_match by auto. - destruct (find_symbol (globalenv p) s); auto. - rewrite ! globalenv_public. + red; simpl. repeat split. +- apply find_symbol_match. +- intros. unfold public_symbol. rewrite find_symbol_match. + rewrite ! globalenv_public. destruct progmatch as (P & Q & R). rewrite R. auto. +- intros. unfold block_is_volatile. + destruct globalenvs_match as [P Q R]. specialize (R b). + unfold find_var_info, find_def. + inv R; auto. + inv H1; auto. + inv H2; auto. Qed. -Hypothesis new_ids_fresh: - forall s, In s (prog_defs_names p) -> In s (map fst new_globs) -> False. -Hypothesis new_ids_unique: - list_norepet (map fst new_globs). - Lemma store_init_data_list_match: forall idl m b ofs m', store_init_data_list (globalenv p) m b ofs idl = Some m' -> - store_init_data_list (globalenv p') m b ofs idl = Some m'. + store_init_data_list (globalenv tp) m b ofs idl = Some m'. Proof. induction idl; simpl; intros. - auto. - assert (forall m', store_init_data (globalenv p) m b ofs a = Some m' -> - store_init_data (globalenv p') m b ofs a = Some m'). - destruct a; simpl; auto. rewrite find_symbol_match. auto. - simpl in H. destruct (find_symbol (globalenv p) i) as [b'|] eqn:?; try discriminate. - red; intros. exploit find_symbol_inversion; eauto. - case_eq (store_init_data (globalenv p) m b ofs a); intros. - rewrite H1 in H. - pose proof (H0 _ H1). rewrite H2. auto. - rewrite H1 in H. inversion H. +- auto. +- destruct (store_init_data (globalenv p) m b ofs a) as [m1|] eqn:S; try discriminate. + assert (X: store_init_data (globalenv tp) m b ofs a = Some m1). + { destruct a; auto. simpl; rewrite find_symbol_match; auto. } + rewrite X. auto. Qed. Lemma alloc_globals_match: - forall gl1 gl2, list_forall2 (match_globdef match_fun match_varinfo) gl1 gl2 -> + forall gl1 gl2, list_forall2 (match_ident_globdef match_fundef match_varinfo ctx) gl1 gl2 -> forall m m', alloc_globals (globalenv p) m gl1 = Some m' -> - alloc_globals (globalenv p') m gl2 = Some m'. + alloc_globals (globalenv tp) m gl2 = Some m'. Proof. induction 1; simpl; intros. - auto. - destruct (alloc_global (globalenv p) m a1) as [m1|] eqn:?; try discriminate. - assert (alloc_global (globalenv p') m b1 = Some m1). - inv H; simpl in *. - auto. +- auto. +- destruct (alloc_global (globalenv p) m a1) as [m1|] eqn:?; try discriminate. + assert (X: alloc_global (globalenv tp) m b1 = Some m1). + { destruct a1 as [id1 g1]; destruct b1 as [id2 g2]; destruct H; simpl in *. + subst id2. inv H2. + - auto. + - inv H; simpl in *. set (sz := init_data_list_size init) in *. destruct (Mem.alloc m 0 sz) as [m2 b] eqn:?. destruct (store_zeros m2 b 0 sz) as [m3|] eqn:?; try discriminate. destruct (store_init_data_list (globalenv p) m3 b 0 init) as [m4|] eqn:?; try discriminate. erewrite store_init_data_list_match; eauto. - rewrite H2. eauto. + } + rewrite X; eauto. Qed. Theorem init_mem_match: - forall m, init_mem p = Some m -> - init_mem p' = alloc_globals (globalenv p') m new_globs. + forall m, init_mem p = Some m -> init_mem tp = Some m. Proof. unfold init_mem; intros. - destruct progmatch as [[tglob [P Q]] R]. - rewrite Q. erewrite <- alloc_globals_app; eauto. - eapply alloc_globals_match; eauto. -Qed. - -Theorem find_new_funct_ptr_match: - forall id f, In (id, Gfun f) new_globs -> - exists b, - find_symbol (globalenv p') id = Some b - /\ find_funct_ptr (globalenv p') b = Some f. -Proof. - intros. - destruct progmatch as [[tglob [P Q]] R]. - exploit in_norepet_unique; eauto. intros (gl1 & gl2 & S & T). - rewrite S in Q. rewrite <- app_ass in Q. - eapply find_funct_ptr_exists_2; eauto. -Qed. - -Theorem find_new_var_match: - forall id v, In (id, Gvar v) new_globs -> - exists b, - find_symbol (globalenv p') id = Some b - /\ find_var_info (globalenv p') b = Some v. -Proof. - intros. - destruct progmatch as [[tglob [P Q]] R]. - exploit in_norepet_unique; eauto. intros (gl1 & gl2 & S & T). - rewrite S in Q. rewrite <- app_ass in Q. - eapply find_var_exists_2; eauto. + eapply alloc_globals_match; eauto. apply progmatch. Qed. End MATCH_PROGRAMS. -Section TRANSF_PROGRAM_AUGMENT. - -Variable A B V W: Type. -Variable transf_fun: A -> res B. -Variable transf_var: V -> res W. +(** Special case for partial transformations that do not depend on the compilation unit *) -Variable new_globs : list (ident * globdef B W). -Variable new_main : ident. +Section TRANSFORM_PARTIAL. -Variable p: program A V. -Variable p': program B W. - -Hypothesis transf_OK: - transform_partial_augment_program transf_fun transf_var new_globs new_main p = OK p'. - -Let prog_match: - match_program - (fun fd tfd => transf_fun fd = OK tfd) - (fun info tinfo => transf_var info = OK tinfo) - new_globs new_main - p p'. -Proof. - apply transform_partial_augment_program_match; auto. -Qed. - -Theorem find_funct_ptr_transf_augment: - 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'. -Proof. - intros. - exploit find_funct_ptr_match. eexact prog_match. eauto. - intros [tf [X Y]]. exists tf; auto. -Qed. - -Theorem find_funct_ptr_rev_transf_augment: - forall (b: block) (tf: B), - find_funct_ptr (globalenv p') b = Some tf -> - if plt b (genv_next (globalenv p)) then - (exists f, find_funct_ptr (globalenv p) b = Some f /\ transf_fun f = OK tf) - else - In (Gfun tf) (map snd new_globs). -Proof. - intros. - exploit find_funct_ptr_rev_match; eauto. -Qed. - -Theorem find_funct_transf_augment: - 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'. -Proof. - intros. - exploit find_funct_match. eexact prog_match. eauto. auto. -Qed. - -Theorem find_funct_rev_transf_augment: - forall (v: val) (tf: B), - find_funct (globalenv p') v = Some tf -> - (exists f, find_funct (globalenv p) v = Some f /\ transf_fun f = OK tf) \/ - In (Gfun tf) (map snd new_globs). -Proof. - intros. - exploit find_funct_rev_match. eexact prog_match. eauto. auto. -Qed. - -Theorem find_var_info_transf_augment: - forall (b: block) (v: globvar V), - find_var_info (globalenv p) b = Some v -> - exists v', - find_var_info (globalenv p') b = Some v' /\ transf_globvar transf_var v = OK v'. -Proof. - intros. - exploit find_var_info_match. eexact prog_match. eauto. intros [tv [X Y]]. - exists tv; split; auto. inv Y. unfold transf_globvar; simpl. - rewrite H0; simpl. auto. -Qed. - -Theorem find_var_info_rev_transf_augment: - forall (b: block) (v': globvar W), - find_var_info (globalenv p') b = Some v' -> - if plt b (genv_next (globalenv p)) then - (exists v, find_var_info (globalenv p) b = Some v /\ transf_globvar transf_var v = OK v') - else - (In (Gvar v') (map snd new_globs)). -Proof. - intros. - exploit find_var_info_rev_match. eexact prog_match. eauto. - destruct (plt b (genv_next (globalenv p))); auto. - intros [v [X Y]]. exists v; split; auto. inv Y. unfold transf_globvar; simpl. - rewrite H0; simpl. auto. -Qed. - -Theorem find_symbol_transf_augment: - forall (s: ident), - ~ In s (map fst new_globs) -> - find_symbol (globalenv p') s = find_symbol (globalenv p) s. -Proof. - intros. eapply find_symbol_match. eexact prog_match. auto. -Qed. - -Theorem public_symbol_transf_augment: - forall (s: ident), - ~ In s (map fst new_globs) -> - public_symbol (globalenv p') s = public_symbol (globalenv p) s. -Proof. - intros. eapply public_symbol_match. eexact prog_match. auto. -Qed. - -Hypothesis new_ids_fresh: - forall s, In s (prog_defs_names p) -> In s (map fst new_globs) -> False. -Hypothesis new_ids_unique: - list_norepet (map fst new_globs). - -Theorem init_mem_transf_augment: - forall m, init_mem p = Some m -> - init_mem p' = alloc_globals (globalenv p') m new_globs. -Proof. - intros. eapply init_mem_match. eexact prog_match. auto. auto. -Qed. - -Theorem init_mem_inject_transf_augment: - forall m, init_mem p = Some m -> - forall m', init_mem p' = Some m' -> - Mem.inject (Mem.flat_inj (Mem.nextblock m)) m m'. -Proof. - intros. - pose proof (initmem_inject p H). - erewrite init_mem_transf_augment in H0; eauto. - eapply alloc_globals_augment; eauto. apply Ple_refl. -Qed. - -Theorem find_new_funct_ptr_exists: - forall id f, In (id, Gfun f) new_globs -> - exists b, find_symbol (globalenv p') id = Some b - /\ find_funct_ptr (globalenv p') b = Some f. -Proof. - intros. eapply find_new_funct_ptr_match; eauto. -Qed. - -Theorem find_new_var_exists: - forall id gv, In (id, Gvar gv) new_globs -> - exists b, find_symbol (globalenv p') id = Some b - /\ find_var_info (globalenv p') b = Some gv. -Proof. - intros. eapply find_new_var_match; eauto. -Qed. - -End TRANSF_PROGRAM_AUGMENT. - -Section TRANSF_PROGRAM_PARTIAL2. - -Variable A B V W: Type. -Variable transf_fun: A -> res B. -Variable transf_var: V -> res W. -Variable p: program A V. -Variable p': program B W. -Hypothesis transf_OK: - transform_partial_program2 transf_fun transf_var p = OK p'. - -Remark transf_augment_OK: - transform_partial_augment_program transf_fun transf_var nil p.(prog_main) p = OK p'. -Proof. - rewrite <- transf_OK. symmetry. apply transform_partial_program2_augment. -Qed. - -Theorem find_funct_ptr_transf_partial2: - 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'. -Proof. - exact (@find_funct_ptr_transf_augment _ _ _ _ _ _ _ _ _ _ transf_augment_OK). -Qed. - -Theorem find_funct_ptr_rev_transf_partial2: - forall (b: block) (tf: B), - find_funct_ptr (globalenv p') b = Some tf -> - exists f, find_funct_ptr (globalenv p) b = Some f /\ transf_fun f = OK tf. -Proof. - pose proof (@find_funct_ptr_rev_transf_augment _ _ _ _ _ _ _ _ _ _ transf_augment_OK). - intros. pose proof (H b tf H0). - destruct (plt b (genv_next (globalenv p))). auto. contradiction. -Qed. - -Theorem find_funct_transf_partial2: - 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'. -Proof. - exact (@find_funct_transf_augment _ _ _ _ _ _ _ _ _ _ transf_augment_OK). -Qed. - -Theorem find_funct_rev_transf_partial2: - forall (v: val) (tf: B), - find_funct (globalenv p') v = Some tf -> - exists f, find_funct (globalenv p) v = Some f /\ transf_fun f = OK tf. -Proof. - pose proof (@find_funct_rev_transf_augment _ _ _ _ _ _ _ _ _ _ transf_augment_OK). - intros. pose proof (H v tf H0). - destruct H1. auto. contradiction. -Qed. - -Theorem find_var_info_transf_partial2: - forall (b: block) (v: globvar V), - find_var_info (globalenv p) b = Some v -> - exists v', - find_var_info (globalenv p') b = Some v' /\ transf_globvar transf_var v = OK v'. -Proof. - exact (@find_var_info_transf_augment _ _ _ _ _ _ _ _ _ _ transf_augment_OK). -Qed. - -Theorem find_var_info_rev_transf_partial2: - forall (b: block) (v': globvar W), - find_var_info (globalenv p') b = Some v' -> - exists v, - find_var_info (globalenv p) b = Some v /\ transf_globvar transf_var v = OK v'. -Proof. - pose proof (@find_var_info_rev_transf_augment _ _ _ _ _ _ _ _ _ _ transf_augment_OK). - intros. pose proof (H b v' H0). - destruct (plt b (genv_next (globalenv p))). auto. contradiction. -Qed. - -Theorem find_symbol_transf_partial2: - forall (s: ident), - find_symbol (globalenv p') s = find_symbol (globalenv p) s. -Proof. - pose proof (@find_symbol_transf_augment _ _ _ _ _ _ _ _ _ _ transf_augment_OK). - auto. -Qed. - -Theorem public_symbol_transf_partial2: - forall (s: ident), - public_symbol (globalenv p') s = public_symbol (globalenv p) s. -Proof. - pose proof (@public_symbol_transf_augment _ _ _ _ _ _ _ _ _ _ transf_augment_OK). - auto. -Qed. - -Theorem block_is_volatile_transf_partial2: - forall (b: block), - block_is_volatile (globalenv p') b = block_is_volatile (globalenv p) b. -Proof. - unfold block_is_volatile; intros. - destruct (find_var_info (globalenv p) b) as [v|] eqn:FV. - exploit find_var_info_transf_partial2; eauto. intros (v' & P & Q). - rewrite P. monadInv Q. auto. - destruct (find_var_info (globalenv p') b) as [v'|] eqn:FV'. - exploit find_var_info_rev_transf_partial2; eauto. intros (v & P & Q). congruence. - auto. -Qed. - -Theorem init_mem_transf_partial2: - forall m, init_mem p = Some m -> init_mem p' = Some m. -Proof. - pose proof (@init_mem_transf_augment _ _ _ _ _ _ _ _ _ _ transf_augment_OK). - intros. simpl in H. apply H; auto. -Qed. - -End TRANSF_PROGRAM_PARTIAL2. - -Section TRANSF_PROGRAM_PARTIAL. - -Variable A B V: Type. -Variable transf: A -> res B. -Variable p: program A V. -Variable p': program B V. -Hypothesis transf_OK: transform_partial_program transf p = OK p'. +Context {A B V: Type} {LA: Linker A} {LV: Linker V}. +Context {transf: A -> res B} {p: program A V} {tp: program B V}. +Hypothesis progmatch: match_program (fun cu f tf => transf f = OK tf) eq p tp. Theorem find_funct_ptr_transf_partial: - forall (b: block) (f: A), + forall b f, find_funct_ptr (globalenv p) b = Some f -> - exists f', - find_funct_ptr (globalenv p') b = Some f' /\ transf f = OK f'. -Proof. - exact (@find_funct_ptr_transf_partial2 _ _ _ _ _ _ _ _ transf_OK). -Qed. - -Theorem find_funct_ptr_rev_transf_partial: - forall (b: block) (tf: B), - find_funct_ptr (globalenv p') b = Some tf -> - exists f, find_funct_ptr (globalenv p) b = Some f /\ transf f = OK tf. + exists tf, + find_funct_ptr (globalenv tp) b = Some tf /\ transf f = OK tf. Proof. - exact (@find_funct_ptr_rev_transf_partial2 _ _ _ _ _ _ _ _ transf_OK). + intros. exploit (find_funct_ptr_match progmatch); eauto. + intros (cu & tf & P & Q & R); exists tf; auto. Qed. Theorem find_funct_transf_partial: - forall (v: val) (f: A), + forall v f, find_funct (globalenv p) v = Some f -> - exists f', - find_funct (globalenv p') v = Some f' /\ transf f = OK f'. -Proof. - exact (@find_funct_transf_partial2 _ _ _ _ _ _ _ _ transf_OK). -Qed. - -Theorem find_funct_rev_transf_partial: - forall (v: val) (tf: B), - find_funct (globalenv p') v = Some tf -> - exists f, find_funct (globalenv p) v = Some f /\ transf f = OK tf. + exists tf, + find_funct (globalenv tp) v = Some tf /\ transf f = OK tf. Proof. - exact (@find_funct_rev_transf_partial2 _ _ _ _ _ _ _ _ transf_OK). + intros. exploit (find_funct_match progmatch); eauto. + intros (cu & tf & P & Q & R); exists tf; auto. Qed. Theorem find_symbol_transf_partial: - forall (s: ident), - find_symbol (globalenv p') s = find_symbol (globalenv p) s. -Proof. - exact (@find_symbol_transf_partial2 _ _ _ _ _ _ _ _ transf_OK). -Qed. - -Theorem public_symbol_transf_partial: - forall (s: ident), - public_symbol (globalenv p') s = public_symbol (globalenv p) s. -Proof. - exact (@public_symbol_transf_partial2 _ _ _ _ _ _ _ _ transf_OK). -Qed. - -Theorem find_var_info_transf_partial: - forall (b: block), - find_var_info (globalenv p') b = find_var_info (globalenv p) b. + forall (s : ident), + find_symbol (globalenv tp) s = find_symbol (globalenv p) s. Proof. - intros. case_eq (find_var_info (globalenv p) b); intros. - exploit find_var_info_transf_partial2. eexact transf_OK. eauto. - intros [v' [P Q]]. monadInv Q. rewrite P. inv EQ. destruct g; auto. - case_eq (find_var_info (globalenv p') b); intros. - exploit find_var_info_rev_transf_partial2. eexact transf_OK. eauto. - intros [v' [P Q]]. monadInv Q. inv EQ. congruence. - auto. + intros. eapply (find_symbol_match progmatch). Qed. -Theorem block_is_volatile_transf_partial: - forall (b: block), - block_is_volatile (globalenv p') b = block_is_volatile (globalenv p) b. +Theorem senv_transf_partial: + Senv.equiv (to_senv (globalenv p)) (to_senv (globalenv tp)). Proof. - exact (@block_is_volatile_transf_partial2 _ _ _ _ _ _ _ _ transf_OK). + intros. eapply (senv_match progmatch). Qed. Theorem init_mem_transf_partial: - forall m, init_mem p = Some m -> init_mem p' = Some m. + forall m, init_mem p = Some m -> init_mem tp = Some m. Proof. - exact (@init_mem_transf_partial2 _ _ _ _ _ _ _ _ transf_OK). + eapply (init_mem_match progmatch). Qed. -End TRANSF_PROGRAM_PARTIAL. +End TRANSFORM_PARTIAL. -Section TRANSF_PROGRAM. +(** Special case for total transformations that do not depend on the compilation unit *) -Variable A B V: Type. -Variable transf: A -> B. -Variable p: program A V. -Let tp := transform_program transf p. +Section TRANSFORM_TOTAL. -Remark transf_OK: - transform_partial_program (fun x => OK (transf x)) p = OK tp. -Proof. - unfold tp. apply transform_program_partial_program. -Qed. +Context {A B V: Type} {LA: Linker A} {LV: Linker V}. +Context {transf: A -> B} {p: program A V} {tp: program B V}. +Hypothesis progmatch: match_program (fun cu f tf => tf = transf f) eq p tp. Theorem find_funct_ptr_transf: - forall (b: block) (f: A), + forall b f, find_funct_ptr (globalenv p) b = Some f -> find_funct_ptr (globalenv tp) b = Some (transf f). Proof. - intros. - destruct (@find_funct_ptr_transf_partial _ _ _ _ _ _ transf_OK _ _ H) - as [f' [X Y]]. congruence. -Qed. - -Theorem find_funct_ptr_rev_transf: - forall (b: block) (tf: B), - find_funct_ptr (globalenv tp) b = Some tf -> - exists f, find_funct_ptr (globalenv p) b = Some f /\ transf f = tf. -Proof. - intros. exploit find_funct_ptr_rev_transf_partial. eexact transf_OK. eauto. - intros [f [X Y]]. exists f; split. auto. congruence. + intros. exploit (find_funct_ptr_match progmatch); eauto. + intros (cu & tf & P & Q & R). congruence. Qed. Theorem find_funct_transf: - forall (v: val) (f: A), + forall v f, find_funct (globalenv p) v = Some f -> find_funct (globalenv tp) v = Some (transf f). Proof. - intros. - destruct (@find_funct_transf_partial _ _ _ _ _ _ transf_OK _ _ H) - as [f' [X Y]]. congruence. -Qed. - -Theorem find_funct_rev_transf: - forall (v: val) (tf: B), - find_funct (globalenv tp) v = Some tf -> - exists f, find_funct (globalenv p) v = Some f /\ transf f = tf. -Proof. - intros. exploit find_funct_rev_transf_partial. eexact transf_OK. eauto. - intros [f [X Y]]. exists f; split. auto. congruence. + intros. exploit (find_funct_match progmatch); eauto. + intros (cu & tf & P & Q & R). congruence. Qed. Theorem find_symbol_transf: - forall (s: ident), + forall (s : ident), find_symbol (globalenv tp) s = find_symbol (globalenv p) s. Proof. - exact (@find_symbol_transf_partial _ _ _ _ _ _ transf_OK). -Qed. - -Theorem public_symbol_transf: - forall (s: ident), - public_symbol (globalenv tp) s = public_symbol (globalenv p) s. -Proof. - exact (@public_symbol_transf_partial _ _ _ _ _ _ transf_OK). -Qed. - -Theorem find_var_info_transf: - forall (b: block), - find_var_info (globalenv tp) b = find_var_info (globalenv p) b. -Proof. - exact (@find_var_info_transf_partial _ _ _ _ _ _ transf_OK). + intros. eapply (find_symbol_match progmatch). Qed. -Theorem block_is_volatile_transf: - forall (b: block), - block_is_volatile (globalenv tp) b = block_is_volatile (globalenv p) b. +Theorem senv_transf: + Senv.equiv (to_senv (globalenv p)) (to_senv (globalenv tp)). Proof. - exact (@block_is_volatile_transf_partial _ _ _ _ _ _ transf_OK). + intros. eapply (senv_match progmatch). Qed. Theorem init_mem_transf: forall m, init_mem p = Some m -> init_mem tp = Some m. Proof. - exact (@init_mem_transf_partial _ _ _ _ _ _ transf_OK). + eapply (init_mem_match progmatch). Qed. -End TRANSF_PROGRAM. +End TRANSFORM_TOTAL. End Genv. diff --git a/common/Linking.v b/common/Linking.v new file mode 100644 index 00000000..52e774db --- /dev/null +++ b/common/Linking.v @@ -0,0 +1,905 @@ +(* *********************************************************************) +(* *) +(* 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. *) +(* *) +(* *********************************************************************) + +(** Separate compilation and syntactic linking *) + +Require Import Coqlib Maps Errors AST. + +(** This file follows "approach A" from the paper + "Lightweight Verification of Separate Compilation" + by Kang, Kim, Hur, Dreyer and Vafeiadis, POPL 2016. *) + + +(** * Syntactic linking *) + +(** A syntactic element [A] supports syntactic linking if it is equipped with the following: +- a partial binary operator [link] that produces the result of linking two elements, + or fails if they cannot be linked (e.g. two definitions that are incompatible); +- a preorder [linkorder] with the meaning that [linkorder a1 a2] holds + if [a2] can be obtained by linking [a1] with some other syntactic element. +*) + +Class Linker (A: Type) := { + link: A -> A -> option A; + linkorder: A -> A -> Prop; + linkorder_refl: forall x, linkorder x x; + linkorder_trans: forall x y z, linkorder x y -> linkorder y z -> linkorder x z; + link_linkorder: forall x y z, link x y = Some z -> linkorder x z /\ linkorder y z +}. + +(** Linking function definitions. External functions of the [EF_external] + kind can link with internal function definitions; the result of + linking is the internal definition. Two external functions can link + if they are identical. *) + +Definition link_fundef {F: Type} (fd1 fd2: fundef F) := + match fd1, fd2 with + | Internal _, Internal _ => None + | External ef1, External ef2 => + if external_function_eq ef1 ef2 then Some (External ef1) else None + | Internal f, External ef => + match ef with EF_external id sg => Some (Internal f) | _ => None end + | External ef, Internal f => + match ef with EF_external id sg => Some (Internal f) | _ => None end + end. + +Inductive linkorder_fundef {F: Type}: fundef F -> fundef F -> Prop := + | linkorder_fundef_refl: forall fd, linkorder_fundef fd fd + | linkorder_fundef_ext_int: forall f id sg, linkorder_fundef (External (EF_external id sg)) (Internal f). + +Instance Linker_fundef (F: Type): Linker (fundef F) := { + link := link_fundef; + linkorder := linkorder_fundef +}. +Proof. +- intros; constructor. +- intros. inv H; inv H0; constructor. +- intros x y z EQ. destruct x, y; simpl in EQ. ++ discriminate. ++ destruct e; inv EQ. split; constructor. ++ destruct e; inv EQ. split; constructor. ++ destruct (external_function_eq e e0); inv EQ. split; constructor. +Defined. + +Global Opaque Linker_fundef. + +(** Linking variable initializers. We adopt the following conventions: +- an "extern" variable has an empty initialization list; +- a "common" variable has an initialization list of the form [Init_space sz]; +- all other initialization lists correspond to fully defined variables, neither "common" nor "extern". +*) + +Inductive init_class : list init_data -> Type := + | Init_extern: init_class nil + | Init_common: forall sz, init_class (Init_space sz :: nil) + | Init_definitive: forall il, init_class il. + +Definition classify_init (i: list init_data) : init_class i := + match i with + | nil => Init_extern + | Init_space sz :: nil => Init_common sz + | i => Init_definitive i + end. + +Definition link_varinit (i1 i2: list init_data) := + match classify_init i1, classify_init i2 with + | Init_extern, _ => Some i2 + | _, Init_extern => Some i1 + | Init_common sz1, _ => if zeq sz1 (init_data_list_size i2) then Some i2 else None + | _, Init_common sz2 => if zeq sz2 (init_data_list_size i1) then Some i1 else None + | _, _ => None + end. + +Inductive linkorder_varinit: list init_data -> list init_data -> Prop := + | linkorder_varinit_refl: forall il, linkorder_varinit il il + | linkorder_varinit_extern: forall il, linkorder_varinit nil il + | linkorder_varinit_common: forall sz il, + il <> nil -> init_data_list_size il = sz -> + linkorder_varinit (Init_space sz :: nil) il. + +Instance Linker_varinit : Linker (list init_data) := { + link := link_varinit; + linkorder := linkorder_varinit +}. +Proof. +- intros. constructor. +- intros. inv H; inv H0; constructor; auto. + congruence. + simpl. generalize (init_data_list_size_pos z). xomega. +- unfold link_varinit; intros until z. + destruct (classify_init x) eqn:Cx, (classify_init y) eqn:Cy; intros E; inv E; try (split; constructor; fail). ++ destruct (zeq sz (Z.max sz0 0 + 0)); inv H0. + split; constructor. congruence. auto. ++ destruct (zeq sz (init_data_list_size il)); inv H0. + split; constructor. red; intros; subst z; discriminate. auto. ++ destruct (zeq sz (init_data_list_size il)); inv H0. + split; constructor. red; intros; subst z; discriminate. auto. +Defined. + +Global Opaque Linker_varinit. + +(** Linking variable definitions. *) + +Definition link_vardef {V: Type} {LV: Linker V} (v1 v2: globvar V) := + match link v1.(gvar_info) v2.(gvar_info) with + | None => None + | Some info => + match link v1.(gvar_init) v2.(gvar_init) with + | None => None + | Some init => + if eqb v1.(gvar_readonly) v2.(gvar_readonly) + && eqb v1.(gvar_volatile) v2.(gvar_volatile) + then Some {| gvar_info := info; gvar_init := init; + gvar_readonly := v1.(gvar_readonly); + gvar_volatile := v1.(gvar_volatile) |} + else None + end + end. + +Inductive linkorder_vardef {V: Type} {LV: Linker V}: globvar V -> globvar V -> Prop := + | linkorder_vardef_intro: forall info1 info2 i1 i2 ro vo, + linkorder info1 info2 -> + linkorder i1 i2 -> + linkorder_vardef (mkglobvar info1 i1 ro vo) (mkglobvar info2 i2 ro vo). + +Instance Linker_vardef (V: Type) {LV: Linker V}: Linker (globvar V) := { + link := link_vardef; + linkorder := linkorder_vardef +}. +Proof. +- intros. destruct x; constructor; apply linkorder_refl. +- intros. inv H; inv H0. constructor; eapply linkorder_trans; eauto. +- unfold link_vardef; intros until z. + destruct x as [f1 i1 r1 v1], y as [f2 i2 r2 v2]; simpl. + destruct (link f1 f2) as [f|] eqn:LF; try discriminate. + destruct (link i1 i2) as [i|] eqn:LI; try discriminate. + destruct (eqb r1 r2) eqn:ER; try discriminate. + destruct (eqb v1 v2) eqn:EV; intros EQ; inv EQ. + apply eqb_prop in ER; apply eqb_prop in EV; subst r2 v2. + apply link_linkorder in LF. apply link_linkorder in LI. + split; constructor; tauto. +Defined. + +Global Opaque Linker_vardef. + +(** A trivial linker for the trivial var info [unit]. *) + +Instance Linker_unit: Linker unit := { + link := fun x y => Some tt; + linkorder := fun x y => True +}. +Proof. +- auto. +- auto. +- auto. +Defined. + +Global Opaque Linker_unit. + +(** Linking global definitions *) + +Definition link_def {F V: Type} {LF: Linker F} {LV: Linker V} (gd1 gd2: globdef F V) := + match gd1, gd2 with + | Gfun f1, Gfun f2 => + match link f1 f2 with Some f => Some (Gfun f) | None => None end + | Gvar v1, Gvar v2 => + match link v1 v2 with Some v => Some (Gvar v) | None => None end + | _, _ => None + end. + +Inductive linkorder_def {F V: Type} {LF: Linker F} {LV: Linker V}: globdef F V -> globdef F V -> Prop := + | linkorder_def_fun: forall fd1 fd2, + linkorder fd1 fd2 -> + linkorder_def (Gfun fd1) (Gfun fd2) + | linkorder_def_var: forall v1 v2, + linkorder v1 v2 -> + linkorder_def (Gvar v1) (Gvar v2). + +Instance Linker_def (F V: Type) {LF: Linker F} {LV: Linker V}: Linker (globdef F V) := { + link := link_def; + linkorder := linkorder_def +}. +Proof. +- intros. destruct x; constructor; apply linkorder_refl. +- intros. inv H; inv H0; constructor; eapply linkorder_trans; eauto. +- unfold link_def; intros. + destruct x as [f1|v1], y as [f2|v2]; try discriminate. ++ destruct (link f1 f2) as [f|] eqn:L; inv H. apply link_linkorder in L. + split; constructor; tauto. ++ destruct (link v1 v2) as [v|] eqn:L; inv H. apply link_linkorder in L. + split; constructor; tauto. +Defined. + +Global Opaque Linker_def. + +(** Linking two compilation units. Compilation units are represented like + whole programs using the type [program F V]. If a name has + a global definition in one unit but not in the other, this definition + is left unchanged in the result of the link. If a name has + global definitions in both units, and is public (not static) in both, + the two definitions are linked as per [Linker_def] above. + + If one or both definitions are static (not public), we should ideally + rename it so that it can be kept unchanged in the result of the link. + This would require a general notion of renaming of global identifiers + in programs that we do not have yet. Hence, as a first step, linking + is undefined if static definitions with the same name appear in both + compilation units. *) + +Section LINKER_PROG. + +Context {F V: Type} {LF: Linker F} {LV: Linker V} (p1 p2: program F V). + +Let dm1 := prog_defmap p1. +Let dm2 := prog_defmap p2. + +Definition link_prog_check (x: ident) (gd1: globdef F V) := + match dm2!x with + | None => true + | Some gd2 => + In_dec peq x p1.(prog_public) + && In_dec peq x p2.(prog_public) + && match link gd1 gd2 with Some _ => true | None => false end + end. + +Definition link_prog_merge (o1 o2: option (globdef F V)) := + match o1, o2 with + | None, _ => o2 + | _, None => o1 + | Some gd1, Some gd2 => link gd1 gd2 + end. + +Definition link_prog := + if ident_eq p1.(prog_main) p2.(prog_main) + && PTree_Properties.for_all dm1 link_prog_check then + Some {| prog_main := p1.(prog_main); + prog_public := p1.(prog_public) ++ p2.(prog_public); + prog_defs := PTree.elements (PTree.combine link_prog_merge dm1 dm2) |} + else + None. + +Lemma link_prog_inv: + forall p, + link_prog = Some p -> + p1.(prog_main) = p2.(prog_main) + /\ (forall id gd1 gd2, + dm1!id = Some gd1 -> dm2!id = Some gd2 -> + In id p1.(prog_public) /\ In id p2.(prog_public) /\ exists gd, link gd1 gd2 = Some gd) + /\ p = {| prog_main := p1.(prog_main); + prog_public := p1.(prog_public) ++ p2.(prog_public); + prog_defs := PTree.elements (PTree.combine link_prog_merge dm1 dm2) |}. +Proof. + unfold link_prog; intros p E. + destruct (ident_eq (prog_main p1) (prog_main p2)); try discriminate. + destruct (PTree_Properties.for_all dm1 link_prog_check) eqn:C; inv E. + rewrite PTree_Properties.for_all_correct in C. + split; auto. split; auto. + intros. exploit C; eauto. unfold link_prog_check. rewrite H0. intros. + destruct (in_dec peq id (prog_public p1)); try discriminate. + destruct (in_dec peq id (prog_public p2)); try discriminate. + destruct (link gd1 gd2) eqn:L; try discriminate. + intuition auto. exists g; auto. +Qed. + +Lemma link_prog_succeeds: + p1.(prog_main) = p2.(prog_main) -> + (forall id gd1 gd2, + dm1!id = Some gd1 -> dm2!id = Some gd2 -> + In id p1.(prog_public) /\ In id p2.(prog_public) /\ link gd1 gd2 <> None) -> + link_prog = + Some {| prog_main := p1.(prog_main); + prog_public := p1.(prog_public) ++ p2.(prog_public); + prog_defs := PTree.elements (PTree.combine link_prog_merge dm1 dm2) |}. +Proof. + intros. unfold link_prog. unfold proj_sumbool. rewrite H, dec_eq_true. simpl. + replace (PTree_Properties.for_all dm1 link_prog_check) with true; auto. + symmetry. apply PTree_Properties.for_all_correct; intros. rename a into gd1. + unfold link_prog_check. destruct dm2!x as [gd2|] eqn:G2; auto. + exploit H0; eauto. intros (P & Q & R). unfold proj_sumbool; rewrite ! pred_dec_true by auto. + destruct (link gd1 gd2); auto; discriminate. +Qed. + +Lemma prog_defmap_elements: + forall (m: PTree.t (globdef F V)) pub mn x, + (prog_defmap {| prog_defs := PTree.elements m; prog_public := pub; prog_main := mn |})!x = m!x. +Proof. + intros. unfold prog_defmap; simpl. apply PTree_Properties.of_list_elements. +Qed. + +End LINKER_PROG. + +Instance Linker_prog (F V: Type) {LF: Linker F} {LV: Linker V} : Linker (program F V) := { + link := link_prog; + linkorder := fun p1 p2 => + p1.(prog_main) = p2.(prog_main) + /\ incl p1.(prog_public) p2.(prog_public) + /\ forall id gd1, + (prog_defmap p1)!id = Some gd1 -> + exists gd2, + (prog_defmap p2)!id = Some gd2 + /\ linkorder gd1 gd2 + /\ (~In id p2.(prog_public) -> gd2 = gd1) +}. +Proof. +- intros; split; auto. split. apply incl_refl. intros. + exists gd1; split; auto. split; auto. apply linkorder_refl. + +- intros x y z (A1 & B1 & C1) (A2 & B2 & C2). + split. congruence. split. red; eauto. + intros. exploit C1; eauto. intros (gd2 & P & Q & R). + exploit C2; eauto. intros (gd3 & U & X & Y). + exists gd3. split; auto. split. eapply linkorder_trans; eauto. + intros. transitivity gd2. apply Y. auto. apply R. red; intros; elim H0; auto. + +- intros. apply link_prog_inv in H. destruct H as (L1 & L2 & L3). + subst z; simpl. intuition auto. ++ red; intros; apply in_app_iff; auto. ++ rewrite prog_defmap_elements, PTree.gcombine, H by auto. + destruct (prog_defmap y)!id as [gd2|] eqn:GD2; simpl. +* exploit L2; eauto. intros (P & Q & gd & R). + exists gd; split. auto. split. apply link_linkorder in R; tauto. + rewrite in_app_iff; tauto. +* exists gd1; split; auto. split. apply linkorder_refl. auto. ++ red; intros; apply in_app_iff; auto. ++ rewrite prog_defmap_elements, PTree.gcombine, H by auto. + destruct (prog_defmap x)!id as [gd2|] eqn:GD2; simpl. +* exploit L2; eauto. intros (P & Q & gd & R). + exists gd; split. auto. split. apply link_linkorder in R; tauto. + rewrite in_app_iff; tauto. +* exists gd1; split; auto. split. apply linkorder_refl. auto. +Defined. + +Lemma prog_defmap_linkorder: + forall {F V: Type} {LF: Linker F} {LV: Linker V} (p1 p2: program F V) id gd1, + linkorder p1 p2 -> + (prog_defmap p1)!id = Some gd1 -> + exists gd2, (prog_defmap p2)!id = Some gd2 /\ linkorder gd1 gd2. +Proof. + intros. destruct H as (A & B & C). + exploit C; eauto. intros (gd2 & P & Q & R). exists gd2; auto. +Qed. + +Global Opaque Linker_prog. + +(** * Matching between two programs *) + +(** The following is a relational presentation of program transformations, + e.g. [transf_partial_program] from module [AST]. *) + +(** To capture the possibility of separate compilation, we parameterize + the [match_fundef] relation between function definitions with + a context, e.g. the compilation unit from which the function definition comes. + This unit is characterized as any program that is in the [linkorder] + relation with the final, whole program. *) + +Section MATCH_PROGRAM_GENERIC. + +Context {C F1 V1 F2 V2: Type} {LC: Linker C} {LF: Linker F1} {LV: Linker V1}. +Variable match_fundef: C -> F1 -> F2 -> Prop. +Variable match_varinfo: V1 -> V2 -> Prop. + +Inductive match_globvar: globvar V1 -> globvar V2 -> Prop := + | match_globvar_intro: forall i1 i2 init ro vo, + match_varinfo i1 i2 -> + match_globvar (mkglobvar i1 init ro vo) (mkglobvar i2 init ro vo). + +Inductive match_globdef (ctx: C): globdef F1 V1 -> globdef F2 V2 -> Prop := + | match_globdef_fun: forall ctx' f1 f2, + linkorder ctx' ctx -> + match_fundef ctx' f1 f2 -> + match_globdef ctx (Gfun f1) (Gfun f2) + | match_globdef_var: forall v1 v2, + match_globvar v1 v2 -> + match_globdef ctx (Gvar v1) (Gvar v2). + +Definition match_ident_globdef + (ctx: C) (ig1: ident * globdef F1 V1) (ig2: ident * globdef F2 V2) : Prop := + fst ig1 = fst ig2 /\ match_globdef ctx (snd ig1) (snd ig2). + +Definition match_program_gen (ctx: C) (p1: program F1 V1) (p2: program F2 V2) : Prop := + list_forall2 (match_ident_globdef ctx) p1.(prog_defs) p2.(prog_defs) + /\ p2.(prog_main) = p1.(prog_main) + /\ p2.(prog_public) = p1.(prog_public). + +Theorem match_program_defmap: + forall ctx p1 p2, match_program_gen ctx p1 p2 -> + forall id, option_rel (match_globdef ctx) (prog_defmap p1)!id (prog_defmap p2)!id. +Proof. + intros. apply PTree_Properties.of_list_related. apply H. +Qed. + +Lemma match_program_gen_main: + forall ctx p1 p2, match_program_gen ctx p1 p2 -> p2.(prog_main) = p1.(prog_main). +Proof. + intros. apply H. +Qed. + +Lemma match_program_public: + forall ctx p1 p2, match_program_gen ctx p1 p2 -> p2.(prog_public) = p1.(prog_public). +Proof. + intros. apply H. +Qed. + +End MATCH_PROGRAM_GENERIC. + +(** In many cases, the context for [match_program_gen] is the source program or + source compilation unit itself. We provide a specialized definition for this case. *) + +Definition match_program {F1 V1 F2 V2: Type} {LF: Linker F1} {LV: Linker V1} + (match_fundef: program F1 V1 -> F1 -> F2 -> Prop) + (match_varinfo: V1 -> V2 -> Prop) + (p1: program F1 V1) (p2: program F2 V2) : Prop := + match_program_gen match_fundef match_varinfo p1 p1 p2. + +Lemma match_program_main: + forall {F1 V1 F2 V2: Type} {LF: Linker F1} {LV: Linker V1} + {match_fundef: program F1 V1 -> F1 -> F2 -> Prop} + {match_varinfo: V1 -> V2 -> Prop} + {p1: program F1 V1} {p2: program F2 V2}, + match_program match_fundef match_varinfo p1 p2 -> p2.(prog_main) = p1.(prog_main). +Proof. + intros. apply H. +Qed. + +(* +Lemma match_program_implies: + forall (A B V W: Type) (LA: Linker A) (LV: Linker V) + (match_fundef1 match_fundef2: program A V -> A -> B -> Prop) + (match_varinfo1 match_varinfo2: V -> W -> Prop) + p p', + match_program match_fundef1 match_varinfo1 p p' -> + (forall cu a b, match_fundef1 cu a b -> linkorder cu p -> match_fundef2 cu a b) -> + (forall v w, match_varinfo1 v w -> match_varinfo2 v w) -> + match_program match_fundef2 match_varinfo2 p p'. +Proof. + intros. destruct H as [P Q]. split; auto. + eapply list_forall2_imply; eauto. + intros. inv H3. split; auto. inv H5. + econstructor; eauto. + constructor. inv H7; constructor; auto. +Qed. +*) + +(** Relation between the program transformation functions from [AST] + and the [match_program] predicate. *) + +Theorem match_transform_partial_program2: + forall {C F1 V1 F2 V2: Type} {LC: Linker C} {LF: Linker F1} {LV: Linker V1} + (match_fundef: C -> F1 -> F2 -> Prop) + (match_varinfo: V1 -> V2 -> Prop) + (transf_fun: ident -> F1 -> res F2) + (transf_var: ident -> V1 -> res V2) + (ctx: C) (p: program F1 V1) (tp: program F2 V2), + transform_partial_program2 transf_fun transf_var p = OK tp -> + (forall i f tf, transf_fun i f = OK tf -> match_fundef ctx f tf) -> + (forall i v tv, transf_var i v = OK tv -> match_varinfo v tv) -> + match_program_gen match_fundef match_varinfo ctx p tp. +Proof. + unfold transform_partial_program2; intros. monadInv H. + red; simpl; split; auto. + revert x EQ. generalize (prog_defs p). + induction l as [ | [i g] l]; simpl; intros. +- monadInv EQ. constructor. +- destruct g as [f|v]. ++ destruct (transf_fun i f) as [tf|?] eqn:TF; monadInv EQ. + constructor; auto. split; simpl; auto. econstructor. apply linkorder_refl. eauto. ++ destruct (transf_globvar transf_var i v) as [tv|?] eqn:TV; monadInv EQ. + constructor; auto. split; simpl; auto. constructor. + monadInv TV. destruct v; simpl; constructor. eauto. +Qed. + +Theorem match_transform_partial_program_contextual: + forall {A B V: Type} {LA: Linker A} {LV: Linker V} + (match_fundef: program A V -> A -> B -> Prop) + (transf_fun: A -> res B) + (p: program A V) (tp: program B V), + transform_partial_program transf_fun p = OK tp -> + (forall f tf, transf_fun f = OK tf -> match_fundef p f tf) -> + match_program match_fundef eq p tp. +Proof. + intros. + eapply match_transform_partial_program2. eexact H. + auto. + simpl; intros. congruence. +Qed. + +Theorem match_transform_program_contextual: + forall {A B V: Type} {LA: Linker A} {LV: Linker V} + (match_fundef: program A V -> A -> B -> Prop) + (transf_fun: A -> B) + (p: program A V), + (forall f, match_fundef p f (transf_fun f)) -> + match_program match_fundef eq p (transform_program transf_fun p). +Proof. + intros. + eapply match_transform_partial_program_contextual. + apply transform_program_partial_program with (transf_fun := transf_fun). + simpl; intros. inv H0. auto. +Qed. + +(** The following two theorems are simpler versions for the case where the + function transformation does not depend on the compilation unit. *) + +Theorem match_transform_partial_program: + forall {A B V: Type} {LA: Linker A} {LV: Linker V} + (transf_fun: A -> res B) + (p: program A V) (tp: program B V), + transform_partial_program transf_fun p = OK tp -> + match_program (fun cu f tf => transf_fun f = OK tf) eq p tp. +Proof. + intros. + eapply match_transform_partial_program2. eexact H. + auto. + simpl; intros. congruence. +Qed. + +Theorem match_transform_program: + forall {A B V: Type} {LA: Linker A} {LV: Linker V} + (transf: A -> B) + (p: program A V), + match_program (fun cu f tf => tf = transf f) eq p (transform_program transf p). +Proof. + intros. apply match_transform_program_contextual. auto. +Qed. + +(** * Commutation between linking and program transformations *) + +Section LINK_MATCH_PROGRAM. + +Context {C F1 V1 F2 V2: Type} {LC: Linker C} {LF1: Linker F1} {LF2: Linker F2} {LV1: Linker V1} {LV2: Linker V2}. +Variable match_fundef: C -> F1 -> F2 -> Prop. +Variable match_varinfo: V1 -> V2 -> Prop. + +Local Transparent Linker_vardef Linker_def Linker_prog. + +Hypothesis link_match_fundef: + forall ctx1 ctx2 f1 tf1 f2 tf2 f, + link f1 f2 = Some f -> + match_fundef ctx1 f1 tf1 -> match_fundef ctx2 f2 tf2 -> + exists tf, link tf1 tf2 = Some tf /\ (match_fundef ctx1 f tf \/ match_fundef ctx2 f tf). + +Hypothesis link_match_varinfo: + forall v1 tv1 v2 tv2 v, + link v1 v2 = Some v -> + match_varinfo v1 tv1 -> match_varinfo v2 tv2 -> + exists tv, link tv1 tv2 = Some tv /\ match_varinfo v tv. + +Lemma link_match_globvar: + forall v1 tv1 v2 tv2 v, + link v1 v2 = Some v -> + match_globvar match_varinfo v1 tv1 -> match_globvar match_varinfo v2 tv2 -> + exists tv, link tv1 tv2 = Some tv /\ match_globvar match_varinfo v tv. +Proof. + simpl; intros. unfold link_vardef in *. inv H0; inv H1; simpl in *. + destruct (link i1 i0) as [info'|] eqn:LINFO; try discriminate. + destruct (link init init0) as [init'|] eqn:LINIT; try discriminate. + destruct (eqb ro ro0 && eqb vo vo0); inv H. + exploit link_match_varinfo; eauto. intros (tinfo & P & Q). rewrite P. + econstructor; split. eauto. constructor. auto. +Qed. + +Lemma link_match_globdef: + forall ctx1 ctx2 ctx g1 tg1 g2 tg2 g, + linkorder ctx1 ctx -> linkorder ctx2 ctx -> + link g1 g2 = Some g -> + match_globdef match_fundef match_varinfo ctx1 g1 tg1 -> + match_globdef match_fundef match_varinfo ctx2 g2 tg2 -> + exists tg, link tg1 tg2 = Some tg /\ match_globdef match_fundef match_varinfo ctx g tg. +Proof. + simpl link. unfold link_def. intros. inv H2; inv H3; try discriminate. +- destruct (link f1 f0) as [f|] eqn:LF; inv H1. + exploit link_match_fundef; eauto. intros (tf & P & Q). + assert (X: exists ctx', linkorder ctx' ctx /\ match_fundef ctx' f tf). + { destruct Q as [Q|Q]; econstructor; (split; [|eassumption]). + apply linkorder_trans with ctx1; auto. + apply linkorder_trans with ctx2; auto. } + destruct X as (cu & X & Y). + exists (Gfun tf); split. rewrite P; auto. econstructor; eauto. +- destruct (link v1 v0) as [v|] eqn:LVAR; inv H1. + exploit link_match_globvar; eauto. intros (tv & P & Q). + exists (Gvar tv); split. rewrite P; auto. constructor; auto. +Qed. + +Lemma match_globdef_linkorder: + forall ctx ctx' g tg, + match_globdef match_fundef match_varinfo ctx g tg -> + linkorder ctx ctx' -> + match_globdef match_fundef match_varinfo ctx' g tg. +Proof. + intros. inv H. +- econstructor. eapply linkorder_trans; eauto. auto. +- constructor; auto. +Qed. + +Theorem link_match_program: + forall ctx1 ctx2 ctx p1 p2 tp1 tp2 p, + link p1 p2 = Some p -> + match_program_gen match_fundef match_varinfo ctx1 p1 tp1 -> + match_program_gen match_fundef match_varinfo ctx2 p2 tp2 -> + linkorder ctx1 ctx -> linkorder ctx2 ctx -> + exists tp, link tp1 tp2 = Some tp /\ match_program_gen match_fundef match_varinfo ctx p tp. +Proof. + intros. destruct (link_prog_inv _ _ _ H) as (P & Q & R). + generalize H0; intros (A1 & B1 & C1). + generalize H1; intros (A2 & B2 & C2). + econstructor; split. +- apply link_prog_succeeds. ++ congruence. ++ intros. + generalize (match_program_defmap _ _ _ _ _ H0 id) (match_program_defmap _ _ _ _ _ H1 id). + rewrite H4, H5. intros R1 R2; inv R1; inv R2. + exploit Q; eauto. intros (X & Y & gd & Z). + exploit link_match_globdef. eexact H2. eexact H3. eauto. eauto. eauto. + intros (tg & TL & _). intuition congruence. +- split; [|split]. ++ rewrite R. apply PTree.elements_canonical_order'. intros id. + rewrite ! PTree.gcombine by auto. + generalize (match_program_defmap _ _ _ _ _ H0 id) (match_program_defmap _ _ _ _ _ H1 id). + clear R. intros R1 R2; inv R1; inv R2; unfold link_prog_merge. +* constructor. +* constructor. apply match_globdef_linkorder with ctx2; auto. +* constructor. apply match_globdef_linkorder with ctx1; auto. +* exploit Q; eauto. intros (X & Y & gd & Z). + exploit link_match_globdef. eexact H2. eexact H3. eauto. eauto. eauto. + intros (tg & TL & MG). rewrite Z, TL. constructor; auto. ++ rewrite R; simpl; auto. ++ rewrite R; simpl. congruence. +Qed. + +End LINK_MATCH_PROGRAM. + +(** We now wrap this commutation diagram into a class, and provide some common instances. *) + +Class TransfLink {A B: Type} {LA: Linker A} {LB: Linker B} (transf: A -> B -> Prop) := + transf_link: + forall (p1 p2: A) (tp1 tp2: B) (p: A), + link p1 p2 = Some p -> + transf p1 tp1 -> transf p2 tp2 -> + exists tp, link tp1 tp2 = Some tp /\ transf p tp. + +Remark link_transf_partial_fundef: + forall (A B: Type) (tr1 tr2: A -> res B) (f1 f2: fundef A) (tf1 tf2: fundef B) (f: fundef A), + link f1 f2 = Some f -> + transf_partial_fundef tr1 f1 = OK tf1 -> + transf_partial_fundef tr2 f2 = OK tf2 -> + exists tf, + link tf1 tf2 = Some tf + /\ (transf_partial_fundef tr1 f = OK tf \/ transf_partial_fundef tr2 f = OK tf). +Proof. +Local Transparent Linker_fundef. + simpl; intros. destruct f1 as [f1|ef1], f2 as [f2|ef2]; simpl in *; monadInv H0; monadInv H1. +- discriminate. +- destruct ef2; inv H. exists (Internal x); split; auto. left; simpl; rewrite EQ; auto. +- destruct ef1; inv H. exists (Internal x); split; auto. right; simpl; rewrite EQ; auto. +- destruct (external_function_eq ef1 ef2); inv H. exists (External ef2); split; auto. simpl. rewrite dec_eq_true; auto. +Qed. + +Instance TransfPartialContextualLink + {A B C V: Type} {LV: Linker V} + (tr_fun: C -> A -> res B) + (ctx_for: program (fundef A) V -> C): + TransfLink (fun (p1: program (fundef A) V) (p2: program (fundef B) V) => + match_program + (fun cu f tf => AST.transf_partial_fundef (tr_fun (ctx_for cu)) f = OK tf) + eq p1 p2). +Proof. + red. intros. destruct (link_linkorder _ _ _ H) as [LO1 LO2]. + eapply link_match_program; eauto. +- intros. eapply link_transf_partial_fundef; eauto. +- intros; subst. exists v; auto. +Qed. + +Instance TransfPartialLink + {A B V: Type} {LV: Linker V} + (tr_fun: A -> res B): + TransfLink (fun (p1: program (fundef A) V) (p2: program (fundef B) V) => + match_program + (fun cu f tf => AST.transf_partial_fundef tr_fun f = OK tf) + eq p1 p2). +Proof. + red. intros. destruct (link_linkorder _ _ _ H) as [LO1 LO2]. + eapply link_match_program; eauto. +- intros. eapply link_transf_partial_fundef; eauto. +- intros; subst. exists v; auto. +Qed. + +Instance TransfTotallContextualLink + {A B C V: Type} {LV: Linker V} + (tr_fun: C -> A -> B) + (ctx_for: program (fundef A) V -> C): + TransfLink (fun (p1: program (fundef A) V) (p2: program (fundef B) V) => + match_program + (fun cu f tf => tf = AST.transf_fundef (tr_fun (ctx_for cu)) f) + eq p1 p2). +Proof. + red. intros. destruct (link_linkorder _ _ _ H) as [LO1 LO2]. + eapply link_match_program; eauto. +- intros. subst. destruct f1, f2; simpl in *. ++ discriminate. ++ destruct e; inv H2. econstructor; eauto. ++ destruct e; inv H2. econstructor; eauto. ++ destruct (external_function_eq e e0); inv H2. econstructor; eauto. +- intros; subst. exists v; auto. +Qed. + +Instance TransfTotalLink + {A B V: Type} {LV: Linker V} + (tr_fun: A -> B): + TransfLink (fun (p1: program (fundef A) V) (p2: program (fundef B) V) => + match_program + (fun cu f tf => tf = AST.transf_fundef tr_fun f) + eq p1 p2). +Proof. + red. intros. destruct (link_linkorder _ _ _ H) as [LO1 LO2]. + eapply link_match_program; eauto. +- intros. subst. destruct f1, f2; simpl in *. ++ discriminate. ++ destruct e; inv H2. econstructor; eauto. ++ destruct e; inv H2. econstructor; eauto. ++ destruct (external_function_eq e e0); inv H2. econstructor; eauto. +- intros; subst. exists v; auto. +Qed. + +(** * Linking a set of compilation units *) + +(** Here, we take a more general view of linking as taking a nonempty list of compilation units + and producing a whole program. *) + +Section LINK_LIST. + +Context {A: Type} {LA: Linker A}. + +Fixpoint link_list (l: nlist A) : option A := + match l with + | nbase a => Some a + | ncons a l => + match link_list l with None => None | Some b => link a b end + end. + +Lemma link_list_linkorder: + forall a l b, link_list l = Some b -> nIn a l -> linkorder a b. +Proof. + induction l; simpl; intros. +- inv H. subst. apply linkorder_refl. +- destruct (link_list l) as [b'|]; try discriminate. + apply link_linkorder in H. destruct H0. ++ subst a0. tauto. ++ apply linkorder_trans with b'. auto. tauto. +Qed. + +End LINK_LIST. + +(** List linking commutes with program transformations, provided the + transformation commutes with simple (binary) linking. *) + +Section LINK_LIST_MATCH. + +Context {A B: Type} {LA: Linker A} {LB: Linker B} (prog_match: A -> B -> Prop) {TL: TransfLink prog_match}. + +Theorem link_list_match: + forall al bl, nlist_forall2 prog_match al bl -> + forall a, link_list al = Some a -> + exists b, link_list bl = Some b /\ prog_match a b. +Proof. + induction 1; simpl; intros a' L. +- inv L. exists b; auto. +- destruct (link_list l) as [a1|] eqn:LL; try discriminate. + exploit IHnlist_forall2; eauto. intros (b' & P & Q). + red in TL. exploit TL; eauto. intros (b'' & U & V). + rewrite P; exists b''; auto. +Qed. + +End LINK_LIST_MATCH. + +(** * Linking and composition of compilation passes *) + +Set Implicit Arguments. + +(** A generic language is a type of programs and a linker. *) + +Structure Language := mklang { lang_prog :> Type; lang_link: Linker lang_prog }. + +Canonical Structure Language_gen (A: Type) (L: Linker A) : Language := @mklang A L. + +(** A compilation pass from language [S] (source) to language [T] (target) + is a matching relation between [S] programs and [T] programs, + plus two linkers, one for [S] and one for [T], + and a property of commutation with linking. *) + +Record Pass (S T: Language) := mkpass { + pass_match :> lang_prog S -> lang_prog T -> Prop; + pass_match_link: @TransfLink (lang_prog S) (lang_prog T) (lang_link S) (lang_link T) pass_match +}. + +Arguments mkpass {S} {T} (pass_match) {pass_match_link}. + +Program Definition pass_identity (l: Language): Pass l l := + {| pass_match := fun p1 p2 => p1 = p2; + pass_match_link := _ |}. +Next Obligation. + red; intros. subst. exists p; auto. +Defined. + +Program Definition pass_compose {l1 l2 l3: Language} (pass: Pass l1 l2) (pass': Pass l2 l3) : Pass l1 l3 := + {| pass_match := fun p1 p3 => exists p2, pass_match pass p1 p2 /\ pass_match pass' p2 p3; + pass_match_link := _ |}. +Next Obligation. + red; intros. + destruct H0 as (p1' & A1 & B1). + destruct H1 as (p2' & A2 & B2). + edestruct (pass_match_link pass) as (p' & A & B); eauto. + edestruct (pass_match_link pass') as (tp & C & D); eauto. +Defined. + +(** A list of compilation passes that can be composed. *) + +Inductive Passes: Language -> Language -> Type := + | pass_nil: forall l, Passes l l + | pass_cons: forall l1 l2 l3, Pass l1 l2 -> Passes l2 l3 -> Passes l1 l3. + +Infix ":::" := pass_cons (at level 60, right associativity) : linking_scope. + +(** The pass corresponding to the composition of a list of passes. *) + +Fixpoint compose_passes (l l': Language) (passes: Passes l l') : Pass l l' := + match passes in Passes l l' return Pass l l' with + | pass_nil l => pass_identity l + | pass_cons l1 l2 l3 pass1 passes => pass_compose pass1 (compose_passes passes) + end. + +(** Some more lemmas about [nlist_forall2]. *) + +Lemma nlist_forall2_identity: + forall (A: Type) (la lb: nlist A), + nlist_forall2 (fun a b => a = b) la lb -> la = lb. +Proof. + induction 1; congruence. +Qed. + +Lemma nlist_forall2_compose_inv: + forall (A B C: Type) (R1: A -> B -> Prop) (R2: B -> C -> Prop) + (la: nlist A) (lc: nlist C), + nlist_forall2 (fun a c => exists b, R1 a b /\ R2 b c) la lc -> + exists lb: nlist B, nlist_forall2 R1 la lb /\ nlist_forall2 R2 lb lc. +Proof. + induction 1. +- rename b into c. destruct H as (b & P & Q). + exists (nbase b); split; constructor; auto. +- rename b into c. destruct H as (b & P & Q). destruct IHnlist_forall2 as (lb & U & V). + exists (ncons b lb); split; constructor; auto. +Qed. + +(** List linking with a composition of compilation passes. *) + +Theorem link_list_compose_passes: + forall (src tgt: Language) (passes: Passes src tgt) + (src_units: nlist src) (tgt_units: nlist tgt), + nlist_forall2 (pass_match (compose_passes passes)) src_units tgt_units -> + forall src_prog, + @link_list _ (lang_link src) src_units = Some src_prog -> + exists tgt_prog, + @link_list _ (lang_link tgt) tgt_units = Some tgt_prog + /\ pass_match (compose_passes passes) src_prog tgt_prog. +Proof. + induction passes; simpl; intros src_units tgt_units F2 src_prog LINK. +- apply nlist_forall2_identity in F2. subst tgt_units. exists src_prog; auto. +- apply nlist_forall2_compose_inv in F2. destruct F2 as (interm_units & P & Q). + edestruct (@link_list_match _ _ (lang_link l1) (lang_link l2) (pass_match p)) + as (interm_prog & U & V). + apply pass_match_link. eauto. eauto. + exploit IHpasses; eauto. intros (tgt_prog & X & Y). + exists tgt_prog; split; auto. exists interm_prog; auto. +Qed. + diff --git a/common/Memory.v b/common/Memory.v index 93d0e432..0ea9e3b0 100644 --- a/common/Memory.v +++ b/common/Memory.v @@ -4143,6 +4143,8 @@ Section UNCHANGED_ON. Variable P: block -> Z -> Prop. Record unchanged_on (m_before m_after: mem) : Prop := mk_unchanged_on { + unchanged_on_nextblock: + Ple (nextblock m_before) (nextblock m_after); unchanged_on_perm: forall b ofs k p, P b ofs -> valid_block m_before b -> @@ -4157,15 +4159,22 @@ Record unchanged_on (m_before m_after: mem) : Prop := mk_unchanged_on { Lemma unchanged_on_refl: forall m, unchanged_on m m. Proof. - intros; constructor; tauto. + intros; constructor. apply Ple_refl. tauto. tauto. +Qed. + +Lemma valid_block_unchanged_on: + forall m m' b, + unchanged_on m m' -> valid_block m b -> valid_block m' b. +Proof. + unfold valid_block; intros. apply unchanged_on_nextblock in H. xomega. Qed. Lemma perm_unchanged_on: forall m m' b ofs k p, - unchanged_on m m' -> P b ofs -> valid_block m b -> + unchanged_on m m' -> P b ofs -> perm m b ofs k p -> perm m' b ofs k p. Proof. - intros. destruct H. apply unchanged_on_perm0; auto. + intros. destruct H. apply unchanged_on_perm0; auto. eapply perm_valid_block; eauto. Qed. Lemma perm_unchanged_on_2: @@ -4176,6 +4185,17 @@ Proof. intros. destruct H. apply unchanged_on_perm0; auto. Qed. +Lemma unchanged_on_trans: + forall m1 m2 m3, unchanged_on m1 m2 -> unchanged_on m2 m3 -> unchanged_on m1 m3. +Proof. + intros; constructor. +- apply Ple_trans with (nextblock m2); apply unchanged_on_nextblock; auto. +- intros. transitivity (perm m2 b ofs k p); apply unchanged_on_perm; auto. + eapply valid_block_unchanged_on; eauto. +- intros. transitivity (ZMap.get ofs (mem_contents m2)#b); apply unchanged_on_contents; auto. + eapply perm_unchanged_on; eauto. +Qed. + Lemma loadbytes_unchanged_on_1: forall m m' b ofs n, unchanged_on m m' -> @@ -4243,6 +4263,7 @@ Lemma store_unchanged_on: unchanged_on m m'. Proof. intros; constructor; intros. +- rewrite (nextblock_store _ _ _ _ _ _ H). apply Ple_refl. - split; intros; eauto with mem. - erewrite store_mem_contents; eauto. rewrite PMap.gsspec. destruct (peq b0 b); auto. subst b0. apply setN_outside. @@ -4259,6 +4280,7 @@ Lemma storebytes_unchanged_on: unchanged_on m m'. Proof. intros; constructor; intros. +- rewrite (nextblock_storebytes _ _ _ _ _ H). apply Ple_refl. - split; intros. eapply perm_storebytes_1; eauto. eapply perm_storebytes_2; eauto. - erewrite storebytes_mem_contents; eauto. rewrite PMap.gsspec. destruct (peq b0 b); auto. subst b0. apply setN_outside. @@ -4273,6 +4295,7 @@ Lemma alloc_unchanged_on: unchanged_on m m'. Proof. intros; constructor; intros. +- rewrite (nextblock_alloc _ _ _ _ _ H). apply Ple_succ. - split; intros. eapply perm_alloc_1; eauto. eapply perm_alloc_4; eauto. @@ -4288,6 +4311,7 @@ Lemma free_unchanged_on: unchanged_on m m'. Proof. intros; constructor; intros. +- rewrite (nextblock_free _ _ _ _ _ H). apply Ple_refl. - split; intros. eapply perm_free_1; eauto. destruct (eq_block b0 b); auto. destruct (zlt ofs lo); auto. destruct (zle hi ofs); auto. @@ -4297,8 +4321,39 @@ Proof. simpl. auto. Qed. +Lemma drop_perm_unchanged_on: + forall m b lo hi p m', + drop_perm m b lo hi p = Some m' -> + (forall i, lo <= i < hi -> ~ P b i) -> + unchanged_on m m'. +Proof. + intros; constructor; intros. +- rewrite (nextblock_drop _ _ _ _ _ _ H). apply Ple_refl. +- split; intros. eapply perm_drop_3; eauto. + destruct (eq_block b0 b); auto. + subst b0. + assert (~ (lo <= ofs < hi)). { red; intros; eelim H0; eauto. } + right; omega. + eapply perm_drop_4; eauto. +- unfold drop_perm in H. + destruct (range_perm_dec m b lo hi Cur Freeable); inv H; simpl. auto. +Qed. + End UNCHANGED_ON. +Lemma unchanged_on_implies: + forall (P Q: block -> Z -> Prop) m m', + unchanged_on P m m' -> + (forall b ofs, Q b ofs -> valid_block m b -> P b ofs) -> + unchanged_on Q m m'. +Proof. + intros. destruct H. constructor; intros. +- auto. +- apply unchanged_on_perm0; auto. +- apply unchanged_on_contents0; auto. + apply H0; auto. eapply perm_valid_block; eauto. +Qed. + End Mem. Notation mem := Mem.mem. diff --git a/common/PrintAST.ml b/common/PrintAST.ml index 4994026a..48172dfd 100644 --- a/common/PrintAST.ml +++ b/common/PrintAST.ml @@ -39,6 +39,7 @@ let name_of_chunk = function let name_of_external = function | EF_external(name, sg) -> sprintf "extern %S" (camlstring_of_coqstring name) | EF_builtin(name, sg) -> sprintf "builtin %S" (camlstring_of_coqstring name) + | EF_runtime(name, sg) -> sprintf "runtime %S" (camlstring_of_coqstring name) | EF_vload chunk -> sprintf "volatile load %s" (name_of_chunk chunk) | EF_vstore chunk -> sprintf "volatile store %s" (name_of_chunk chunk) | EF_malloc -> "malloc" diff --git a/common/Smallstep.v b/common/Smallstep.v index 71cef35f..9c91243a 100644 --- a/common/Smallstep.v +++ b/common/Smallstep.v @@ -513,43 +513,49 @@ Open Scope smallstep_scope. (** The general form of a forward simulation. *) -Record forward_simulation (L1 L2: semantics) : Type := - Forward_simulation { - fsim_index: Type; - fsim_order: fsim_index -> fsim_index -> Prop; - fsim_order_wf: well_founded fsim_order; - fsim_match_states :> fsim_index -> state L1 -> state L2 -> Prop; +Record fsim_properties (L1 L2: semantics) (index: Type) + (order: index -> index -> Prop) + (match_states: index -> state L1 -> state L2 -> Prop) : Prop := { + fsim_order_wf: well_founded order; fsim_match_initial_states: forall s1, initial_state L1 s1 -> - exists i, exists s2, initial_state L2 s2 /\ fsim_match_states i s1 s2; + exists i, exists s2, initial_state L2 s2 /\ match_states i s1 s2; fsim_match_final_states: forall i s1 s2 r, - fsim_match_states i s1 s2 -> final_state L1 s1 r -> final_state L2 s2 r; + match_states i s1 s2 -> final_state L1 s1 r -> final_state L2 s2 r; fsim_simulation: forall s1 t s1', Step L1 s1 t s1' -> - forall i s2, fsim_match_states i s1 s2 -> + forall i s2, match_states i s1 s2 -> exists i', exists s2', - (Plus L2 s2 t s2' \/ (Star L2 s2 t s2' /\ fsim_order i' i)) - /\ fsim_match_states i' s1' s2'; + (Plus L2 s2 t s2' \/ (Star L2 s2 t s2' /\ order i' i)) + /\ match_states i' s1' s2'; fsim_public_preserved: forall id, Senv.public_symbol (symbolenv L2) id = Senv.public_symbol (symbolenv L1) id }. -Implicit Arguments forward_simulation []. +Arguments fsim_properties: clear implicits. + +Inductive forward_simulation (L1 L2: semantics) : Prop := + Forward_simulation (index: Type) + (order: index -> index -> Prop) + (match_states: index -> state L1 -> state L2 -> Prop) + (props: fsim_properties L1 L2 index order match_states). + +Arguments Forward_simulation {L1 L2 index} order match_states props. (** An alternate form of the simulation diagram *) Lemma fsim_simulation': - forall L1 L2 (S: forward_simulation L1 L2), + forall L1 L2 index order match_states, fsim_properties L1 L2 index order match_states -> forall i s1 t s1', Step L1 s1 t s1' -> - forall s2, S i s1 s2 -> - (exists i', exists s2', Plus L2 s2 t s2' /\ S i' s1' s2') - \/ (exists i', fsim_order S i' i /\ t = E0 /\ S i' s1' s2). + forall s2, match_states i s1 s2 -> + (exists i', exists s2', Plus L2 s2 t s2' /\ match_states i' s1' s2') + \/ (exists i', order i' i /\ t = E0 /\ match_states i' s1' s2). Proof. intros. exploit fsim_simulation; eauto. intros [i' [s2' [A B]]]. intuition. left; exists i'; exists s2'; auto. - inv H2. + inv H3. right; exists i'; auto. left; exists i'; exists s2'; split; auto. econstructor; eauto. Qed. @@ -602,15 +608,15 @@ Hypothesis simulation: Lemma forward_simulation_star_wf: forward_simulation L1 L2. Proof. - apply Forward_simulation with - (fsim_order := order) - (fsim_match_states := fun idx s1 s2 => idx = s1 /\ match_states s1 s2); - auto. - intros. exploit match_initial_states; eauto. intros [s2 [A B]]. + apply Forward_simulation with order (fun idx s1 s2 => idx = s1 /\ match_states s1 s2); + constructor. +- auto. +- intros. exploit match_initial_states; eauto. intros [s2 [A B]]. exists s1; exists s2; auto. - intros. destruct H. eapply match_final_states; eauto. - intros. destruct H0. subst i. exploit simulation; eauto. intros [s2' [A B]]. - exists s1'; exists s2'; intuition. +- intros. destruct H. eapply match_final_states; eauto. +- intros. destruct H0. subst i. exploit simulation; eauto. intros [s2' [A B]]. + exists s1'; exists s2'; intuition auto. +- auto. Qed. End SIMULATION_STAR_WF. @@ -709,28 +715,26 @@ End FORWARD_SIMU_DIAGRAMS. Section SIMULATION_SEQUENCES. -Variable L1: semantics. -Variable L2: semantics. -Variable S: forward_simulation L1 L2. +Context L1 L2 index order match_states (S: fsim_properties L1 L2 index order match_states). Lemma simulation_star: forall s1 t s1', Star L1 s1 t s1' -> - forall i s2, S i s1 s2 -> - exists i', exists s2', Star L2 s2 t s2' /\ S i' s1' s2'. + forall i s2, match_states i s1 s2 -> + exists i', exists s2', Star L2 s2 t s2' /\ match_states i' s1' s2'. Proof. induction 1; intros. exists i; exists s2; split; auto. apply star_refl. exploit fsim_simulation; eauto. intros [i' [s2' [A B]]]. exploit IHstar; eauto. intros [i'' [s2'' [C D]]]. exists i''; exists s2''; split; auto. eapply star_trans; eauto. - intuition. apply plus_star; auto. + intuition auto. apply plus_star; auto. Qed. Lemma simulation_plus: forall s1 t s1', Plus L1 s1 t s1' -> - forall i s2, S i s1 s2 -> - (exists i', exists s2', Plus L2 s2 t s2' /\ S i' s1' s2') - \/ (exists i', clos_trans _ (fsim_order S) i' i /\ t = E0 /\ S i' s1' s2). + forall i s2, match_states i s1 s2 -> + (exists i', exists s2', Plus L2 s2 t s2' /\ match_states i' s1' s2') + \/ (exists i', clos_trans _ order i' i /\ t = E0 /\ match_states i' s1' s2). Proof. induction 1 using plus_ind2; intros. (* base case *) @@ -744,34 +748,34 @@ Proof. left; exists i''; exists s2''; split; auto. eapply plus_star_trans; eauto. exploit IHplus; eauto. intros [[i'' [s2'' [P Q]]] | [i'' [P [Q R]]]]. subst. simpl. left; exists i''; exists s2''; auto. - subst. simpl. right; exists i''; intuition. + subst. simpl. right; exists i''; intuition auto. eapply t_trans; eauto. eapply t_step; eauto. Qed. Lemma simulation_forever_silent: forall i s1 s2, - Forever_silent L1 s1 -> S i s1 s2 -> + Forever_silent L1 s1 -> match_states i s1 s2 -> Forever_silent L2 s2. Proof. assert (forall i s1 s2, - Forever_silent L1 s1 -> S i s1 s2 -> - forever_silent_N (step L2) (fsim_order S) (globalenv L2) i s2). + Forever_silent L1 s1 -> match_states i s1 s2 -> + forever_silent_N (step L2) order (globalenv L2) i s2). cofix COINDHYP; intros. inv H. destruct (fsim_simulation S _ _ _ H1 _ _ H0) as [i' [s2' [A B]]]. destruct A as [C | [C D]]. eapply forever_silent_N_plus; eauto. eapply forever_silent_N_star; eauto. - intros. eapply forever_silent_N_forever; eauto. apply fsim_order_wf. + intros. eapply forever_silent_N_forever; eauto. eapply fsim_order_wf; eauto. Qed. Lemma simulation_forever_reactive: forall i s1 s2 T, - Forever_reactive L1 s1 T -> S i s1 s2 -> + Forever_reactive L1 s1 T -> match_states i s1 s2 -> Forever_reactive L2 s2 T. Proof. cofix COINDHYP; intros. inv H. - destruct (simulation_star H1 i _ H0) as [i' [st2' [A B]]]. + edestruct simulation_star as [i' [st2' [A B]]]; eauto. econstructor; eauto. Qed. @@ -779,56 +783,48 @@ End SIMULATION_SEQUENCES. (** ** Composing two forward simulations *) -Section COMPOSE_SIMULATIONS. - -Variable L1: semantics. -Variable L2: semantics. -Variable L3: semantics. -Variable S12: forward_simulation L1 L2. -Variable S23: forward_simulation L2 L3. - -Let ff_index : Type := (fsim_index S23 * fsim_index S12)%type. - -Let ff_order : ff_index -> ff_index -> Prop := - lex_ord (clos_trans _ (fsim_order S23)) (fsim_order S12). - -Let ff_match_states (i: ff_index) (s1: state L1) (s3: state L3) : Prop := - exists s2, S12 (snd i) s1 s2 /\ S23 (fst i) s2 s3. - -Lemma compose_forward_simulation: forward_simulation L1 L3. -Proof. - apply Forward_simulation with (fsim_order := ff_order) (fsim_match_states := ff_match_states). -(* well founded *) - unfold ff_order. apply wf_lex_ord. apply wf_clos_trans. apply fsim_order_wf. apply fsim_order_wf. -(* initial states *) - intros. exploit (fsim_match_initial_states S12); eauto. intros [i [s2 [A B]]]. - exploit (fsim_match_initial_states S23); eauto. intros [i' [s3 [C D]]]. +Lemma compose_forward_simulations: + forall L1 L2 L3, forward_simulation L1 L2 -> forward_simulation L2 L3 -> forward_simulation L1 L3. +Proof. + intros L1 L2 L3 S12 S23. + destruct S12 as [index order match_states props]. + destruct S23 as [index' order' match_states' props']. + + set (ff_index := (index' * index)%type). + set (ff_order := lex_ord (clos_trans _ order') order). + set (ff_match_states := fun (i: ff_index) (s1: state L1) (s3: state L3) => + exists s2, match_states (snd i) s1 s2 /\ match_states' (fst i) s2 s3). + apply Forward_simulation with ff_order ff_match_states; constructor. +- (* well founded *) + unfold ff_order. apply wf_lex_ord. apply wf_clos_trans. + eapply fsim_order_wf; eauto. eapply fsim_order_wf; eauto. +- (* initial states *) + intros. exploit (fsim_match_initial_states props); eauto. intros [i [s2 [A B]]]. + exploit (fsim_match_initial_states props'); eauto. intros [i' [s3 [C D]]]. exists (i', i); exists s3; split; auto. exists s2; auto. -(* final states *) +- (* final states *) intros. destruct H as [s3 [A B]]. - eapply (fsim_match_final_states S23); eauto. - eapply (fsim_match_final_states S12); eauto. -(* simulation *) + eapply (fsim_match_final_states props'); eauto. + eapply (fsim_match_final_states props); eauto. +- (* simulation *) intros. destruct H0 as [s3 [A B]]. destruct i as [i2 i1]; simpl in *. - exploit (fsim_simulation' S12); eauto. intros [[i1' [s3' [C D]]] | [i1' [C [D E]]]]. - (* L2 makes one or several steps. *) + exploit (fsim_simulation' props); eauto. intros [[i1' [s3' [C D]]] | [i1' [C [D E]]]]. ++ (* L2 makes one or several steps. *) exploit simulation_plus; eauto. intros [[i2' [s2' [P Q]]] | [i2' [P [Q R]]]]. - (* L3 makes one or several steps *) +* (* L3 makes one or several steps *) exists (i2', i1'); exists s2'; split. auto. exists s3'; auto. - (* L3 makes no step *) +* (* L3 makes no step *) exists (i2', i1'); exists s2; split. right; split. subst t; apply star_refl. red. left. auto. exists s3'; auto. - (* L2 makes no step *) ++ (* L2 makes no step *) exists (i2, i1'); exists s2; split. right; split. subst t; apply star_refl. red. right. auto. exists s3; auto. -(* symbols *) - intros. transitivity (Senv.public_symbol (symbolenv L2) id); apply fsim_public_preserved; auto. +- (* symbols *) + intros. transitivity (Senv.public_symbol (symbolenv L2) id); eapply fsim_public_preserved; eauto. Qed. -End COMPOSE_SIMULATIONS. - (** * Receptiveness and determinacy *) Definition single_events (L: semantics) : Prop := @@ -916,49 +912,57 @@ Qed. (** The general form of a backward simulation. *) -Record backward_simulation (L1 L2: semantics) : Type := - Backward_simulation { - bsim_index: Type; - bsim_order: bsim_index -> bsim_index -> Prop; - bsim_order_wf: well_founded bsim_order; - bsim_match_states :> bsim_index -> state L1 -> state L2 -> Prop; +Record bsim_properties (L1 L2: semantics) (index: Type) + (order: index -> index -> Prop) + (match_states: index -> state L1 -> state L2 -> Prop) : Prop := { + bsim_order_wf: well_founded order; bsim_initial_states_exist: forall s1, initial_state L1 s1 -> exists s2, initial_state L2 s2; bsim_match_initial_states: forall s1 s2, initial_state L1 s1 -> initial_state L2 s2 -> - exists i, exists s1', initial_state L1 s1' /\ bsim_match_states i s1' s2; + exists i, exists s1', initial_state L1 s1' /\ match_states i s1' s2; bsim_match_final_states: forall i s1 s2 r, - bsim_match_states i s1 s2 -> safe L1 s1 -> final_state L2 s2 r -> + match_states i s1 s2 -> safe L1 s1 -> final_state L2 s2 r -> exists s1', Star L1 s1 E0 s1' /\ final_state L1 s1' r; bsim_progress: forall i s1 s2, - bsim_match_states i s1 s2 -> safe L1 s1 -> + match_states i s1 s2 -> safe L1 s1 -> (exists r, final_state L2 s2 r) \/ (exists t, exists s2', Step L2 s2 t s2'); bsim_simulation: forall s2 t s2', Step L2 s2 t s2' -> - forall i s1, bsim_match_states i s1 s2 -> safe L1 s1 -> + forall i s1, match_states i s1 s2 -> safe L1 s1 -> exists i', exists s1', - (Plus L1 s1 t s1' \/ (Star L1 s1 t s1' /\ bsim_order i' i)) - /\ bsim_match_states i' s1' s2'; + (Plus L1 s1 t s1' \/ (Star L1 s1 t s1' /\ order i' i)) + /\ match_states i' s1' s2'; bsim_public_preserved: forall id, Senv.public_symbol (symbolenv L2) id = Senv.public_symbol (symbolenv L1) id }. +Arguments bsim_properties: clear implicits. + +Inductive backward_simulation (L1 L2: semantics) : Prop := + Backward_simulation (index: Type) + (order: index -> index -> Prop) + (match_states: index -> state L1 -> state L2 -> Prop) + (props: bsim_properties L1 L2 index order match_states). + +Arguments Backward_simulation {L1 L2 index} order match_states props. + (** An alternate form of the simulation diagram *) Lemma bsim_simulation': - forall L1 L2 (S: backward_simulation L1 L2), + forall L1 L2 index order match_states, bsim_properties L1 L2 index order match_states -> forall i s2 t s2', Step L2 s2 t s2' -> - forall s1, S i s1 s2 -> safe L1 s1 -> - (exists i', exists s1', Plus L1 s1 t s1' /\ S i' s1' s2') - \/ (exists i', bsim_order S i' i /\ t = E0 /\ S i' s1 s2'). + forall s1, match_states i s1 s2 -> safe L1 s1 -> + (exists i', exists s1', Plus L1 s1 t s1' /\ match_states i' s1' s2') + \/ (exists i', order i' i /\ t = E0 /\ match_states i' s1 s2'). Proof. intros. exploit bsim_simulation; eauto. intros [i' [s1' [A B]]]. intuition. left; exists i'; exists s1'; auto. - inv H3. + inv H4. right; exists i'; auto. left; exists i'; exists s1'; split; auto. econstructor; eauto. Qed. @@ -1004,13 +1008,13 @@ Hypothesis simulation: Lemma backward_simulation_plus: backward_simulation L1 L2. Proof. apply Backward_simulation with - (bsim_order := fun (x y: unit) => False) - (bsim_match_states := fun (i: unit) s1 s2 => match_states s1 s2); - auto. - red; intros; constructor; intros. contradiction. - intros. exists tt; eauto. - intros. exists s1; split. apply star_refl. eauto. - intros. exploit simulation; eauto. intros [s1' [A B]]. + (fun (x y: unit) => False) + (fun (i: unit) s1 s2 => match_states s1 s2); + constructor; auto. +- red; intros; constructor; intros. contradiction. +- intros. exists tt; eauto. +- intros. exists s1; split. apply star_refl. eauto. +- intros. exploit simulation; eauto. intros [s1' [A B]]. exists tt; exists s1'; auto. Qed. @@ -1022,19 +1026,17 @@ End BACKWARD_SIMU_DIAGRAMS. Section BACKWARD_SIMULATION_SEQUENCES. -Variable L1: semantics. -Variable L2: semantics. -Variable S: backward_simulation L1 L2. +Context L1 L2 index order match_states (S: bsim_properties L1 L2 index order match_states). Lemma bsim_E0_star: forall s2 s2', Star L2 s2 E0 s2' -> - forall i s1, S i s1 s2 -> safe L1 s1 -> - exists i', exists s1', Star L1 s1 E0 s1' /\ S i' s1' s2'. + forall i s1, match_states i s1 s2 -> safe L1 s1 -> + exists i', exists s1', Star L1 s1 E0 s1' /\ match_states i' s1' s2'. Proof. intros s20 s20' STAR0. pattern s20, s20'. eapply star_E0_ind; eauto. -(* base case *) +- (* base case *) intros. exists i; exists s1; split; auto. apply star_refl. -(* inductive case *) +- (* inductive case *) intros. exploit bsim_simulation; eauto. intros [i' [s1' [A B]]]. assert (Star L1 s0 E0 s1'). intuition. apply plus_star; auto. exploit H0. eauto. eapply star_safe; eauto. intros [i'' [s1'' [C D]]]. @@ -1043,7 +1045,7 @@ Qed. Lemma bsim_safe: forall i s1 s2, - S i s1 s2 -> safe L1 s1 -> safe L2 s2. + match_states i s1 s2 -> safe L1 s1 -> safe L2 s2. Proof. intros; red; intros. exploit bsim_E0_star; eauto. intros [i' [s1' [A B]]]. @@ -1052,22 +1054,22 @@ Qed. Lemma bsim_E0_plus: forall s2 t s2', Plus L2 s2 t s2' -> t = E0 -> - forall i s1, S i s1 s2 -> safe L1 s1 -> - (exists i', exists s1', Plus L1 s1 E0 s1' /\ S i' s1' s2') - \/ (exists i', clos_trans _ (bsim_order S) i' i /\ S i' s1 s2'). + forall i s1, match_states i s1 s2 -> safe L1 s1 -> + (exists i', exists s1', Plus L1 s1 E0 s1' /\ match_states i' s1' s2') + \/ (exists i', clos_trans _ order i' i /\ match_states i' s1 s2'). Proof. induction 1 using plus_ind2; intros; subst t. -(* base case *) +- (* base case *) exploit bsim_simulation'; eauto. intros [[i' [s1' [A B]]] | [i' [A [B C]]]]. - left; exists i'; exists s1'; auto. - right; exists i'; intuition. -(* inductive case *) ++ left; exists i'; exists s1'; auto. ++ right; exists i'; intuition. +- (* inductive case *) exploit Eapp_E0_inv; eauto. intros [EQ1 EQ2]; subst. exploit bsim_simulation'; eauto. intros [[i' [s1' [A B]]] | [i' [A [B C]]]]. - exploit bsim_E0_star. apply plus_star; eauto. eauto. eapply star_safe; eauto. apply plus_star; auto. ++ exploit bsim_E0_star. apply plus_star; eauto. eauto. eapply star_safe; eauto. apply plus_star; auto. intros [i'' [s1'' [P Q]]]. left; exists i''; exists s1''; intuition. eapply plus_star_trans; eauto. - exploit IHplus; eauto. intros [P | [i'' [P Q]]]. ++ exploit IHplus; eauto. intros [P | [i'' [P Q]]]. left; auto. right; exists i''; intuition. eapply t_trans; eauto. apply t_step; auto. Qed. @@ -1098,21 +1100,20 @@ Variable L1: semantics. Variable L2: semantics. Variable L3: semantics. Hypothesis L3_single_events: single_events L3. -Variable S12: backward_simulation L1 L2. -Variable S23: backward_simulation L2 L3. +Context index order match_states (S12: bsim_properties L1 L2 index order match_states). +Context index' order' match_states' (S23: bsim_properties L2 L3 index' order' match_states'). -Let bb_index : Type := (bsim_index S12 * bsim_index S23)%type. +Let bb_index : Type := (index * index')%type. -Let bb_order : bb_index -> bb_index -> Prop := - lex_ord (clos_trans _ (bsim_order S12)) (bsim_order S23). +Definition bb_order : bb_index -> bb_index -> Prop := lex_ord (clos_trans _ order) order'. Inductive bb_match_states: bb_index -> state L1 -> state L3 -> Prop := | bb_match_later: forall i1 i2 s1 s3 s2x s2y, - S12 i1 s1 s2x -> Star L2 s2x E0 s2y -> S23 i2 s2y s3 -> + match_states i1 s1 s2x -> Star L2 s2x E0 s2y -> match_states' i2 s2y s3 -> bb_match_states (i1, i2) s1 s3. Lemma bb_match_at: forall i1 i2 s1 s3 s2, - S12 i1 s1 s2 -> S23 i2 s2 s3 -> + match_states i1 s1 s2 -> match_states' i2 s2 s3 -> bb_match_states (i1, i2) s1 s3. Proof. intros. econstructor; eauto. apply star_refl. @@ -1120,7 +1121,7 @@ Qed. Lemma bb_simulation_base: forall s3 t s3', Step L3 s3 t s3' -> - forall i1 s1 i2 s2, S12 i1 s1 s2 -> S23 i2 s2 s3 -> safe L1 s1 -> + forall i1 s1 i2 s2, match_states i1 s1 s2 -> match_states' i2 s2 s3 -> safe L1 s1 -> exists i', exists s1', (Plus L1 s1 t s1' \/ (Star L1 s1 t s1' /\ bb_order i' (i1, i2))) /\ bb_match_states i' s1' s3'. @@ -1128,29 +1129,29 @@ Proof. intros. exploit (bsim_simulation' S23); eauto. eapply bsim_safe; eauto. intros [ [i2' [s2' [PLUS2 MATCH2]]] | [i2' [ORD2 [EQ MATCH2]]]]. - (* 1 L2 makes one or several transitions *) +- (* 1 L2 makes one or several transitions *) assert (EITHER: t = E0 \/ (length t = 1)%nat). - exploit L3_single_events; eauto. - destruct t; auto. destruct t; auto. simpl. intros. omegaContradiction. + { exploit L3_single_events; eauto. + destruct t; auto. destruct t; auto. simpl. intros. omegaContradiction. } destruct EITHER. - (* 1.1 these are silent transitions *) - subst t. exploit bsim_E0_plus; eauto. ++ (* 1.1 these are silent transitions *) + subst t. exploit (bsim_E0_plus S12); eauto. intros [ [i1' [s1' [PLUS1 MATCH1]]] | [i1' [ORD1 MATCH1]]]. - (* 1.1.1 L1 makes one or several transitions *) +* (* 1.1.1 L1 makes one or several transitions *) exists (i1', i2'); exists s1'; split. auto. eapply bb_match_at; eauto. - (* 1.1.2 L1 makes no transitions *) +* (* 1.1.2 L1 makes no transitions *) exists (i1', i2'); exists s1; split. right; split. apply star_refl. left; auto. eapply bb_match_at; eauto. - (* 1.2 non-silent transitions *) ++ (* 1.2 non-silent transitions *) exploit star_non_E0_split. apply plus_star; eauto. auto. intros [s2x [s2y [P [Q R]]]]. - exploit bsim_E0_star. eexact P. eauto. auto. intros [i1' [s1x [X Y]]]. - exploit bsim_simulation'. eexact Q. eauto. eapply star_safe; eauto. + exploit (bsim_E0_star S12). eexact P. eauto. auto. intros [i1' [s1x [X Y]]]. + exploit (bsim_simulation' S12). eexact Q. eauto. eapply star_safe; eauto. intros [[i1'' [s1y [U V]]] | [i1'' [U [V W]]]]; try (subst t; discriminate). exists (i1'', i2'); exists s1y; split. left. eapply star_plus_trans; eauto. eapply bb_match_later; eauto. - (* 2. L2 makes no transitions *) +- (* 2. L2 makes no transitions *) subst. exists (i1, i2'); exists s1; split. right; split. apply star_refl. right; auto. eapply bb_match_at; eauto. @@ -1165,12 +1166,12 @@ Lemma bb_simulation: Proof. intros. inv H0. exploit star_inv; eauto. intros [[EQ1 EQ2] | PLUS]. - (* 1. match at *) +- (* 1. match at *) subst. eapply bb_simulation_base; eauto. - (* 2. match later *) - exploit bsim_E0_plus; eauto. +- (* 2. match later *) + exploit (bsim_E0_plus S12); eauto. intros [[i1' [s1' [A B]]] | [i1' [A B]]]. - (* 2.1 one or several silent transitions *) ++ (* 2.1 one or several silent transitions *) exploit bb_simulation_base. eauto. auto. eexact B. eauto. eapply star_safe; eauto. eapply plus_star; eauto. intros [i'' [s1'' [C D]]]. @@ -1178,7 +1179,7 @@ Proof. left. eapply plus_star_trans; eauto. destruct C as [P | [P Q]]. apply plus_star; eauto. eauto. traceEq. - (* 2.2 no silent transition *) ++ (* 2.2 no silent transition *) exploit bb_simulation_base. eauto. auto. eexact B. eauto. auto. intros [i'' [s1'' [C D]]]. exists i''; exists s1''; split; auto. @@ -1186,48 +1187,53 @@ Proof. inv H6. left. eapply t_trans; eauto. left; auto. Qed. -Lemma compose_backward_simulation: backward_simulation L1 L3. -Proof. - apply Backward_simulation with (bsim_order := bb_order) (bsim_match_states := bb_match_states). -(* well founded *) - unfold bb_order. apply wf_lex_ord. apply wf_clos_trans. apply bsim_order_wf. apply bsim_order_wf. -(* initial states exist *) - intros. exploit (bsim_initial_states_exist S12); eauto. intros [s2 A]. - eapply (bsim_initial_states_exist S23); eauto. -(* match initial states *) +End COMPOSE_BACKWARD_SIMULATIONS. + +Lemma compose_backward_simulation: + forall L1 L2 L3, + single_events L3 -> backward_simulation L1 L2 -> backward_simulation L2 L3 -> + backward_simulation L1 L3. +Proof. + intros L1 L2 L3 L3single S12 S23. + destruct S12 as [index order match_states props]. + destruct S23 as [index' order' match_states' props']. + apply Backward_simulation with (bb_order order order') (bb_match_states L1 L2 L3 match_states match_states'); + constructor. +- (* well founded *) + unfold bb_order. apply wf_lex_ord. apply wf_clos_trans. eapply bsim_order_wf; eauto. eapply bsim_order_wf; eauto. +- (* initial states exist *) + intros. exploit (bsim_initial_states_exist props); eauto. intros [s2 A]. + eapply (bsim_initial_states_exist props'); eauto. +- (* match initial states *) intros s1 s3 INIT1 INIT3. - exploit (bsim_initial_states_exist S12); eauto. intros [s2 INIT2]. - exploit (bsim_match_initial_states S23); eauto. intros [i2 [s2' [INIT2' M2]]]. - exploit (bsim_match_initial_states S12); eauto. intros [i1 [s1' [INIT1' M1]]]. - exists (i1, i2); exists s1'; intuition. eapply bb_match_at; eauto. -(* match final states *) + exploit (bsim_initial_states_exist props); eauto. intros [s2 INIT2]. + exploit (bsim_match_initial_states props'); eauto. intros [i2 [s2' [INIT2' M2]]]. + exploit (bsim_match_initial_states props); eauto. intros [i1 [s1' [INIT1' M1]]]. + exists (i1, i2); exists s1'; intuition auto. eapply bb_match_at; eauto. +- (* match final states *) intros i s1 s3 r MS SAFE FIN. inv MS. - exploit (bsim_match_final_states S23); eauto. + exploit (bsim_match_final_states props'); eauto. eapply star_safe; eauto. eapply bsim_safe; eauto. intros [s2' [A B]]. - exploit bsim_E0_star. eapply star_trans. eexact H0. eexact A. auto. eauto. auto. + exploit (bsim_E0_star props). eapply star_trans. eexact H0. eexact A. auto. eauto. auto. intros [i1' [s1' [C D]]]. - exploit (bsim_match_final_states S12); eauto. eapply star_safe; eauto. + exploit (bsim_match_final_states props); eauto. eapply star_safe; eauto. intros [s1'' [P Q]]. exists s1''; split; auto. eapply star_trans; eauto. -(* progress *) +- (* progress *) intros i s1 s3 MS SAFE. inv MS. - eapply (bsim_progress S23). eauto. eapply star_safe; eauto. eapply bsim_safe; eauto. -(* simulation *) - exact bb_simulation. -(* symbols *) - intros. transitivity (Senv.public_symbol (symbolenv L2) id); apply bsim_public_preserved; auto. + eapply (bsim_progress props'). eauto. eapply star_safe; eauto. eapply bsim_safe; eauto. +- (* simulation *) + apply bb_simulation; auto. +- (* symbols *) + intros. transitivity (Senv.public_symbol (symbolenv L2) id); eapply bsim_public_preserved; eauto. Qed. -End COMPOSE_BACKWARD_SIMULATIONS. - (** ** Converting a forward simulation to a backward simulation *) Section FORWARD_TO_BACKWARD. -Variable L1: semantics. -Variable L2: semantics. -Variable FS: forward_simulation L1 L2. +Context L1 L2 index order match_states (FS: fsim_properties L1 L2 index order match_states). Hypothesis L1_receptive: receptive L1. Hypothesis L2_determinate: determinate L2. @@ -1243,38 +1249,38 @@ Inductive f2b_transitions: state L1 -> state L2 -> Prop := Star L1 s1 E0 s1' -> Step L1 s1' t s1'' -> Plus L2 s2 t s2' -> - FS i' s1' s2 -> - FS i'' s1'' s2' -> + match_states i' s1' s2 -> + match_states i'' s1'' s2' -> f2b_transitions s1 s2. Lemma f2b_progress: - forall i s1 s2, FS i s1 s2 -> safe L1 s1 -> f2b_transitions s1 s2. + forall i s1 s2, match_states i s1 s2 -> safe L1 s1 -> f2b_transitions s1 s2. Proof. - intros i0; pattern i0. apply well_founded_ind with (R := fsim_order FS). - apply fsim_order_wf. + intros i0; pattern i0. apply well_founded_ind with (R := order). + eapply fsim_order_wf; eauto. intros i REC s1 s2 MATCH SAFE. destruct (SAFE s1) as [[r FINAL] | [t [s1' STEP1]]]. apply star_refl. - (* final state reached *) +- (* final state reached *) eapply f2b_trans_final; eauto. apply star_refl. eapply fsim_match_final_states; eauto. - (* L1 can make one step *) +- (* L1 can make one step *) exploit (fsim_simulation FS); eauto. intros [i' [s2' [A MATCH']]]. - assert (B: Plus L2 s2 t s2' \/ (s2' = s2 /\ t = E0 /\ fsim_order FS i' i)). - intuition. - destruct (star_inv H0); intuition. + assert (B: Plus L2 s2 t s2' \/ (s2' = s2 /\ t = E0 /\ order i' i)). + intuition auto. + destruct (star_inv H0); intuition auto. clear A. destruct B as [PLUS2 | [EQ1 [EQ2 ORDER]]]. - eapply f2b_trans_step; eauto. apply star_refl. - subst. exploit REC; eauto. eapply star_safe; eauto. apply star_one; auto. ++ eapply f2b_trans_step; eauto. apply star_refl. ++ subst. exploit REC; eauto. eapply star_safe; eauto. apply star_one; auto. intros TRANS; inv TRANS. - eapply f2b_trans_final; eauto. eapply star_left; eauto. - eapply f2b_trans_step; eauto. eapply star_left; eauto. +* eapply f2b_trans_final; eauto. eapply star_left; eauto. +* eapply f2b_trans_step; eauto. eapply star_left; eauto. Qed. Lemma fsim_simulation_not_E0: forall s1 t s1', Step L1 s1 t s1' -> t <> E0 -> - forall i s2, FS i s1 s2 -> - exists i', exists s2', Plus L2 s2 t s2' /\ FS i' s1' s2'. + forall i s2, match_states i s1 s2 -> + exists i', exists s2', Plus L2 s2 t s2' /\ match_states i' s1' s2'. Proof. intros. exploit (fsim_simulation FS); eauto. intros [i' [s2' [A B]]]. exists i'; exists s2'; split; auto. @@ -1363,23 +1369,23 @@ Qed. Inductive f2b_match_states: f2b_index -> state L1 -> state L2 -> Prop := | f2b_match_at: forall i s1 s2, - FS i s1 s2 -> + match_states i s1 s2 -> f2b_match_states (F2BI_after O) s1 s2 | f2b_match_before: forall s1 t s1' s2b s2 n s2a i, Step L1 s1 t s1' -> t <> E0 -> Star L2 s2b E0 s2 -> starN (step L2) (globalenv L2) n s2 t s2a -> - FS i s1 s2b -> + match_states i s1 s2b -> f2b_match_states (F2BI_before n) s1 s2 | f2b_match_after: forall n s2 s2a s1 i, starN (step L2) (globalenv L2) (S n) s2 E0 s2a -> - FS i s1 s2a -> + match_states i s1 s2a -> f2b_match_states (F2BI_after (S n)) s1 s2. Remark f2b_match_after': forall n s2 s2a s1 i, starN (step L2) (globalenv L2) n s2 E0 s2a -> - FS i s1 s2a -> + match_states i s1 s2a -> f2b_match_states (F2BI_after n) s1 s2. Proof. intros. inv H. @@ -1398,15 +1404,15 @@ Lemma f2b_simulation_step: Proof. intros s2 t s2' STEP2 i s1 MATCH SAFE. inv MATCH. -(* 1. At matching states *) +- (* 1. At matching states *) exploit f2b_progress; eauto. intros TRANS; inv TRANS. - (* 1.1 L1 can reach final state and L2 is at final state: impossible! *) ++ (* 1.1 L1 can reach final state and L2 is at final state: impossible! *) exploit (sd_final_nostep L2_determinate); eauto. contradiction. - (* 1.2 L1 can make 0 or several steps; L2 can make 1 or several matching steps. *) ++ (* 1.2 L1 can make 0 or several steps; L2 can make 1 or several matching steps. *) inv H2. exploit f2b_determinacy_inv. eexact H5. eexact STEP2. intros [[EQ1 [EQ2 EQ3]] | [NOT1 [NOT2 MT]]]. - (* 1.2.1 L2 makes a silent transition *) +* (* 1.2.1 L2 makes a silent transition *) destruct (silent_or_not_silent t2). (* 1.2.1.1 L1 makes a silent transition too: perform transition now and go to "after" state *) subst. simpl in *. destruct (star_starN H6) as [n STEPS2]. @@ -1418,7 +1424,7 @@ Proof. exists (F2BI_before n); exists s1'; split. right; split. auto. constructor. econstructor. eauto. auto. apply star_one; eauto. eauto. eauto. - (* 1.2.2 L2 makes a non-silent transition, and so does L1 *) +* (* 1.2.2 L2 makes a non-silent transition, and so does L1 *) exploit not_silent_length. eapply (sr_traces L1_receptive); eauto. intros [EQ | EQ]. congruence. subst t2. rewrite E0_right in H1. @@ -1437,15 +1443,15 @@ Proof. left. eapply plus_right; eauto. eapply f2b_match_after'; eauto. -(* 2. Before *) +- (* 2. Before *) inv H2. congruence. exploit f2b_determinacy_inv. eexact H4. eexact STEP2. intros [[EQ1 [EQ2 EQ3]] | [NOT1 [NOT2 MT]]]. - (* 2.1 L2 makes a silent transition: remain in "before" state *) ++ (* 2.1 L2 makes a silent transition: remain in "before" state *) subst. simpl in *. exists (F2BI_before n0); exists s1; split. right; split. apply star_refl. constructor. omega. econstructor; eauto. eapply star_right; eauto. - (* 2.2 L2 make a non-silent transition *) ++ (* 2.2 L2 make a non-silent transition *) exploit not_silent_length. eapply (sr_traces L1_receptive); eauto. intros [EQ | EQ]. congruence. subst. rewrite E0_right in *. @@ -1466,7 +1472,7 @@ Proof. left. apply plus_one; auto. eapply f2b_match_after'; eauto. -(* 3. After *) +- (* 3. After *) inv H. exploit Eapp_E0_inv; eauto. intros [EQ1 EQ2]; subst. exploit f2b_determinacy_inv. eexact H2. eexact STEP2. intros [[EQ1 [EQ2 EQ3]] | [NOT1 [NOT2 MT]]]. @@ -1476,20 +1482,28 @@ Proof. congruence. Qed. +End FORWARD_TO_BACKWARD. + (** The backward simulation *) -Lemma forward_to_backward_simulation: backward_simulation L1 L2. +Lemma forward_to_backward_simulation: + forall L1 L2, + forward_simulation L1 L2 -> receptive L1 -> determinate L2 -> + backward_simulation L1 L2. Proof. - apply Backward_simulation with (bsim_order := f2b_order) (bsim_match_states := f2b_match_states). + intros L1 L2 FS L1_receptive L2_determinate. + destruct FS as [index order match_states FS]. + apply Backward_simulation with f2b_order (f2b_match_states L1 L2 match_states); constructor. +- (* well founded *) apply wf_f2b_order. -(* initial states exist *) +- (* initial states exist *) intros. exploit (fsim_match_initial_states FS); eauto. intros [i [s2 [A B]]]. exists s2; auto. -(* initial states *) +- (* initial states *) intros. exploit (fsim_match_initial_states FS); eauto. intros [i [s2' [A B]]]. assert (s2 = s2') by (eapply sd_initial_determ; eauto). subst s2'. exists (F2BI_after O); exists s1; split; auto. econstructor; eauto. -(* final states *) +- (* final states *) intros. inv H. exploit f2b_progress; eauto. intros TRANS; inv TRANS. assert (r0 = r) by (eapply (sd_final_determ L2_determinate); eauto). subst r0. @@ -1497,21 +1511,19 @@ Proof. inv H4. exploit (sd_final_nostep L2_determinate); eauto. contradiction. inv H5. congruence. exploit (sd_final_nostep L2_determinate); eauto. contradiction. inv H2. exploit (sd_final_nostep L2_determinate); eauto. contradiction. -(* progress *) +- (* progress *) intros. inv H. exploit f2b_progress; eauto. intros TRANS; inv TRANS. left; exists r; auto. inv H3. right; econstructor; econstructor; eauto. inv H4. congruence. right; econstructor; econstructor; eauto. inv H1. right; econstructor; econstructor; eauto. -(* simulation *) - exact f2b_simulation_step. -(* symbols preserved *) +- (* simulation *) + eapply f2b_simulation_step; eauto. +- (* symbols preserved *) exact (fsim_public_preserved FS). Qed. -End FORWARD_TO_BACKWARD. - (** * Transforming a semantics into a single-event, equivalent semantics *) Definition well_behaved_traces (L: semantics) : Prop := @@ -1554,15 +1566,15 @@ Section FACTOR_FORWARD_SIMULATION. Variable L1: semantics. Variable L2: semantics. -Variable sim: forward_simulation L1 L2. +Context index order match_states (sim: fsim_properties L1 L2 index order match_states). Hypothesis L2single: single_events L2. -Inductive ffs_match: fsim_index sim -> (trace * state L1) -> state L2 -> Prop := +Inductive ffs_match: index -> (trace * state L1) -> state L2 -> Prop := | ffs_match_at: forall i s1 s2, - sim i s1 s2 -> + match_states i s1 s2 -> ffs_match i (E0, s1) s2 | ffs_match_buffer: forall i ev t s1 s2 s2', - Star L2 s2 (ev :: t) s2' -> sim i s1 s2' -> + Star L2 s2 (ev :: t) s2' -> match_states i s1 s2' -> ffs_match i (ev :: t, s1) s2. Lemma star_non_E0_split': @@ -1585,27 +1597,27 @@ Lemma ffs_simulation: forall s1 t s1', Step (atomic L1) s1 t s1' -> forall i s2, ffs_match i s1 s2 -> exists i', exists s2', - (Plus L2 s2 t s2' \/ (Star L2 s2 t s2') /\ fsim_order sim i' i) + (Plus L2 s2 t s2' \/ (Star L2 s2 t s2') /\ order i' i) /\ ffs_match i' s1' s2'. Proof. induction 1; intros. -(* silent step *) +- (* silent step *) inv H0. exploit (fsim_simulation sim); eauto. intros [i' [s2' [A B]]]. exists i'; exists s2'; split. auto. constructor; auto. -(* start step *) +- (* start step *) inv H0. exploit (fsim_simulation sim); eauto. intros [i' [s2' [A B]]]. destruct t as [ | ev' t]. - (* single event *) ++ (* single event *) exists i'; exists s2'; split. auto. constructor; auto. - (* multiple events *) ++ (* multiple events *) assert (C: Star L2 s2 (ev :: ev' :: t) s2'). intuition. apply plus_star; auto. exploit star_non_E0_split'. eauto. simpl. intros [s2x [P Q]]. exists i'; exists s2x; split. auto. econstructor; eauto. -(* continue step *) +- (* continue step *) inv H0. exploit star_non_E0_split'. eauto. simpl. intros [s2x [P Q]]. destruct t. @@ -1613,27 +1625,31 @@ Proof. exists i; exists s2x; split. auto. econstructor; eauto. Qed. +End FACTOR_FORWARD_SIMULATION. + Theorem factor_forward_simulation: + forall L1 L2, + forward_simulation L1 L2 -> single_events L2 -> forward_simulation (atomic L1) L2. Proof. - apply Forward_simulation with (fsim_match_states := ffs_match) (fsim_order := fsim_order sim). -(* wf *) - apply fsim_order_wf. -(* initial states *) + intros L1 L2 FS L2single. + destruct FS as [index order match_states sim]. + apply Forward_simulation with order (ffs_match L1 L2 match_states); constructor. +- (* wf *) + eapply fsim_order_wf; eauto. +- (* initial states *) intros. destruct s1 as [t1 s1]. simpl in H. destruct H. subst. exploit (fsim_match_initial_states sim); eauto. intros [i [s2 [A B]]]. exists i; exists s2; split; auto. constructor; auto. -(* final states *) +- (* final states *) intros. destruct s1 as [t1 s1]. simpl in H0; destruct H0; subst. inv H. eapply (fsim_match_final_states sim); eauto. -(* simulation *) - exact ffs_simulation. -(* symbols preserved *) +- (* simulation *) + eapply ffs_simulation; eauto. +- (* symbols preserved *) simpl. exact (fsim_public_preserved sim). Qed. -End FACTOR_FORWARD_SIMULATION. - (** Likewise, a backward simulation from a single-event semantics [L1] to a semantics [L2] can be "factored" as a backward simulation from [L1] to [atomic L2]. *) @@ -1641,13 +1657,13 @@ Section FACTOR_BACKWARD_SIMULATION. Variable L1: semantics. Variable L2: semantics. -Variable sim: backward_simulation L1 L2. +Context index order match_states (sim: bsim_properties L1 L2 index order match_states). Hypothesis L1single: single_events L1. Hypothesis L2wb: well_behaved_traces L2. -Inductive fbs_match: bsim_index sim -> state L1 -> (trace * state L2) -> Prop := +Inductive fbs_match: index -> state L1 -> (trace * state L2) -> Prop := | fbs_match_intro: forall i s1 t s2 s1', - Star L1 s1 t s1' -> sim i s1' s2 -> + Star L1 s1 t s1' -> match_states i s1' s2 -> t = E0 \/ output_trace t -> fbs_match i s1 (t, s2). @@ -1655,18 +1671,18 @@ Lemma fbs_simulation: forall s2 t s2', Step (atomic L2) s2 t s2' -> forall i s1, fbs_match i s1 s2 -> safe L1 s1 -> exists i', exists s1', - (Plus L1 s1 t s1' \/ (Star L1 s1 t s1' /\ bsim_order sim i' i)) + (Plus L1 s1 t s1' \/ (Star L1 s1 t s1' /\ order i' i)) /\ fbs_match i' s1' s2'. Proof. induction 1; intros. -(* silent step *) +- (* silent step *) inv H0. exploit (bsim_simulation sim); eauto. eapply star_safe; eauto. intros [i' [s1'' [A B]]]. exists i'; exists s1''; split. destruct A as [P | [P Q]]. left. eapply star_plus_trans; eauto. right; split; auto. eapply star_trans; eauto. econstructor. apply star_refl. auto. auto. -(* start step *) +- (* start step *) inv H0. exploit (bsim_simulation sim); eauto. eapply star_safe; eauto. intros [i' [s1'' [A B]]]. @@ -1677,7 +1693,7 @@ Proof. left; auto. econstructor; eauto. exploit L2wb; eauto. -(* continue step *) +- (* continue step *) inv H0. unfold E0 in H8; destruct H8; try congruence. exploit star_non_E0_split'; eauto. simpl. intros [s1x [P Q]]. exists i; exists s1x; split. left; auto. econstructor; eauto. simpl in H0; tauto. @@ -1690,47 +1706,51 @@ Lemma fbs_progress: (exists t, exists s2', Step (atomic L2) s2 t s2'). Proof. intros. inv H. destruct t. -(* 1. no buffered events *) +- (* 1. no buffered events *) exploit (bsim_progress sim); eauto. eapply star_safe; eauto. intros [[r A] | [t [s2' A]]]. -(* final state *) ++ (* final state *) left; exists r; simpl; auto. -(* L2 can step *) ++ (* L2 can step *) destruct t. right; exists E0; exists (nil, s2'). constructor. auto. right; exists (e :: nil); exists (t, s2'). constructor. auto. -(* 2. some buffered events *) +- (* 2. some buffered events *) unfold E0 in H3; destruct H3. congruence. right; exists (e :: nil); exists (t, s3). constructor. auto. Qed. +End FACTOR_BACKWARD_SIMULATION. + Theorem factor_backward_simulation: + forall L1 L2, + backward_simulation L1 L2 -> single_events L1 -> well_behaved_traces L2 -> backward_simulation L1 (atomic L2). Proof. - apply Backward_simulation with (bsim_match_states := fbs_match) (bsim_order := bsim_order sim). -(* wf *) - apply bsim_order_wf. -(* initial states exist *) + intros L1 L2 BS L1single L2wb. + destruct BS as [index order match_states sim]. + apply Backward_simulation with order (fbs_match L1 L2 match_states); constructor. +- (* wf *) + eapply bsim_order_wf; eauto. +- (* initial states exist *) intros. exploit (bsim_initial_states_exist sim); eauto. intros [s2 A]. exists (E0, s2). simpl; auto. -(* initial states match *) +- (* initial states match *) intros. destruct s2 as [t s2]; simpl in H0; destruct H0; subst. exploit (bsim_match_initial_states sim); eauto. intros [i [s1' [A B]]]. exists i; exists s1'; split. auto. econstructor. apply star_refl. auto. auto. -(* final states match *) +- (* final states match *) intros. destruct s2 as [t s2]; simpl in H1; destruct H1; subst. inv H. exploit (bsim_match_final_states sim); eauto. eapply star_safe; eauto. intros [s1'' [A B]]. exists s1''; split; auto. eapply star_trans; eauto. -(* progress *) - exact fbs_progress. -(* simulation *) - exact fbs_simulation. -(* symbols *) +- (* progress *) + eapply fbs_progress; eauto. +- (* simulation *) + eapply fbs_simulation; eauto. +- (* symbols *) simpl. exact (bsim_public_preserved sim). Qed. -End FACTOR_BACKWARD_SIMULATION. - (** Receptiveness of [atomic L]. *) Record strongly_receptive (L: semantics) : Prop := diff --git a/driver/Compiler.v b/driver/Compiler.v index ea5849ec..dd752aca 100644 --- a/driver/Compiler.v +++ b/driver/Compiler.v @@ -14,15 +14,10 @@ (** Libraries. *) Require Import String. -Require Import Coqlib. -Require Import Errors. -Require Import AST. -Require Import Smallstep. +Require Import Coqlib Errors. +Require Import AST Linking Smallstep. (** Languages (syntax and semantics). *) -Require Csyntax. -Require Csem. -Require Cstrategy. -Require Cexec. +Require Ctypes Csyntax Csem Cstrategy Cexec. Require Clight. Require Csharpminor. Require Cminor. @@ -192,171 +187,228 @@ Proof. intros. destruct x; simpl. rewrite print_identity. auto. auto. Qed. -Remark forward_simulation_identity: - forall sem, forward_simulation sem sem. +(** * Relational specification of compilation *) + +Definition match_if {A: Type} (flag: unit -> bool) (R: A -> A -> Prop): A -> A -> Prop := + if flag tt then R else eq. + +Lemma total_if_match: + forall (A: Type) (flag: unit -> bool) (f: A -> A) (rel: A -> A -> Prop) (prog: A), + (forall p, rel p (f p)) -> + match_if flag rel prog (total_if flag f prog). Proof. - intros. apply forward_simulation_step with (fun s1 s2 => s2 = s1); intros. -- auto. -- exists s1; auto. -- subst s2; auto. -- subst s2. exists s1'; auto. + intros. unfold match_if, total_if. destruct (flag tt); auto. Qed. -Lemma total_if_simulation: - forall (A: Type) (sem: A -> semantics) (flag: unit -> bool) (f: A -> A) (prog: A), - (forall p, forward_simulation (sem p) (sem (f p))) -> - forward_simulation (sem prog) (sem (total_if flag f prog)). +Lemma partial_if_match: + forall (A: Type) (flag: unit -> bool) (f: A -> res A) (rel: A -> A -> Prop) (prog tprog: A), + (forall p tp, f p = OK tp -> rel p tp) -> + partial_if flag f prog = OK tprog -> + match_if flag rel prog tprog. Proof. - intros. unfold total_if. destruct (flag tt). auto. apply forward_simulation_identity. + intros. unfold match_if, partial_if in *. destruct (flag tt). auto. congruence. Qed. -Lemma partial_if_simulation: - forall (A: Type) (sem: A -> semantics) (flag: unit -> bool) (f: A -> res A) (prog tprog: A), - partial_if flag f prog = OK tprog -> - (forall p tp, f p = OK tp -> forward_simulation (sem p) (sem tp)) -> - forward_simulation (sem prog) (sem tprog). +Instance TransfIfLink {A: Type} {LA: Linker A} + (flag: unit -> bool) (transf: A -> A -> Prop) (TL: TransfLink transf) + : TransfLink (match_if flag transf). +Proof. + unfold match_if. destruct (flag tt). +- auto. +- red; intros. subst tp1 tp2. exists p; auto. +Qed. + +(** This is the list of compilation passes of CompCert in relational style. + Each pass is characterized by a [match_prog] relation between its + input code and its output code. The [mkpass] and [:::] combinators, + defined in module [Linking], ensure that the passes are composable + (the output language of a pass is the input language of the next pass) + and that they commute with linking (property [TransfLink], inferred + by the type class mechanism of Coq). *) + +Local Open Scope linking_scope. + +Definition CompCert's_passes := + mkpass SimplExprproof.match_prog + ::: mkpass SimplLocalsproof.match_prog + ::: mkpass Cshmgenproof.match_prog + ::: mkpass Cminorgenproof.match_prog + ::: mkpass Selectionproof.match_prog + ::: mkpass RTLgenproof.match_prog + ::: mkpass (match_if Compopts.optim_tailcalls Tailcallproof.match_prog) + ::: mkpass Inliningproof.match_prog + ::: mkpass Renumberproof.match_prog + ::: mkpass (match_if Compopts.optim_constprop Constpropproof.match_prog) + ::: mkpass (match_if Compopts.optim_constprop Renumberproof.match_prog) + ::: mkpass (match_if Compopts.optim_CSE CSEproof.match_prog) + ::: mkpass (match_if Compopts.optim_redundancy Deadcodeproof.match_prog) + ::: mkpass Unusedglobproof.match_prog + ::: mkpass Allocproof.match_prog + ::: mkpass Tunnelingproof.match_prog + ::: mkpass Linearizeproof.match_prog + ::: mkpass CleanupLabelsproof.match_prog + ::: mkpass (match_if Compopts.debug Debugvarproof.match_prog) + ::: mkpass Stackingproof.match_prog + ::: mkpass Asmgenproof.match_prog + ::: pass_nil _. + +(** Composing the [match_prog] relations above, we obtain the relation + between CompCert C sources and Asm code that characterize CompCert's + compilation. *) + +Definition match_prog: Csyntax.program -> Asm.program -> Prop := + pass_match (compose_passes CompCert's_passes). + +(** The [transf_c_program] function, when successful, produces + assembly code that is in the [match_prog] relation with the source C program. *) + +Theorem transf_c_program_match: + forall p tp, + transf_c_program p = OK tp -> + match_prog p tp. Proof. - intros. unfold partial_if in *. destruct (flag tt). eauto. inv H. apply forward_simulation_identity. + intros p tp T. + unfold transf_c_program, time in T. simpl in T. + destruct (SimplExpr.transl_program p) as [p1|e] eqn:P1; simpl in T; try discriminate. + unfold transf_clight_program, time in T. rewrite ! compose_print_identity in T. simpl in T. + destruct (SimplLocals.transf_program p1) as [p2|e] eqn:P2; simpl in T; try discriminate. + destruct (Cshmgen.transl_program p2) as [p3|e] eqn:P3; simpl in T; try discriminate. + destruct (Cminorgen.transl_program p3) as [p4|e] eqn:P4; simpl in T; try discriminate. + unfold transf_cminor_program, time in T. rewrite ! compose_print_identity in T. simpl in T. + destruct (Selection.sel_program p4) as [p5|e] eqn:P5; simpl in T; try discriminate. + destruct (RTLgen.transl_program p5) as [p6|e] eqn:P6; simpl in T; try discriminate. + unfold transf_rtl_program, time in T. rewrite ! compose_print_identity in T. simpl in T. + set (p7 := total_if optim_tailcalls Tailcall.transf_program p6) in *. + destruct (Inlining.transf_program p7) as [p8|e] eqn:P8; simpl in T; try discriminate. + set (p9 := Renumber.transf_program p8) in *. + set (p10 := total_if optim_constprop Constprop.transf_program p9) in *. + set (p11 := total_if optim_constprop Renumber.transf_program p10) in *. + destruct (partial_if optim_CSE CSE.transf_program p11) as [p12|e] eqn:P12; simpl in T; try discriminate. + destruct (partial_if optim_redundancy Deadcode.transf_program p12) as [p13|e] eqn:P13; simpl in T; try discriminate. + destruct (Unusedglob.transform_program p13) as [p14|e] eqn:P14; simpl in T; try discriminate. + destruct (Allocation.transf_program p14) as [p15|e] eqn:P15; simpl in T; try discriminate. + set (p16 := Tunneling.tunnel_program p15) in *. + destruct (Linearize.transf_program p16) as [p17|e] eqn:P17; simpl in T; try discriminate. + set (p18 := CleanupLabels.transf_program p17) in *. + destruct (partial_if debug Debugvar.transf_program p18) as [p19|e] eqn:P19; simpl in T; try discriminate. + destruct (Stacking.transf_program p19) as [p20|e] eqn:P20; simpl in T; try discriminate. + unfold match_prog; simpl. + exists p1; split. apply SimplExprproof.transf_program_match; auto. + exists p2; split. apply SimplLocalsproof.match_transf_program; auto. + exists p3; split. apply Cshmgenproof.transf_program_match; auto. + exists p4; split. apply Cminorgenproof.transf_program_match; auto. + exists p5; split. apply Selectionproof.transf_program_match; auto. + exists p6; split. apply RTLgenproof.transf_program_match; auto. + exists p7; split. apply total_if_match. apply Tailcallproof.transf_program_match. + exists p8; split. apply Inliningproof.transf_program_match; auto. + exists p9; split. apply Renumberproof.transf_program_match; auto. + exists p10; split. apply total_if_match. apply Constpropproof.transf_program_match. + exists p11; split. apply total_if_match. apply Renumberproof.transf_program_match. + exists p12; split. eapply partial_if_match; eauto. apply CSEproof.transf_program_match. + exists p13; split. eapply partial_if_match; eauto. apply Deadcodeproof.transf_program_match. + exists p14; split. apply Unusedglobproof.transf_program_match; auto. + exists p15; split. apply Allocproof.transf_program_match; auto. + exists p16; split. apply Tunnelingproof.transf_program_match. + exists p17; split. apply Linearizeproof.transf_program_match; auto. + exists p18; split. apply CleanupLabelsproof.transf_program_match; auto. + exists p19; split. eapply partial_if_match; eauto. apply Debugvarproof.transf_program_match. + exists p20; split. apply Stackingproof.transf_program_match; auto. + exists tp; split. apply Asmgenproof.transf_program_match; auto. + reflexivity. Qed. (** * Semantic preservation *) -(** We prove that the [transf_program] translations preserve semantics - by constructing the following simulations: -- Forward simulations from [Cstrategy] / [Cminor] / [RTL] to [Asm] +(** We now prove that the whole CompCert compiler (as characterized by the + [match_prog] relation) preserves semantics by constructing + the following simulations: +- Forward simulations from [Cstrategy] to [Asm] (composition of the forward simulations for each pass). - Backward simulations for the same languages (derived from the forward simulation, using receptiveness of the source language and determinacy of [Asm]). - Backward simulation from [Csem] to [Asm] (composition of two backward simulations). +*) -These results establish the correctness of the whole compiler! *) - -Theorem transf_rtl_program_correct: - forall p tp, - transf_rtl_program p = OK tp -> - forward_simulation (RTL.semantics p) (Asm.semantics tp) - * backward_simulation (RTL.semantics p) (Asm.semantics tp). -Proof. - intros. - assert (F: forward_simulation (RTL.semantics p) (Asm.semantics tp)). - unfold transf_rtl_program, time in H. - repeat rewrite compose_print_identity in H. - simpl in H. - set (p1 := total_if optim_tailcalls Tailcall.transf_program p) in *. - destruct (Inlining.transf_program p1) as [p11|] eqn:?; simpl in H; try discriminate. - set (p12 := Renumber.transf_program p11) in *. - set (p2 := total_if optim_constprop Constprop.transf_program p12) in *. - set (p21 := total_if optim_constprop Renumber.transf_program p2) in *. - destruct (partial_if optim_CSE CSE.transf_program p21) as [p3|] eqn:?; simpl in H; try discriminate. - destruct (partial_if optim_redundancy Deadcode.transf_program p3) as [p31|] eqn:?; simpl in H; try discriminate. - destruct (Unusedglob.transform_program p31) as [p32|] eqn:?; simpl in H; try discriminate. - destruct (Allocation.transf_program p32) as [p4|] eqn:?; simpl in H; try discriminate. - set (p5 := Tunneling.tunnel_program p4) in *. - destruct (Linearize.transf_program p5) as [p6|] eqn:?; simpl in H; try discriminate. - set (p7 := CleanupLabels.transf_program p6) in *. - destruct (partial_if debug Debugvar.transf_program p7) as [p71|] eqn:?; simpl in H; try discriminate. - destruct (Stacking.transf_program p71) as [p8|] eqn:?; simpl in H; try discriminate. - apply compose_forward_simulation with (RTL.semantics p1). - apply total_if_simulation. apply Tailcallproof.transf_program_correct. - apply compose_forward_simulation with (RTL.semantics p11). - apply Inliningproof.transf_program_correct; auto. - apply compose_forward_simulation with (RTL.semantics p12). - apply Renumberproof.transf_program_correct. - apply compose_forward_simulation with (RTL.semantics p2). - apply total_if_simulation. apply Constpropproof.transf_program_correct. - apply compose_forward_simulation with (RTL.semantics p21). - apply total_if_simulation. apply Renumberproof.transf_program_correct. - apply compose_forward_simulation with (RTL.semantics p3). - eapply partial_if_simulation; eauto. apply CSEproof.transf_program_correct. - apply compose_forward_simulation with (RTL.semantics p31). - eapply partial_if_simulation; eauto. apply Deadcodeproof.transf_program_correct. - apply compose_forward_simulation with (RTL.semantics p32). - apply Unusedglobproof.transf_program_correct; auto. - apply compose_forward_simulation with (LTL.semantics p4). - apply Allocproof.transf_program_correct; auto. - apply compose_forward_simulation with (LTL.semantics p5). - apply Tunnelingproof.transf_program_correct. - apply compose_forward_simulation with (Linear.semantics p6). - apply Linearizeproof.transf_program_correct; auto. - apply compose_forward_simulation with (Linear.semantics p7). - apply CleanupLabelsproof.transf_program_correct. - apply compose_forward_simulation with (Linear.semantics p71). - eapply partial_if_simulation; eauto. apply Debugvarproof.transf_program_correct. - apply compose_forward_simulation with (Mach.semantics Asmgenproof0.return_address_offset p8). - apply Stackingproof.transf_program_correct. - exact Asmgenproof.return_address_exists. - auto. - apply Asmgenproof.transf_program_correct; eauto. - split. auto. - apply forward_to_backward_simulation. auto. - apply RTL.semantics_receptive. - apply Asm.semantics_determinate. -Qed. - -Theorem transf_cminor_program_correct: - forall p tp, - transf_cminor_program p = OK tp -> - forward_simulation (Cminor.semantics p) (Asm.semantics tp) - * backward_simulation (Cminor.semantics p) (Asm.semantics tp). +Remark forward_simulation_identity: + forall sem, forward_simulation sem sem. Proof. - intros. - assert (F: forward_simulation (Cminor.semantics p) (Asm.semantics tp)). - unfold transf_cminor_program, time in H. - repeat rewrite compose_print_identity in H. - simpl in H. - destruct (Selection.sel_program p) as [p1|] eqn:?; simpl in H; try discriminate. - destruct (RTLgen.transl_program p1) as [p2|] eqn:?; simpl in H; try discriminate. - eapply compose_forward_simulation. apply Selectionproof.transf_program_correct. eauto. - eapply compose_forward_simulation. apply RTLgenproof.transf_program_correct. eassumption. - exact (fst (transf_rtl_program_correct _ _ H)). - - split. auto. - apply forward_to_backward_simulation. auto. - apply Cminor.semantics_receptive. - apply Asm.semantics_determinate. + intros. apply forward_simulation_step with (fun s1 s2 => s2 = s1); intros. +- auto. +- exists s1; auto. +- subst s2; auto. +- subst s2. exists s1'; auto. Qed. -Theorem transf_clight_program_correct: - forall p tp, - transf_clight_program p = OK tp -> - forward_simulation (Clight.semantics1 p) (Asm.semantics tp) - * backward_simulation (Clight.semantics1 p) (Asm.semantics tp). +Lemma match_if_simulation: + forall (A: Type) (sem: A -> semantics) (flag: unit -> bool) (transf: A -> A -> Prop) (prog tprog: A), + match_if flag transf prog tprog -> + (forall p tp, transf p tp -> forward_simulation (sem p) (sem tp)) -> + forward_simulation (sem prog) (sem tprog). Proof. - intros. - assert (F: forward_simulation (Clight.semantics1 p) (Asm.semantics tp)). - revert H; unfold transf_clight_program, time; simpl. - rewrite print_identity. - caseEq (SimplLocals.transf_program p); simpl; try congruence; intros p0 EQ0. - caseEq (Cshmgen.transl_program p0); simpl; try congruence; intros p1 EQ1. - caseEq (Cminorgen.transl_program p1); simpl; try congruence; intros p2 EQ2. - intros EQ3. - eapply compose_forward_simulation. apply SimplLocalsproof.transf_program_correct. eauto. - eapply compose_forward_simulation. apply Cshmgenproof.transl_program_correct. eauto. - eapply compose_forward_simulation. apply Cminorgenproof.transl_program_correct. eauto. - exact (fst (transf_cminor_program_correct _ _ EQ3)). - - split. auto. - apply forward_to_backward_simulation. auto. - apply Clight.semantics_receptive. - apply Asm.semantics_determinate. + intros. unfold match_if in *. destruct (flag tt). eauto. subst. apply forward_simulation_identity. Qed. -Theorem transf_cstrategy_program_correct: +Theorem cstrategy_semantic_preservation: forall p tp, - transf_c_program p = OK tp -> + match_prog p tp -> forward_simulation (Cstrategy.semantics p) (Asm.semantics tp) - * backward_simulation (atomic (Cstrategy.semantics p)) (Asm.semantics tp). + /\ backward_simulation (atomic (Cstrategy.semantics p)) (Asm.semantics tp). Proof. - intros. - assert (F: forward_simulation (Cstrategy.semantics p) (Asm.semantics tp)). - revert H; unfold transf_c_program, time; simpl. - caseEq (SimplExpr.transl_program p); simpl; try congruence; intros p0 EQ0. - intros EQ1. - eapply compose_forward_simulation. apply SimplExprproof.transl_program_correct. eauto. - exact (fst (transf_clight_program_correct _ _ EQ1)). - + intros p tp M. unfold match_prog, pass_match in M; simpl in M. +Ltac DestructM := + match goal with + [ H: exists p, _ /\ _ |- _ ] => + let p := fresh "p" in let M := fresh "M" in let MM := fresh "MM" in + destruct H as (p & M & MM); clear H + end. + repeat DestructM. subst tp. + assert (F: forward_simulation (Cstrategy.semantics p) (Asm.semantics p21)). + { + eapply compose_forward_simulations. + eapply SimplExprproof.transl_program_correct; eassumption. + eapply compose_forward_simulations. + eapply SimplLocalsproof.transf_program_correct; eassumption. + eapply compose_forward_simulations. + eapply Cshmgenproof.transl_program_correct; eassumption. + eapply compose_forward_simulations. + eapply Cminorgenproof.transl_program_correct; eassumption. + eapply compose_forward_simulations. + eapply Selectionproof.transf_program_correct; eassumption. + eapply compose_forward_simulations. + eapply RTLgenproof.transf_program_correct; eassumption. + eapply compose_forward_simulations. + eapply match_if_simulation. eassumption. exact Tailcallproof.transf_program_correct. + eapply compose_forward_simulations. + eapply Inliningproof.transf_program_correct; eassumption. + eapply compose_forward_simulations. eapply Renumberproof.transf_program_correct; eassumption. + eapply compose_forward_simulations. + eapply match_if_simulation. eassumption. exact Constpropproof.transf_program_correct. + eapply compose_forward_simulations. + eapply match_if_simulation. eassumption. exact Renumberproof.transf_program_correct. + eapply compose_forward_simulations. + eapply match_if_simulation. eassumption. exact CSEproof.transf_program_correct. + eapply compose_forward_simulations. + eapply match_if_simulation. eassumption. exact Deadcodeproof.transf_program_correct; eassumption. + eapply compose_forward_simulations. + eapply Unusedglobproof.transf_program_correct; eassumption. + eapply compose_forward_simulations. + eapply Allocproof.transf_program_correct; eassumption. + eapply compose_forward_simulations. + eapply Tunnelingproof.transf_program_correct; eassumption. + eapply compose_forward_simulations. + eapply Linearizeproof.transf_program_correct; eassumption. + eapply compose_forward_simulations. + eapply CleanupLabelsproof.transf_program_correct; eassumption. + eapply compose_forward_simulations. + eapply match_if_simulation. eassumption. exact Debugvarproof.transf_program_correct. + eapply compose_forward_simulations. + eapply Stackingproof.transf_program_correct with (return_address_offset := Asmgenproof0.return_address_offset). + exact Asmgenproof.return_address_exists. + eassumption. + eapply Asmgenproof.transf_program_correct; eassumption. + } split. auto. apply forward_to_backward_simulation. apply factor_forward_simulation. auto. eapply sd_traces. eapply Asm.semantics_determinate. @@ -364,9 +416,9 @@ Proof. apply Asm.semantics_determinate. Qed. -Theorem transf_c_program_correct: +Theorem c_semantic_preservation: forall p tp, - transf_c_program p = OK tp -> + match_prog p tp -> backward_simulation (Csem.semantics p) (Asm.semantics tp). Proof. intros. @@ -376,5 +428,54 @@ Proof. apply Cstrategy.strategy_simulation. apply Csem.semantics_single_events. eapply ssr_well_behaved; eapply Cstrategy.semantics_strongly_receptive. - exact (snd (transf_cstrategy_program_correct _ _ H)). + exact (proj2 (cstrategy_semantic_preservation _ _ H)). +Qed. + +(** * Correctness of the CompCert compiler *) + +(** Combining the results above, we obtain semantic preservation for two + usage scenarios of CompCert: compilation of a single monolithic program, + and separate compilation of multiple source files followed by linking. + + In the monolithic case, we have a whole C program [p] that is + compiled in one run of CompCert to a whole Asm program [tp]. + Then, [tp] preserves the semantics of [p], in the sense that there + exists a backward simulation of the dynamic semantics of [p] + by the dynamic semantics of [tp]. *) + +Theorem transf_c_program_correct: + forall p tp, + transf_c_program p = OK tp -> + backward_simulation (Csem.semantics p) (Asm.semantics tp). +Proof. + intros. apply c_semantic_preservation. apply transf_c_program_match; auto. +Qed. + +(** Here is the separate compilation case. Consider a nonempty list [c_units] + of C source files (compilation units), [C1 ,,, Cn]. Assume that every + C compilation unit [Ci] is successfully compiled by CompCert, obtaining + an Asm compilation unit [Ai]. Let [asm_unit] be the nonempty list + [A1 ... An]. Further assume that the C units [C1 ... Cn] can be linked + together to produce a whole C program [c_program]. Then, the generated + Asm units can be linked together, producing a whole Asm program + [asm_program]. Moreover, [asm_program] preserves the semantics of + [c_program], in the sense that there exists a backward simulation of + the dynamic semantics of [asm_program] by the dynamic semantics of [c_program]. +*) + +Theorem separate_transf_c_program_correct: + forall c_units asm_units c_program, + nlist_forall2 (fun cu tcu => transf_c_program cu = OK tcu) c_units asm_units -> + link_list c_units = Some c_program -> + exists asm_program, + link_list asm_units = Some asm_program + /\ backward_simulation (Csem.semantics c_program) (Asm.semantics asm_program). +Proof. + intros. + assert (nlist_forall2 match_prog c_units asm_units). + { eapply nlist_forall2_imply. eauto. simpl; intros. apply transf_c_program_match; auto. } + assert (exists asm_program, link_list asm_units = Some asm_program /\ match_prog c_program asm_program). + { eapply link_list_compose_passes; eauto. } + destruct H2 as (asm_program & P & Q). + exists asm_program; split; auto. apply c_semantic_preservation; auto. Qed. diff --git a/driver/Complements.v b/driver/Complements.v index 8651f2ff..f7598758 100644 --- a/driver/Complements.v +++ b/driver/Complements.v @@ -80,17 +80,19 @@ Theorem transf_cstrategy_program_preservation: Proof. assert (WBT: forall p, well_behaved_traces (Cstrategy.semantics p)). intros. eapply ssr_well_behaved. apply Cstrategy.semantics_strongly_receptive. - intros. intuition. + intros. + assert (MATCH: match_prog p tp) by (apply transf_c_program_match; auto). + intuition auto. eapply forward_simulation_behavior_improves; eauto. - apply (fst (transf_cstrategy_program_correct _ _ H)). + apply (proj1 (cstrategy_semantic_preservation _ _ MATCH)). exploit backward_simulation_behavior_improves. - apply (snd (transf_cstrategy_program_correct _ _ H)). + apply (proj2 (cstrategy_semantic_preservation _ _ MATCH)). eauto. intros [beh1 [A B]]. exists beh1; split; auto. rewrite atomic_behaviors; auto. eapply forward_simulation_same_safe_behavior; eauto. - apply (fst (transf_cstrategy_program_correct _ _ H)). + apply (proj1 (cstrategy_semantic_preservation _ _ MATCH)). exploit backward_simulation_same_safe_behavior. - apply (snd (transf_cstrategy_program_correct _ _ H)). + apply (proj2 (cstrategy_semantic_preservation _ _ MATCH)). intros. rewrite <- atomic_behaviors in H2; eauto. eauto. intros. rewrite atomic_behaviors; auto. Qed. diff --git a/exportclight/ExportClight.ml b/exportclight/ExportClight.ml index 5d4ab88b..b5877f8b 100644 --- a/exportclight/ExportClight.ml +++ b/exportclight/ExportClight.ml @@ -237,6 +237,8 @@ let external_function p = function fprintf p "@[<hov 2>(EF_external %a@ %a)@]" coqstring name signatur sg | EF_builtin(name, sg) -> fprintf p "@[<hov 2>(EF_builtin %a@ %a)@]" coqstring name signatur sg + | EF_runtime(name, sg) -> + fprintf p "@[<hov 2>(EF_runtime %a@ %a)@]" coqstring name signatur sg | EF_vload chunk -> fprintf p "(EF_vload %s)" (name_of_chunk chunk) | EF_vstore chunk -> diff --git a/extraction/extraction.v b/extraction/extraction.v index 0f0a8637..22a69c49 100644 --- a/extraction/extraction.v +++ b/extraction/extraction.v @@ -158,11 +158,10 @@ Separate Extraction Csyntax.Eindex Csyntax.Epreincr Ctyping.typecheck_program Ctyping.epostincr Ctyping.epostdecr Ctyping.epreincr Ctyping.epredecr - Clight.make_program + Ctypes.make_program Conventions1.dummy_int_reg Conventions1.dummy_float_reg RTL.instr_defs RTL.instr_uses Machregs.mregs_for_operation Machregs.mregs_for_builtin Machregs.two_address_op Machregs.is_stack_reg AST.signature_main - AST.transform_partial_ident_program Parser.translation_unit_file. diff --git a/ia32/Asmexpand.ml b/ia32/Asmexpand.ml index 7ca31902..61beeb00 100644 --- a/ia32/Asmexpand.ml +++ b/ia32/Asmexpand.ml @@ -460,4 +460,4 @@ let expand_fundef id = function Errors.OK (External ef) let expand_program (p: Asm.program) : Asm.program Errors.res = - AST.transform_partial_ident_program expand_fundef p + AST.transform_partial_program2 expand_fundef (fun id v -> Errors.OK v) p diff --git a/ia32/Asmgen.v b/ia32/Asmgen.v index 91122898..fd0d5bc5 100644 --- a/ia32/Asmgen.v +++ b/ia32/Asmgen.v @@ -12,16 +12,9 @@ (** Translation from Mach to IA32 Asm. *) -Require Import Coqlib. -Require Import Errors. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Memdata. -Require Import Op. -Require Import Locations. -Require Import Mach. -Require Import Asm. +Require Import Coqlib Errors. +Require Import Integers Floats AST Memdata. +Require Import Op Locations Mach Asm. Open Local Scope string_scope. Open Local Scope error_monad_scope. diff --git a/ia32/Asmgenproof.v b/ia32/Asmgenproof.v index 105347e7..28237237 100644 --- a/ia32/Asmgenproof.v +++ b/ia32/Asmgenproof.v @@ -12,56 +12,43 @@ (** Correctness proof for x86 generation: main proof. *) -Require Import Coqlib. -Require Import Errors. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import Memory. -Require Import Events. -Require Import Globalenvs. -Require Import Smallstep. -Require Import Op. -Require Import Locations. -Require Import Mach. -Require Import Conventions. -Require Import Asm. -Require Import Asmgen. -Require Import Asmgenproof0. -Require Import Asmgenproof1. +Require Import Coqlib Errors. +Require Import Integers Floats AST Linking. +Require Import Values Memory Events Globalenvs Smallstep. +Require Import Op Locations Mach Conventions Asm. +Require Import Asmgen Asmgenproof0 Asmgenproof1. + +Definition match_prog (p: Mach.program) (tp: Asm.program) := + match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp. + +Lemma transf_program_match: + forall p tp, transf_program p = OK tp -> match_prog p tp. +Proof. + intros. eapply match_transform_partial_program; eauto. +Qed. Section PRESERVATION. Variable prog: Mach.program. Variable tprog: Asm.program. -Hypothesis TRANSF: transf_program prog = Errors.OK tprog. - +Hypothesis TRANSF: match_prog prog tprog. Let ge := Genv.globalenv prog. Let tge := Genv.globalenv tprog. Lemma symbols_preserved: - forall id, Genv.find_symbol tge id = Genv.find_symbol ge id. -Proof. - intros. unfold ge, tge. - apply Genv.find_symbol_transf_partial with transf_fundef. - exact TRANSF. -Qed. + forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. +Proof (Genv.find_symbol_match TRANSF). -Lemma public_preserved: - forall id, Genv.public_symbol tge id = Genv.public_symbol ge id. -Proof. - intros. unfold ge, tge. - apply Genv.public_symbol_transf_partial with transf_fundef. - exact TRANSF. -Qed. +Lemma senv_preserved: + Senv.equiv ge tge. +Proof (Genv.senv_match TRANSF). Lemma functions_translated: forall b f, 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). + exists tf, + Genv.find_funct_ptr tge b = Some tf /\ transf_fundef f = OK tf. +Proof (Genv.find_funct_ptr_transf_partial TRANSF). Lemma functions_transl: forall fb f tf, @@ -73,14 +60,6 @@ Proof. monadInv B. rewrite H0 in EQ; inv EQ; auto. Qed. -Lemma varinfo_preserved: - forall b, Genv.find_var_info tge b = Genv.find_var_info ge b. -Proof. - intros. unfold ge, tge. - apply Genv.find_var_info_transf_partial with transf_fundef. - exact TRANSF. -Qed. - (** * Properties of control flow *) Lemma transf_function_no_overflow: @@ -682,8 +661,7 @@ Opaque loadind. eapply find_instr_tail; eauto. erewrite <- sp_val by eauto. eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. - eapply external_call_symbols_preserved; eauto. - exact symbols_preserved. exact public_preserved. exact varinfo_preserved. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. eauto. econstructor; eauto. instantiate (2 := tf); instantiate (1 := x). @@ -866,8 +844,7 @@ Transparent destroyed_at_function_entry. intros [res' [m2' [P [Q [R S]]]]]. left; econstructor; split. apply plus_one. eapply exec_step_external; eauto. - eapply external_call_symbols_preserved'; eauto. - exact symbols_preserved. exact public_preserved. exact varinfo_preserved. + eapply external_call_symbols_preserved'; eauto. apply senv_preserved. econstructor; eauto. unfold loc_external_result. apply agree_set_other; auto. apply agree_set_mregs; auto. @@ -885,7 +862,7 @@ Proof. intros. inversion H. unfold ge0 in *. econstructor; split. econstructor. - eapply Genv.init_mem_transf_partial; eauto. + eapply (Genv.init_mem_transf_partial TRANSF); eauto. replace (Genv.symbol_address (Genv.globalenv tprog) (prog_main tprog) Int.zero) with (Vptr fb Int.zero). econstructor; eauto. @@ -893,7 +870,7 @@ Proof. apply Mem.extends_refl. split. auto. simpl. unfold Vzero; congruence. intros. rewrite Regmap.gi. auto. unfold Genv.symbol_address. - rewrite (transform_partial_program_main _ _ TRANSF). + rewrite (match_program_main TRANSF). rewrite symbols_preserved. unfold ge; rewrite H1. auto. Qed. @@ -911,7 +888,7 @@ Theorem transf_program_correct: forward_simulation (Mach.semantics return_address_offset prog) (Asm.semantics tprog). Proof. eapply forward_simulation_star with (measure := measure). - eexact public_preserved. + apply senv_preserved. eexact transf_initial_states. eexact transf_final_states. exact step_simulation. diff --git a/lib/Coqlib.v b/lib/Coqlib.v index 4ec19fa9..fc4a59f6 100644 --- a/lib/Coqlib.v +++ b/lib/Coqlib.v @@ -643,6 +643,12 @@ Definition option_eq (A: Type) (eqA: forall (x y: A), {x=y} + {x<>y}): Proof. decide equality. Defined. Global Opaque option_eq. +(** Lifting a relation to an option type. *) + +Inductive option_rel (A B: Type) (R: A -> B -> Prop) : option A -> option B -> Prop := + | option_rel_none: option_rel R None None + | option_rel_some: forall x y, R x y -> option_rel R (Some x) (Some y). + (** Mapping a function over an option type. *) Definition option_map (A B: Type) (f: A -> B) (x: option A) : option B := @@ -1184,6 +1190,24 @@ Proof. induction 1; simpl; congruence. Qed. +Lemma list_forall2_in_left: + forall x1 l1 l2, + list_forall2 l1 l2 -> In x1 l1 -> exists x2, In x2 l2 /\ P x1 x2. +Proof. + induction 1; simpl; intros. contradiction. destruct H1. + subst; exists b1; auto. + exploit IHlist_forall2; eauto. intros (x2 & U & V); exists x2; auto. +Qed. + +Lemma list_forall2_in_right: + forall x2 l1 l2, + list_forall2 l1 l2 -> In x2 l2 -> exists x1, In x1 l1 /\ P x1 x2. +Proof. + induction 1; simpl; intros. contradiction. destruct H1. + subst; exists a1; auto. + exploit IHlist_forall2; eauto. intros (x1 & U & V); exists x1; auto. +Qed. + End FORALL2. Lemma list_forall2_imply: @@ -1376,3 +1400,35 @@ Qed. End LEX_ORDER. +(** * Nonempty lists *) + +Inductive nlist (A: Type) : Type := + | nbase: A -> nlist A + | ncons: A -> nlist A -> nlist A. + +Definition nfirst {A: Type} (l: nlist A) := + match l with nbase a => a | ncons a l' => a end. + +Fixpoint nlast {A: Type} (l: nlist A) := + match l with nbase a => a | ncons a l' => nlast l' end. + +Fixpoint nIn {A: Type} (x: A) (l: nlist A) : Prop := + match l with + | nbase a => a = x + | ncons a l => a = x \/ nIn x l + end. + +Inductive nlist_forall2 {A B: Type} (R: A -> B -> Prop) : nlist A -> nlist B -> Prop := + | nbase_forall2: forall a b, R a b -> nlist_forall2 R (nbase a) (nbase b) + | ncons_forall2: forall a l b m, R a b -> nlist_forall2 R l m -> nlist_forall2 R (ncons a l) (ncons b m). + +Lemma nlist_forall2_imply: + forall (A B: Type) (P1: A -> B -> Prop) (l1: nlist A) (l2: nlist B), + nlist_forall2 P1 l1 l2 -> + forall (P2: A -> B -> Prop), + (forall v1 v2, nIn v1 l1 -> nIn v2 l2 -> P1 v1 v2 -> P2 v1 v2) -> + nlist_forall2 P2 l1 l2. +Proof. + induction 1; simpl; intros; constructor; auto. +Qed. + @@ -789,46 +789,42 @@ Module PTree <: TREE. intros. apply (H (xO i0)). Qed. - Theorem elements_canonical_order: + 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) -> + (forall i, option_rel R (get i m) (get i n)) -> 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, + intros until n. unfold elements. generalize 1%positive. revert m n. + induction m; intros. + - simpl. rewrite xelements_empty. constructor. + intros. specialize (H i). rewrite gempty in H. inv H; auto. + - destruct n as [ | n1 o' n2 ]. + + rewrite (xelements_empty (Node m1 o m2)). simpl; constructor. + intros. specialize (H i). rewrite gempty in H. inv H; auto. + + rewrite ! xelements_node. repeat apply list_forall2_app. + apply IHm1. intros. apply (H (xO i)). + generalize (H xH); simpl; intros OR; inv OR. + constructor. + constructor. auto. constructor. + apply IHm2. intros. apply (H (xI i)). + 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)) - (xelements m j nil) (xelements n j nil)). - { - induction m; intros. - - rewrite xelements_leaf. rewrite xelements_empty. constructor. - intros. destruct (get i n) eqn:E; auto. exploit H0; eauto. - intros [x [P Q]]. rewrite gleaf in P; congruence. - - destruct n as [ | n1 o' n2 ]. - + rewrite xelements_leaf, xelements_empty. constructor. - intros. destruct (get i (Node m1 o m2)) eqn:E; auto. exploit H; eauto. - intros [x [P Q]]. rewrite gleaf in P; congruence. - + rewrite ! xelements_node. apply list_forall2_app. - apply IHm1. - intros. apply (H (xO i) x); auto. - intros. apply (H0 (xO i) y); auto. - apply list_forall2_app. - destruct o, o'. - destruct (H xH a) as [x [P Q]]. auto. simpl in P. inv P. - constructor. auto. constructor. - destruct (H xH a) as [x [P Q]]. auto. simpl in P. inv P. - destruct (H0 xH b) as [x [P Q]]. auto. simpl in P. inv P. - constructor. - apply IHm2. - intros. apply (H (xI i) x); auto. - intros. apply (H0 (xI i) y); auto. - } - intros. apply H with (j := xH); auto. + (elements m) (elements n). + Proof. + intros. apply elements_canonical_order'. + intros. destruct (get i m) as [x|] eqn:GM. + exploit H; eauto. intros (y & P & Q). rewrite P; constructor; auto. + destruct (get i n) as [y|] eqn:GN. + exploit H0; eauto. intros (x & P & Q). congruence. + constructor. Qed. Theorem elements_extensional: @@ -837,9 +833,8 @@ Module PTree <: TREE. 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. + exploit (@elements_canonical_order' _ _ (fun (x y: A) => x = y) m n). + intros. rewrite H. destruct (get i n); constructor; auto. induction 1. auto. destruct a1 as [a2 a3]; destruct b1 as [b2 b3]; simpl in *. destruct H0. congruence. Qed. @@ -1542,6 +1537,110 @@ Instance Equal_EqDec : EqDec (T.t A) Equal := Equal_dec. End EXTENSIONAL_EQUALITY. +(** Creating a tree from a list of (key, value) pairs. *) + +Section OF_LIST. + +Variable A: Type. + +Let f := fun (m: T.t A) (k_v: T.elt * A) => T.set (fst k_v) (snd k_v) m. + +Definition of_list (l: list (T.elt * A)) : T.t A := + List.fold_left f l (T.empty _). + +Lemma in_of_list: + forall l k v, T.get k (of_list l) = Some v -> In (k, v) l. +Proof. + assert (REC: forall k v l m, + T.get k (fold_left f l m) = Some v -> In (k, v) l \/ T.get k m = Some v). + { induction l as [ | [k1 v1] l]; simpl; intros. + - tauto. + - apply IHl in H. unfold f in H. simpl in H. rewrite T.gsspec in H. + destruct H; auto. + destruct (T.elt_eq k k1). inv H. auto. auto. + } + intros. apply REC in H. rewrite T.gempty in H. intuition congruence. +Qed. + +Lemma of_list_dom: + forall l k, In k (map fst l) -> exists v, T.get k (of_list l) = Some v. +Proof. + assert (REC: forall k l m, + In k (map fst l) \/ (exists v, T.get k m = Some v) -> + exists v, T.get k (fold_left f l m) = Some v). + { induction l as [ | [k1 v1] l]; simpl; intros. + - tauto. + - apply IHl. unfold f; rewrite T.gsspec. simpl. destruct (T.elt_eq k k1). + right; econstructor; eauto. + intuition congruence. + } + intros. apply REC. auto. +Qed. + +Remark of_list_unchanged: + forall k l m, ~In k (map fst l) -> T.get k (List.fold_left f l m) = T.get k m. +Proof. + induction l as [ | [k1 v1] l]; simpl; intros. +- auto. +- rewrite IHl by tauto. unfold f; apply T.gso; intuition auto. +Qed. + +Lemma of_list_unique: + forall k v l1 l2, + ~In k (map fst l2) -> T.get k (of_list (l1 ++ (k, v) :: l2)) = Some v. +Proof. + intros. unfold of_list. rewrite fold_left_app. simpl. + rewrite of_list_unchanged by auto. unfold f; apply T.gss. +Qed. + +Lemma of_list_norepet: + forall l k v, list_norepet (map fst l) -> In (k, v) l -> T.get k (of_list l) = Some v. +Proof. + assert (REC: forall k v l m, + list_norepet (map fst l) -> + In (k, v) l -> + T.get k (fold_left f l m) = Some v). + { induction l as [ | [k1 v1] l]; simpl; intros. + contradiction. + inv H. destruct H0. + inv H. rewrite of_list_unchanged by auto. apply T.gss. + apply IHl; auto. + } + intros; apply REC; auto. +Qed. + +Lemma of_list_elements: + forall m k, T.get k (of_list (T.elements m)) = T.get k m. +Proof. + intros. destruct (T.get k m) as [v|] eqn:M. +- apply of_list_norepet. apply T.elements_keys_norepet. apply T.elements_correct; auto. +- destruct (T.get k (of_list (T.elements m))) as [v|] eqn:M'; auto. + apply in_of_list in M'. apply T.elements_complete in M'. congruence. +Qed. + +End OF_LIST. + +Lemma of_list_related: + forall (A B: Type) (R: A -> B -> Prop) k l1 l2, + list_forall2 (fun ka kb => fst ka = fst kb /\ R (snd ka) (snd kb)) l1 l2 -> + option_rel R (T.get k (of_list l1)) (T.get k (of_list l2)). +Proof. + intros until k. unfold of_list. + set (R' := fun ka kb => fst ka = fst kb /\ R (snd ka) (snd kb)). + set (fa := fun (m : T.t A) (k_v : T.elt * A) => T.set (fst k_v) (snd k_v) m). + set (fb := fun (m : T.t B) (k_v : T.elt * B) => T.set (fst k_v) (snd k_v) m). + assert (REC: forall l1 l2, list_forall2 R' l1 l2 -> + forall m1 m2, option_rel R (T.get k m1) (T.get k m2) -> + option_rel R (T.get k (fold_left fa l1 m1)) (T.get k (fold_left fb l2 m2))). + { induction 1; intros; simpl. + - auto. + - apply IHlist_forall2. unfold fa, fb. rewrite ! T.gsspec. + destruct H as [E F]. rewrite E. destruct (T.elt_eq k (fst b1)). + constructor; auto. + auto. } + intros. apply REC; auto. rewrite ! T.gempty. constructor. +Qed. + End Tree_Properties. Module PTree_Properties := Tree_Properties(PTree). diff --git a/powerpc/Asmexpand.ml b/powerpc/Asmexpand.ml index 7af27d20..dad19a6d 100644 --- a/powerpc/Asmexpand.ml +++ b/powerpc/Asmexpand.ml @@ -792,4 +792,4 @@ let expand_fundef id = function Errors.OK (External ef) let expand_program (p: Asm.program) : Asm.program Errors.res = - AST.transform_partial_ident_program expand_fundef p + AST.transform_partial_program2 expand_fundef (fun id v -> Errors.OK v) p diff --git a/powerpc/Asmgenproof.v b/powerpc/Asmgenproof.v index 4e59b297..31db77ca 100644 --- a/powerpc/Asmgenproof.v +++ b/powerpc/Asmgenproof.v @@ -12,75 +12,52 @@ (** Correctness proof for PPC generation: main proof. *) -Require Import Coqlib. -Require Import Maps. -Require Import Errors. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import Memory. -Require Import Events. -Require Import Globalenvs. -Require Import Smallstep. -Require Import Op. -Require Import Locations. -Require Import Conventions. -Require Import Mach. -Require Import Asm. -Require Import Asmgen. -Require Import Asmgenproof0. -Require Import Asmgenproof1. +Require Import Coqlib Errors. +Require Import Integers Floats AST Linking. +Require Import Values Memory Events Globalenvs Smallstep. +Require Import Op Locations Mach Conventions Asm. +Require Import Asmgen Asmgenproof0 Asmgenproof1. + +Definition match_prog (p: Mach.program) (tp: Asm.program) := + match_program (fun _ f tf => transf_fundef f = OK tf) eq p tp. + +Lemma transf_program_match: + forall p tp, transf_program p = OK tp -> match_prog p tp. +Proof. + intros. eapply match_transform_partial_program; eauto. +Qed. Section PRESERVATION. Variable prog: Mach.program. Variable tprog: Asm.program. -Hypothesis TRANSF: transf_program prog = Errors.OK tprog. - +Hypothesis TRANSF: match_prog prog tprog. Let ge := Genv.globalenv prog. Let tge := Genv.globalenv tprog. Lemma symbols_preserved: - forall id, Genv.find_symbol tge id = Genv.find_symbol ge id. -Proof. - intros. unfold ge, tge. - apply Genv.find_symbol_transf_partial with transf_fundef. - exact TRANSF. -Qed. + forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. +Proof (Genv.find_symbol_match TRANSF). -Lemma public_preserved: - forall id, Genv.public_symbol tge id = Genv.public_symbol ge id. -Proof. - intros. unfold ge, tge. - apply Genv.public_symbol_transf_partial with transf_fundef. - exact TRANSF. -Qed. - -Lemma varinfo_preserved: - forall b, Genv.find_var_info tge b = Genv.find_var_info ge b. -Proof. - intros. unfold ge, tge. - apply Genv.find_var_info_transf_partial with transf_fundef. - exact TRANSF. -Qed. +Lemma senv_preserved: + Senv.equiv ge tge. +Proof (Genv.senv_match TRANSF). Lemma functions_translated: forall b f, 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). + exists tf, + Genv.find_funct_ptr tge b = Some tf /\ transf_fundef f = OK tf. +Proof (Genv.find_funct_ptr_transf_partial TRANSF). Lemma functions_transl: - forall f b tf, - Genv.find_funct_ptr ge b = Some (Internal f) -> + forall fb f tf, + Genv.find_funct_ptr ge fb = Some (Internal f) -> transf_function f = OK tf -> - Genv.find_funct_ptr tge b = Some (Internal tf). + Genv.find_funct_ptr tge fb = Some (Internal tf). Proof. - intros. - destruct (functions_translated _ _ H) as [tf' [A B]]. - rewrite A. monadInv B. f_equal. congruence. + intros. exploit functions_translated; eauto. intros [tf' [A B]]. + monadInv B. rewrite H0 in EQ; inv EQ; auto. Qed. (** * Properties of control flow *) @@ -765,8 +742,7 @@ Hint Resolve agree_nextinstr agree_set_other: asmgen. eapply find_instr_tail; eauto. erewrite <- sp_val by eauto. eapply eval_builtin_args_preserved with (ge1 := ge); eauto. exact symbols_preserved. - eapply external_call_symbols_preserved; eauto. - exact symbols_preserved. exact public_preserved. exact varinfo_preserved. + eapply external_call_symbols_preserved; eauto. apply senv_preserved. eauto. econstructor; eauto. instantiate (2 := tf); instantiate (1 := x). @@ -954,8 +930,7 @@ Local Transparent destroyed_by_jumptable. intros [res' [m2' [P [Q [R S]]]]]. left; econstructor; split. apply plus_one. eapply exec_step_external; eauto. - eapply external_call_symbols_preserved'; eauto. - exact symbols_preserved. exact public_preserved. exact varinfo_preserved. + eapply external_call_symbols_preserved'; eauto. apply senv_preserved. econstructor; eauto. unfold loc_external_result. apply agree_set_other; auto. apply agree_set_mregs; auto. @@ -974,7 +949,7 @@ Proof. intros. inversion H. unfold ge0 in *. econstructor; split. econstructor. - eapply Genv.init_mem_transf_partial; eauto. + eapply (Genv.init_mem_transf_partial TRANSF); eauto. replace (Genv.symbol_address (Genv.globalenv tprog) (prog_main tprog) Int.zero) with (Vptr fb Int.zero). econstructor; eauto. @@ -982,7 +957,7 @@ Proof. apply Mem.extends_refl. split. auto. simpl. unfold Vzero; congruence. intros. rewrite Regmap.gi. auto. unfold Genv.symbol_address. - rewrite (transform_partial_program_main _ _ TRANSF). + rewrite (match_program_main TRANSF). rewrite symbols_preserved. unfold ge; rewrite H1. auto. Qed. @@ -1000,7 +975,7 @@ Theorem transf_program_correct: forward_simulation (Mach.semantics return_address_offset prog) (Asm.semantics tprog). Proof. eapply forward_simulation_star with (measure := measure). - eexact public_preserved. + apply senv_preserved. eexact transf_initial_states. eexact transf_final_states. exact step_simulation. |