From 355b4abcee015c3fae9ac5653c25259e104a886c Mon Sep 17 00:00:00 2001 From: xleroy Date: Sat, 4 Aug 2007 07:27:50 +0000 Subject: Fusion des modifications faites sur les branches "tailcalls" et "smallstep". En particulier: - Semantiques small-step depuis RTL jusqu'a PPC - Cminor independant du processeur - Ajout passes Selection et Reload - Ajout des langages intermediaires CminorSel et LTLin correspondants - Ajout des tailcalls depuis Cminor jusqu'a PPC git-svn-id: https://yquem.inria.fr/compcert/svn/compcert/trunk@384 fca1b0fc-160b-0410-b1d3-a4f43f01ea2e --- .depend | 100 +- Makefile | 40 +- backend/Allocation.v | 382 +- backend/Allocproof.v | 1971 +++------- backend/Alloctyping.v | 516 +-- backend/Bounds.v | 357 ++ backend/CSE.v | 8 +- backend/CSEproof.v | 349 +- backend/Cmconstr.v | 1011 ----- backend/Cmconstrproof.v | 1207 ------ backend/Cminor.v | 333 +- backend/CminorSel.v | 296 ++ backend/Coloring.v | 2 + backend/Coloringproof.v | 1 + backend/Constprop.v | 58 +- backend/Constpropproof.v | 609 +-- backend/Conventions.v | 281 +- backend/LTL.v | 504 ++- backend/LTLin.v | 255 ++ backend/LTLintyping.v | 104 + backend/LTLtyping.v | 160 +- backend/Linear.v | 243 +- backend/Linearize.v | 144 +- backend/Linearizeproof.v | 865 ++--- backend/Linearizetyping.v | 345 +- backend/Lineartyping.v | 208 +- backend/Locations.v | 2 +- backend/Mach.v | 256 +- backend/Machabstr.v | 512 +-- backend/Machabstr2concr.v | 947 +++++ backend/Machabstr2mach.v | 1185 ------ backend/Machconcr.v | 250 ++ backend/Machtyping.v | 312 +- backend/Op.v | 257 +- backend/PPC.v | 96 +- backend/PPCgen.v | 30 +- backend/PPCgenproof.v | 1315 ++++--- backend/PPCgenproof1.v | 58 +- backend/PPCgenretaddr.v | 176 + backend/Parallelmove.v | 85 +- backend/RTL.v | 293 +- backend/RTLbigstep.v | 400 ++ backend/RTLgen.v | 120 +- backend/RTLgenproof.v | 1584 ++++---- backend/RTLgenproof1.v | 1367 ------- backend/RTLgenspec.v | 1455 +++++++ backend/RTLtyping.v | 356 +- backend/Registers.v | 7 +- backend/Reload.v | 211 ++ backend/Reloadproof.v | 1230 ++++++ backend/Reloadtyping.v | 309 ++ backend/Selection.v | 1103 ++++++ backend/Selectionproof.v | 1240 ++++++ backend/Stacking.v | 88 +- backend/Stackingproof.v | 1585 ++++---- backend/Stackingtyping.v | 121 +- backend/Tunneling.v | 56 +- backend/Tunnelingproof.v | 472 +-- backend/Tunnelingtyping.v | 61 +- caml/CMlexer.mll | 3 + caml/CMparser.mly | 194 +- caml/CMtypecheck.ml | 239 +- caml/Camlcoq.ml | 45 +- caml/Coloringaux.ml | 18 +- caml/Main2.ml | 8 +- caml/PrintPPC.ml | 6 +- caml/RTLgenaux.ml | 46 +- caml/RTLtypingaux.ml | 21 +- cfrontend/Cminorgen.v | 221 +- cfrontend/Cminorgenproof.v | 694 ++-- cfrontend/Csem.v | 3 +- cfrontend/Csharpminor.v | 150 +- cfrontend/Cshmgen.v | 276 +- cfrontend/Cshmgenproof1.v | 134 +- cfrontend/Cshmgenproof2.v | 103 +- cfrontend/Cshmgenproof3.v | 179 +- cfrontend/Csyntax.v | 11 +- common/AST.v | 219 +- common/Errors.v | 167 + common/Events.v | 117 +- common/Globalenvs.v | 690 +++- common/Main.v | 352 +- common/Mem.v | 3281 ++++++++-------- common/Smallstep.v | 460 +++ common/Switch.v | 165 + common/Values.v | 64 + coq | 2 +- doc/backend.html | 250 -- doc/coqdoc.css | 62 + doc/index.html | 8561 ++---------------------------------------- doc/removeproofs | 2 +- doc/style.css | 4 +- extraction/.depend | 370 +- extraction/Makefile | 26 +- extraction/convert | 1 + extraction/extraction.v | 1 + lib/Coqlib.v | 40 + lib/Iteration.v | 64 +- lib/Parmov.v | 505 +-- runtime/Makefile | 13 + runtime/calloc.c | 13 + runtime/stdio.c | 152 + runtime/stdio.h | 67 + test/c/Makefile | 9 +- test/c/knucleotide.c | 4 - test/c/mandelbrot.c | 4 - test/cminor/Makefile | 6 + test/cminor/sha1.cmp | 2 +- test/cminor/switchtbl.cm | 16 + test/harness/mainlists.c | 5 - test/harness/mainswitchtbl.c | 11 + 111 files changed, 20656 insertions(+), 25288 deletions(-) create mode 100644 backend/Bounds.v delete mode 100644 backend/Cmconstr.v delete mode 100644 backend/Cmconstrproof.v create mode 100644 backend/CminorSel.v create mode 100644 backend/LTLin.v create mode 100644 backend/LTLintyping.v create mode 100644 backend/Machabstr2concr.v delete mode 100644 backend/Machabstr2mach.v create mode 100644 backend/Machconcr.v create mode 100644 backend/PPCgenretaddr.v create mode 100644 backend/RTLbigstep.v delete mode 100644 backend/RTLgenproof1.v create mode 100644 backend/RTLgenspec.v create mode 100644 backend/Reload.v create mode 100644 backend/Reloadproof.v create mode 100644 backend/Reloadtyping.v create mode 100644 backend/Selection.v create mode 100644 backend/Selectionproof.v create mode 100644 common/Errors.v create mode 100644 common/Smallstep.v create mode 100644 common/Switch.v delete mode 100644 doc/backend.html create mode 100644 doc/coqdoc.css create mode 100644 runtime/Makefile create mode 100644 runtime/calloc.c create mode 100644 runtime/stdio.c create mode 100644 runtime/stdio.h create mode 100644 test/cminor/switchtbl.cm create mode 100644 test/harness/mainswitchtbl.c diff --git a/.depend b/.depend index 5262e32b..d8ec3bd6 100644 --- a/.depend +++ b/.depend @@ -6,64 +6,76 @@ lib/Iteration.vo: lib/Iteration.v lib/Coqlib.vo lib/Integers.vo: lib/Integers.v lib/Coqlib.vo lib/Floats.vo: lib/Floats.v lib/Coqlib.vo lib/Integers.vo lib/Parmov.vo: lib/Parmov.v lib/Coqlib.vo -common/AST.vo: common/AST.v lib/Coqlib.vo lib/Integers.vo lib/Floats.vo +common/Errors.vo: common/Errors.v lib/Coqlib.vo +common/AST.vo: common/AST.v lib/Coqlib.vo common/Errors.vo lib/Integers.vo lib/Floats.vo common/Events.vo: common/Events.v lib/Coqlib.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Mem.vo -common/Globalenvs.vo: common/Globalenvs.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Mem.vo +common/Globalenvs.vo: common/Globalenvs.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Mem.vo common/Mem.vo: common/Mem.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Values.vo: common/Values.v lib/Coqlib.vo common/AST.vo lib/Integers.vo lib/Floats.vo -common/Main.vo: common/Main.v lib/Coqlib.vo lib/Maps.vo common/AST.vo common/Values.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Csharpminor.vo backend/Cminor.vo backend/RTL.vo backend/LTL.vo backend/Linear.vo backend/Mach.vo backend/PPC.vo cfrontend/Cshmgen.vo cfrontend/Cminorgen.vo backend/RTLgen.vo backend/Constprop.vo backend/CSE.vo backend/Allocation.vo backend/Tunneling.vo backend/Linearize.vo backend/Stacking.vo backend/PPCgen.vo cfrontend/Ctyping.vo backend/RTLtyping.vo backend/LTLtyping.vo backend/Lineartyping.vo backend/Machtyping.vo cfrontend/Cshmgenproof3.vo cfrontend/Cminorgenproof.vo backend/RTLgenproof.vo backend/Constpropproof.vo backend/CSEproof.vo backend/Allocproof.vo backend/Alloctyping.vo backend/Tunnelingproof.vo backend/Tunnelingtyping.vo backend/Linearizeproof.vo backend/Linearizetyping.vo backend/Stackingproof.vo backend/Stackingtyping.vo backend/Machabstr2mach.vo backend/PPCgenproof.vo +common/Smallstep.vo: common/Smallstep.v lib/Coqlib.vo common/AST.vo common/Events.vo common/Globalenvs.vo lib/Integers.vo +common/Switch.vo: common/Switch.v lib/Coqlib.vo lib/Integers.vo +common/Main.vo: common/Main.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo common/AST.vo common/Values.vo common/Smallstep.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Csharpminor.vo backend/Cminor.vo backend/CminorSel.vo backend/RTL.vo backend/LTL.vo backend/LTLin.vo backend/Linear.vo backend/Mach.vo backend/PPC.vo cfrontend/Cshmgen.vo cfrontend/Cminorgen.vo backend/Selection.vo backend/RTLgen.vo backend/Constprop.vo backend/CSE.vo backend/Allocation.vo backend/Tunneling.vo backend/Linearize.vo backend/Reload.vo backend/Stacking.vo backend/PPCgen.vo cfrontend/Ctyping.vo backend/RTLtyping.vo backend/LTLtyping.vo backend/LTLintyping.vo backend/Lineartyping.vo backend/Machtyping.vo cfrontend/Cshmgenproof3.vo cfrontend/Cminorgenproof.vo backend/Selectionproof.vo backend/RTLgenproof.vo backend/Constpropproof.vo backend/CSEproof.vo backend/Allocproof.vo backend/Alloctyping.vo backend/Tunnelingproof.vo backend/Tunnelingtyping.vo backend/Linearizeproof.vo backend/Linearizetyping.vo backend/Reloadproof.vo backend/Reloadtyping.vo backend/Stackingproof.vo backend/Stackingtyping.vo backend/Machabstr2concr.vo backend/PPCgenproof.vo +backend/Cminor.vo: backend/Cminor.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Events.vo common/Values.vo common/Mem.vo common/Globalenvs.vo common/Switch.vo backend/Op.vo: backend/Op.v lib/Coqlib.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Mem.vo common/Globalenvs.vo -backend/Cminor.vo: backend/Cminor.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Events.vo common/Values.vo common/Mem.vo backend/Op.vo common/Globalenvs.vo -backend/Cmconstr.vo: backend/Cmconstr.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Mem.vo backend/Op.vo common/Globalenvs.vo backend/Cminor.vo -backend/Cmconstrproof.vo: backend/Cmconstrproof.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Mem.vo common/Events.vo backend/Op.vo common/Globalenvs.vo backend/Cminor.vo backend/Cmconstr.vo +backend/CminorSel.vo: backend/CminorSel.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Events.vo common/Values.vo common/Mem.vo backend/Cminor.vo backend/Op.vo common/Globalenvs.vo common/Switch.vo +backend/Selection.vo: backend/Selection.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Mem.vo common/Globalenvs.vo backend/Cminor.vo backend/Op.vo backend/CminorSel.vo +backend/Selectionproof.vo: backend/Selectionproof.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Mem.vo common/Events.vo common/Globalenvs.vo backend/Cminor.vo backend/Op.vo backend/CminorSel.vo backend/Selection.vo backend/Registers.vo: backend/Registers.v lib/Coqlib.vo common/AST.vo lib/Maps.vo lib/Ordered.vo -backend/RTL.vo: backend/RTL.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Events.vo common/Mem.vo common/Globalenvs.vo backend/Op.vo backend/Registers.vo -backend/RTLgen.vo: backend/RTLgen.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo backend/Op.vo backend/Registers.vo backend/Cminor.vo backend/RTL.vo -backend/RTLgenproof1.vo: backend/RTLgenproof1.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Events.vo common/Mem.vo common/Globalenvs.vo backend/Op.vo backend/Registers.vo backend/Cminor.vo backend/RTL.vo backend/RTLgen.vo -backend/RTLgenproof.vo: backend/RTLgenproof.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Mem.vo common/Events.vo common/Globalenvs.vo backend/Op.vo backend/Registers.vo backend/Cminor.vo backend/RTL.vo backend/RTLgen.vo backend/RTLgenproof1.vo -backend/RTLtyping.vo: backend/RTLtyping.v lib/Coqlib.vo lib/Maps.vo common/AST.vo backend/Op.vo backend/Registers.vo backend/RTL.vo backend/Conventions.vo common/Globalenvs.vo common/Values.vo common/Mem.vo lib/Integers.vo common/Events.vo -backend/Kildall.vo: backend/Kildall.v lib/Coqlib.vo lib/Iteration.vo lib/Maps.vo lib/Lattice.vo +backend/RTL.vo: backend/RTL.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Events.vo common/Mem.vo common/Globalenvs.vo common/Smallstep.vo backend/Op.vo backend/Registers.vo +backend/RTLgen.vo: backend/RTLgen.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Switch.vo backend/Op.vo backend/Registers.vo backend/CminorSel.vo backend/RTL.vo +backend/RTLgenspec.vo: backend/RTLgenspec.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Events.vo common/Mem.vo common/Globalenvs.vo common/Switch.vo backend/Op.vo backend/Registers.vo backend/CminorSel.vo backend/RTL.vo backend/RTLgen.vo +backend/RTLgenproof.vo: backend/RTLgenproof.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Mem.vo common/Events.vo common/Smallstep.vo common/Globalenvs.vo common/Switch.vo backend/Registers.vo backend/Cminor.vo backend/Op.vo backend/CminorSel.vo backend/RTL.vo backend/RTLgen.vo backend/RTLgenspec.vo common/Errors.vo +backend/RTLtyping.vo: backend/RTLtyping.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo common/AST.vo backend/Op.vo backend/Registers.vo backend/RTL.vo backend/Conventions.vo common/Globalenvs.vo common/Values.vo common/Mem.vo lib/Integers.vo common/Events.vo common/Smallstep.vo +backend/Kildall.vo: backend/Kildall.v lib/Coqlib.vo lib/Iteration.vo lib/Maps.vo lib/Lattice.vo lib/Ordered.vo backend/Constprop.vo: backend/Constprop.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Globalenvs.vo backend/Op.vo backend/Registers.vo backend/RTL.vo lib/Lattice.vo backend/Kildall.vo -backend/Constpropproof.vo: backend/Constpropproof.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Events.vo common/Mem.vo common/Globalenvs.vo backend/Op.vo backend/Registers.vo backend/RTL.vo lib/Lattice.vo backend/Kildall.vo backend/Constprop.vo +backend/Constpropproof.vo: backend/Constpropproof.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Events.vo common/Mem.vo common/Globalenvs.vo common/Smallstep.vo backend/Op.vo backend/Registers.vo backend/RTL.vo lib/Lattice.vo backend/Kildall.vo backend/Constprop.vo backend/CSE.vo: backend/CSE.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Mem.vo common/Globalenvs.vo backend/Op.vo backend/Registers.vo backend/RTL.vo backend/Kildall.vo -backend/CSEproof.vo: backend/CSEproof.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Mem.vo common/Events.vo common/Globalenvs.vo backend/Op.vo backend/Registers.vo backend/RTL.vo backend/Kildall.vo backend/CSE.vo +backend/CSEproof.vo: backend/CSEproof.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Mem.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo backend/Op.vo backend/Registers.vo backend/RTL.vo backend/Kildall.vo backend/CSE.vo backend/Locations.vo: backend/Locations.v lib/Coqlib.vo lib/Maps.vo common/AST.vo common/Values.vo backend/Conventions.vo: backend/Conventions.v lib/Coqlib.vo common/AST.vo backend/Locations.vo -backend/LTL.vo: backend/LTL.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Events.vo common/Mem.vo common/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/Conventions.vo +backend/LTL.vo: backend/LTL.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Events.vo common/Mem.vo common/Globalenvs.vo common/Smallstep.vo backend/Op.vo backend/Locations.vo backend/Conventions.vo backend/LTLtyping.vo: backend/LTLtyping.v lib/Coqlib.vo lib/Maps.vo common/AST.vo backend/Op.vo backend/RTL.vo backend/Locations.vo backend/LTL.vo backend/Conventions.vo backend/InterfGraph.vo: backend/InterfGraph.v lib/Coqlib.vo lib/Maps.vo lib/Ordered.vo backend/Registers.vo backend/Locations.vo backend/Coloring.vo: backend/Coloring.v lib/Coqlib.vo lib/Maps.vo common/AST.vo backend/Op.vo backend/Registers.vo backend/RTL.vo backend/RTLtyping.vo backend/Locations.vo backend/Conventions.vo backend/InterfGraph.vo backend/Coloringproof.vo: backend/Coloringproof.v lib/Coqlib.vo lib/Maps.vo common/AST.vo backend/Op.vo backend/Registers.vo backend/RTL.vo backend/RTLtyping.vo backend/Locations.vo backend/Conventions.vo backend/InterfGraph.vo backend/Coloring.vo -backend/Parallelmove.vo: backend/Parallelmove.v lib/Coqlib.vo lib/Parmov.vo common/Values.vo common/Events.vo common/AST.vo backend/Locations.vo backend/Conventions.vo -backend/Allocation.vo: backend/Allocation.v lib/Coqlib.vo lib/Maps.vo lib/Lattice.vo common/AST.vo lib/Integers.vo common/Values.vo common/Globalenvs.vo backend/Op.vo backend/Registers.vo backend/RTL.vo backend/RTLtyping.vo backend/Kildall.vo backend/Locations.vo backend/Conventions.vo backend/Coloring.vo backend/Parallelmove.vo backend/LTL.vo -backend/Allocproof.vo: backend/Allocproof.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Mem.vo common/Events.vo common/Globalenvs.vo backend/Op.vo backend/Registers.vo backend/RTL.vo backend/RTLtyping.vo backend/Locations.vo backend/Conventions.vo backend/Coloring.vo backend/Coloringproof.vo backend/Parallelmove.vo backend/Allocation.vo backend/LTL.vo -backend/Alloctyping.vo: backend/Alloctyping.v lib/Coqlib.vo lib/Maps.vo common/AST.vo backend/Op.vo backend/Registers.vo backend/RTL.vo backend/Locations.vo backend/LTL.vo backend/Coloring.vo backend/Coloringproof.vo backend/Allocation.vo backend/Allocproof.vo backend/RTLtyping.vo backend/LTLtyping.vo backend/Conventions.vo backend/Parallelmove.vo +backend/Allocation.vo: backend/Allocation.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo lib/Lattice.vo common/AST.vo lib/Integers.vo common/Values.vo common/Globalenvs.vo backend/Op.vo backend/Registers.vo backend/RTL.vo backend/RTLtyping.vo backend/Kildall.vo backend/Locations.vo backend/Conventions.vo backend/Coloring.vo backend/LTL.vo +backend/Allocproof.vo: backend/Allocproof.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Mem.vo common/Events.vo common/Smallstep.vo common/Globalenvs.vo backend/Op.vo backend/Registers.vo backend/RTL.vo backend/RTLtyping.vo backend/Locations.vo backend/Conventions.vo backend/Coloring.vo backend/Coloringproof.vo backend/Allocation.vo backend/LTL.vo +backend/Alloctyping.vo: backend/Alloctyping.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo common/AST.vo backend/Op.vo backend/Registers.vo backend/RTL.vo backend/Locations.vo backend/LTL.vo backend/Coloring.vo backend/Coloringproof.vo backend/Allocation.vo backend/Allocproof.vo backend/RTLtyping.vo backend/LTLtyping.vo backend/Conventions.vo backend/Tunneling.vo: backend/Tunneling.v lib/Coqlib.vo lib/Maps.vo common/AST.vo common/Values.vo common/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/LTL.vo -backend/Tunnelingproof.vo: backend/Tunnelingproof.v lib/Coqlib.vo lib/Maps.vo common/AST.vo common/Values.vo common/Mem.vo common/Events.vo common/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/LTL.vo backend/Tunneling.vo -backend/Tunnelingtyping.vo: backend/Tunnelingtyping.v lib/Coqlib.vo lib/Maps.vo common/AST.vo common/Values.vo common/Mem.vo common/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/LTL.vo backend/LTLtyping.vo backend/Tunneling.vo -backend/Linear.vo: backend/Linear.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Mem.vo common/Events.vo common/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/LTL.vo backend/Conventions.vo +backend/Tunnelingproof.vo: backend/Tunnelingproof.v lib/Coqlib.vo lib/Maps.vo common/AST.vo common/Values.vo common/Mem.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo backend/Op.vo backend/Locations.vo backend/LTL.vo backend/Tunneling.vo +backend/Tunnelingtyping.vo: backend/Tunnelingtyping.v lib/Coqlib.vo lib/Maps.vo common/AST.vo common/Values.vo common/Mem.vo common/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/LTL.vo backend/LTLtyping.vo backend/Tunneling.vo backend/Tunnelingproof.vo +backend/LTLin.vo: backend/LTLin.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Mem.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo backend/Op.vo backend/Locations.vo backend/LTL.vo backend/Conventions.vo +backend/LTLintyping.vo: backend/LTLintyping.v lib/Coqlib.vo lib/Maps.vo common/AST.vo backend/Op.vo backend/RTL.vo backend/Locations.vo backend/LTLin.vo backend/Conventions.vo +backend/Linearize.vo: backend/Linearize.v lib/Coqlib.vo lib/Maps.vo common/AST.vo common/Values.vo common/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/LTL.vo backend/LTLin.vo backend/Kildall.vo lib/Lattice.vo +backend/Linearizeproof.vo: backend/Linearizeproof.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Mem.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo backend/Op.vo backend/Locations.vo backend/LTL.vo backend/LTLtyping.vo backend/LTLin.vo backend/Linearize.vo lib/Lattice.vo +backend/Linearizetyping.vo: backend/Linearizetyping.v lib/Coqlib.vo lib/Maps.vo common/AST.vo backend/Op.vo backend/Locations.vo backend/LTL.vo backend/LTLtyping.vo backend/LTLin.vo backend/Linearize.vo backend/LTLintyping.vo backend/Conventions.vo +backend/Linear.vo: backend/Linear.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Mem.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo backend/Op.vo backend/Locations.vo backend/LTL.vo backend/Conventions.vo backend/Lineartyping.vo: backend/Lineartyping.v lib/Coqlib.vo lib/Maps.vo common/AST.vo backend/Op.vo backend/RTL.vo backend/Locations.vo backend/Linear.vo backend/Conventions.vo -backend/Linearize.vo: backend/Linearize.v lib/Coqlib.vo lib/Maps.vo common/AST.vo common/Values.vo common/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/LTL.vo backend/Linear.vo backend/Kildall.vo lib/Lattice.vo -backend/Linearizeproof.vo: backend/Linearizeproof.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Mem.vo common/Events.vo common/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/LTL.vo backend/Linear.vo backend/Linearize.vo lib/Lattice.vo -backend/Linearizetyping.vo: backend/Linearizetyping.v lib/Coqlib.vo lib/Maps.vo common/AST.vo backend/Op.vo backend/Locations.vo backend/LTL.vo backend/Linear.vo backend/Linearize.vo backend/LTLtyping.vo backend/Lineartyping.vo backend/Conventions.vo -backend/Mach.vo: backend/Mach.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Mem.vo common/Events.vo common/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/Conventions.vo -backend/Machabstr.vo: backend/Machabstr.v lib/Coqlib.vo lib/Maps.vo common/AST.vo common/Mem.vo lib/Integers.vo common/Values.vo common/Events.vo common/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/Conventions.vo backend/Mach.vo +backend/Parallelmove.vo: backend/Parallelmove.v lib/Coqlib.vo lib/Parmov.vo common/Values.vo common/Events.vo common/AST.vo backend/Locations.vo backend/Conventions.vo +backend/Reload.vo: backend/Reload.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/LTLin.vo backend/Conventions.vo backend/Parallelmove.vo backend/Linear.vo +backend/Reloadproof.vo: backend/Reloadproof.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Mem.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo backend/Op.vo backend/Locations.vo backend/Conventions.vo backend/Allocproof.vo backend/LTLin.vo backend/LTLintyping.vo backend/Linear.vo backend/Parallelmove.vo backend/Reload.vo +backend/Reloadtyping.vo: backend/Reloadtyping.v lib/Coqlib.vo lib/Maps.vo common/AST.vo backend/Op.vo backend/Locations.vo backend/LTLin.vo backend/LTLintyping.vo backend/Linear.vo backend/Lineartyping.vo backend/Conventions.vo backend/Parallelmove.vo backend/Reload.vo backend/Reloadproof.vo +backend/Mach.vo: backend/Mach.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Mem.vo common/Events.vo common/Globalenvs.vo backend/Op.vo backend/Locations.vo +backend/Machabstr.vo: backend/Machabstr.v lib/Coqlib.vo lib/Maps.vo common/AST.vo common/Mem.vo lib/Integers.vo common/Values.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo backend/Op.vo backend/Locations.vo backend/Conventions.vo backend/Mach.vo backend/Machtyping.vo: backend/Machtyping.v lib/Coqlib.vo lib/Maps.vo common/AST.vo common/Mem.vo lib/Integers.vo common/Values.vo common/Events.vo common/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/Conventions.vo backend/Mach.vo backend/Machabstr.vo -backend/Stacking.vo: backend/Stacking.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo backend/Op.vo backend/RTL.vo backend/Locations.vo backend/Linear.vo backend/Lineartyping.vo backend/Mach.vo backend/Conventions.vo -backend/Stackingproof.vo: backend/Stackingproof.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo backend/Op.vo common/Mem.vo common/Events.vo common/Globalenvs.vo backend/Locations.vo backend/Mach.vo backend/Machabstr.vo backend/Linear.vo backend/Lineartyping.vo backend/Conventions.vo backend/Stacking.vo -backend/Stackingtyping.vo: backend/Stackingtyping.v lib/Coqlib.vo lib/Maps.vo lib/Integers.vo common/AST.vo backend/Op.vo backend/Locations.vo backend/Conventions.vo backend/Linear.vo backend/Lineartyping.vo backend/Mach.vo backend/Machtyping.vo backend/Stacking.vo backend/Stackingproof.vo -backend/Machabstr2mach.vo: backend/Machabstr2mach.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Mem.vo common/Events.vo common/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/Machabstr.vo backend/Mach.vo backend/Machtyping.vo backend/Stackingproof.vo -backend/PPC.vo: backend/PPC.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Mem.vo common/Events.vo common/Globalenvs.vo -backend/PPCgen.vo: backend/PPCgen.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Mem.vo common/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/Mach.vo backend/PPC.vo -backend/PPCgenproof1.vo: backend/PPCgenproof1.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Mem.vo common/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/Mach.vo backend/Machtyping.vo backend/PPC.vo backend/PPCgen.vo backend/Conventions.vo -backend/PPCgenproof.vo: backend/PPCgenproof.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Mem.vo common/Events.vo common/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/Mach.vo backend/Machtyping.vo backend/PPC.vo backend/PPCgen.vo backend/PPCgenproof1.vo -cfrontend/Csyntax.vo: cfrontend/Csyntax.v lib/Coqlib.vo lib/Integers.vo lib/Floats.vo common/AST.vo -cfrontend/Csem.vo: cfrontend/Csem.v lib/Coqlib.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/AST.vo common/Mem.vo common/Events.vo common/Globalenvs.vo cfrontend/Csyntax.vo +backend/Bounds.vo: backend/Bounds.v lib/Coqlib.vo lib/Maps.vo common/AST.vo backend/Op.vo backend/Locations.vo backend/Linear.vo backend/Lineartyping.vo backend/Conventions.vo +backend/Stacking.vo: backend/Stacking.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo common/AST.vo lib/Integers.vo backend/Op.vo backend/RTL.vo backend/Locations.vo backend/Linear.vo backend/Bounds.vo backend/Mach.vo backend/Conventions.vo +backend/Stackingproof.vo: backend/Stackingproof.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo common/AST.vo lib/Integers.vo common/Values.vo backend/Op.vo common/Mem.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo backend/Locations.vo backend/Linear.vo backend/Lineartyping.vo backend/Mach.vo backend/Machabstr.vo backend/Bounds.vo backend/Conventions.vo backend/Stacking.vo +backend/Stackingtyping.vo: backend/Stackingtyping.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo lib/Integers.vo common/AST.vo backend/Op.vo backend/Locations.vo backend/Conventions.vo backend/Linear.vo backend/Lineartyping.vo backend/Mach.vo backend/Machtyping.vo backend/Bounds.vo backend/Stacking.vo backend/Stackingproof.vo +backend/Machconcr.vo: backend/Machconcr.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Mem.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo backend/Op.vo backend/Locations.vo backend/Conventions.vo backend/Mach.vo backend/PPCgenretaddr.vo +backend/Machabstr2concr.vo: backend/Machabstr2concr.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Mem.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo backend/Op.vo backend/Locations.vo backend/Mach.vo backend/Machtyping.vo backend/Machabstr.vo backend/Machconcr.vo backend/Stackingproof.vo backend/PPCgenretaddr.vo +backend/PPC.vo: backend/PPC.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Mem.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo +backend/PPCgen.vo: backend/PPCgen.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Mem.vo common/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/Mach.vo backend/PPC.vo +backend/PPCgenretaddr.vo: backend/PPCgenretaddr.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Mem.vo common/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/Mach.vo backend/PPC.vo backend/PPCgen.vo +backend/PPCgenproof1.vo: backend/PPCgenproof1.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Mem.vo common/Globalenvs.vo backend/Op.vo backend/Locations.vo backend/Mach.vo backend/Machconcr.vo backend/Machtyping.vo backend/PPC.vo backend/PPCgen.vo backend/Conventions.vo +backend/PPCgenproof.vo: backend/PPCgenproof.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Mem.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo backend/Op.vo backend/Locations.vo backend/Mach.vo backend/Machconcr.vo backend/Machtyping.vo backend/PPC.vo backend/PPCgen.vo backend/PPCgenretaddr.vo backend/PPCgenproof1.vo +cfrontend/Csyntax.vo: cfrontend/Csyntax.v lib/Coqlib.vo common/Errors.vo lib/Integers.vo lib/Floats.vo common/AST.vo +cfrontend/Csem.vo: cfrontend/Csem.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/AST.vo common/Mem.vo common/Events.vo common/Globalenvs.vo cfrontend/Csyntax.vo cfrontend/Ctyping.vo: cfrontend/Ctyping.v lib/Coqlib.vo lib/Maps.vo common/AST.vo cfrontend/Csyntax.vo -cfrontend/Cshmgen.vo: cfrontend/Cshmgen.v lib/Coqlib.vo lib/Integers.vo lib/Floats.vo common/AST.vo cfrontend/Csyntax.vo cfrontend/Csharpminor.vo -cfrontend/Cshmgenproof1.vo: cfrontend/Cshmgenproof1.v lib/Coqlib.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/AST.vo common/Values.vo common/Events.vo common/Mem.vo common/Globalenvs.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Ctyping.vo cfrontend/Csharpminor.vo cfrontend/Cshmgen.vo -cfrontend/Cshmgenproof2.vo: cfrontend/Cshmgenproof2.v lib/Coqlib.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/AST.vo common/Values.vo common/Events.vo common/Mem.vo common/Globalenvs.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Ctyping.vo cfrontend/Csharpminor.vo cfrontend/Cshmgen.vo cfrontend/Cshmgenproof1.vo -cfrontend/Cshmgenproof3.vo: cfrontend/Cshmgenproof3.v lib/Coqlib.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/AST.vo common/Values.vo common/Events.vo common/Mem.vo common/Globalenvs.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Ctyping.vo cfrontend/Csharpminor.vo cfrontend/Cshmgen.vo cfrontend/Cshmgenproof1.vo cfrontend/Cshmgenproof2.vo -cfrontend/Csharpminor.vo: cfrontend/Csharpminor.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Mem.vo common/Events.vo common/Globalenvs.vo -cfrontend/Cminorgen.vo: cfrontend/Cminorgen.v lib/Coqlib.vo lib/Maps.vo lib/Ordered.vo common/AST.vo lib/Integers.vo common/Mem.vo cfrontend/Csharpminor.vo backend/Op.vo backend/Cminor.vo backend/Cmconstr.vo -cfrontend/Cminorgenproof.vo: cfrontend/Cminorgenproof.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Mem.vo common/Events.vo common/Globalenvs.vo cfrontend/Csharpminor.vo backend/Op.vo backend/Cminor.vo backend/Cmconstr.vo cfrontend/Cminorgen.vo backend/Cmconstrproof.vo +cfrontend/Cshmgen.vo: cfrontend/Cshmgen.v lib/Coqlib.vo common/Errors.vo lib/Integers.vo lib/Floats.vo common/AST.vo cfrontend/Csyntax.vo backend/Cminor.vo cfrontend/Csharpminor.vo +cfrontend/Cshmgenproof1.vo: cfrontend/Cshmgenproof1.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/AST.vo common/Values.vo common/Events.vo common/Mem.vo common/Globalenvs.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Ctyping.vo backend/Cminor.vo cfrontend/Csharpminor.vo cfrontend/Cshmgen.vo +cfrontend/Cshmgenproof2.vo: cfrontend/Cshmgenproof2.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/AST.vo common/Values.vo common/Events.vo common/Mem.vo common/Globalenvs.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Ctyping.vo backend/Cminor.vo cfrontend/Csharpminor.vo cfrontend/Cshmgen.vo cfrontend/Cshmgenproof1.vo +cfrontend/Cshmgenproof3.vo: cfrontend/Cshmgenproof3.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/AST.vo common/Values.vo common/Events.vo common/Mem.vo common/Globalenvs.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Ctyping.vo backend/Cminor.vo cfrontend/Csharpminor.vo cfrontend/Cshmgen.vo cfrontend/Cshmgenproof1.vo cfrontend/Cshmgenproof2.vo +cfrontend/Csharpminor.vo: cfrontend/Csharpminor.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Mem.vo common/Events.vo common/Globalenvs.vo backend/Cminor.vo +cfrontend/Cminorgen.vo: cfrontend/Cminorgen.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo lib/Ordered.vo common/AST.vo lib/Integers.vo common/Mem.vo cfrontend/Csharpminor.vo backend/Op.vo backend/Cminor.vo +cfrontend/Cminorgenproof.vo: cfrontend/Cminorgenproof.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Mem.vo common/Events.vo common/Globalenvs.vo cfrontend/Csharpminor.vo backend/Cminor.vo cfrontend/Cminorgen.vo diff --git a/Makefile b/Makefile index 00b00008..bea28aca 100644 --- a/Makefile +++ b/Makefile @@ -12,30 +12,32 @@ LIB=Coqlib.v Maps.v Lattice.v Ordered.v \ # Files in common/ -COMMON=AST.v Events.v Globalenvs.v Mem.v Values.v Main.v +COMMON=Errors.v AST.v Events.v Globalenvs.v Mem.v Values.v \ + Smallstep.v Switch.v Main.v # Files in backend/ BACKEND=\ - Op.v Cminor.v \ - Cmconstr.v Cmconstrproof.v \ + Cminor.v Op.v CminorSel.v \ + Selection.v Selectionproof.v \ Registers.v RTL.v \ - RTLgen.v RTLgenproof1.v RTLgenproof.v \ + RTLgen.v RTLgenspec.v RTLgenproof.v \ RTLtyping.v \ Kildall.v \ Constprop.v Constpropproof.v \ CSE.v CSEproof.v \ Locations.v Conventions.v LTL.v LTLtyping.v \ InterfGraph.v Coloring.v Coloringproof.v \ - Parallelmove.v Allocation.v \ - Allocproof.v Alloctyping.v \ + Allocation.v Allocproof.v Alloctyping.v \ Tunneling.v Tunnelingproof.v Tunnelingtyping.v \ - Linear.v Lineartyping.v \ + LTLin.v LTLintyping.v \ Linearize.v Linearizeproof.v Linearizetyping.v \ + Linear.v Lineartyping.v \ + Parallelmove.v Reload.v Reloadproof.v Reloadtyping.v \ Mach.v Machabstr.v Machtyping.v \ - Stacking.v Stackingproof.v Stackingtyping.v \ - Machabstr2mach.v \ - PPC.v PPCgen.v PPCgenproof1.v PPCgenproof.v + Bounds.v Stacking.v Stackingproof.v Stackingtyping.v \ + Machconcr.v Machabstr2concr.v \ + PPC.v PPCgen.v PPCgenretaddr.v PPCgenproof1.v PPCgenproof.v # Files in cfrontend/ @@ -47,7 +49,7 @@ CFRONTEND=Csyntax.v Csem.v Ctyping.v Cshmgen.v \ FILES=$(LIB:%=lib/%) $(COMMON:%=common/%) $(BACKEND:%=backend/%) $(CFRONTEND:%=cfrontend/%) -FLATFILES=$(LIB) $(BACKEND) $(CFRONTEND) +FLATFILES=$(LIB) $(COMMON) $(BACKEND) $(CFRONTEND) proof: $(FILES:.v=.vo) @@ -65,24 +67,30 @@ cil: $(MAKE) -C cil documentation: - $(COQDOC) --html -d doc $(FLATFILES:%.v=--glob-from doc/%.glob) $(FILES) - doc/removeproofs doc/lib.*.html doc/backend.*.html + @ln -f $(FILES) doc/ + @mkdir -p doc/html + cd doc; $(COQDOC) --html -d html \ + $(FLATFILES:%.v=--glob-from %.glob) $(FLATFILES) + @cd doc; rm -f $(FLATFILES) + cp doc/coqdoc.css doc/html/coqdoc.css + doc/removeproofs doc/html/*.html latexdoc: - $(COQDOC) --latex -o doc/doc.tex -g $(FILES) + cd doc; $(COQDOC) --latex -o doc/doc.tex -g $(FILES) .SUFFIXES: .v .vo .v.vo: @rm -f doc/glob/$(*F).glob - $(COQC) -dump-glob doc/$(*F).glob $*.v + @echo "COQC $*.v" + @$(COQC) -dump-glob doc/$(*F).glob $*.v depend: $(COQDEP) $(FILES) > .depend clean: rm -f */*.vo *~ */*~ - rm -f doc/lib.*.html doc/backend.*.html doc/*.glob + rm -rf doc/html doc/*.glob $(MAKE) -C extraction clean $(MAKE) -C test/cminor clean diff --git a/backend/Allocation.v b/backend/Allocation.v index 74c85cfe..eab5233d 100644 --- a/backend/Allocation.v +++ b/backend/Allocation.v @@ -1,7 +1,7 @@ -(** Register allocation, spilling, reloading and explicitation of - calling conventions. *) +(** Register allocation. *) Require Import Coqlib. +Require Import Errors. Require Import Maps. Require Import Lattice. Require Import AST. @@ -16,15 +16,14 @@ Require Import Kildall. Require Import Locations. Require Import Conventions. Require Import Coloring. -Require Import Parallelmove. (** * Liveness analysis over RTL *) (** A register [r] is live at a point [p] if there exists a path - from [p] to some instruction that uses [r] as argument, - and [r] is not redefined along this path. - Liveness can be computed by a backward dataflow analysis. - The analysis operates over sets of (live) pseudo-registers. *) + from [p] to some instruction that uses [r] as argument, + and [r] is not redefined along this path. + Liveness can be computed by a backward dataflow analysis. + The analysis operates over sets of (live) pseudo-registers. *) Notation reg_live := Regset.add. Notation reg_dead := Regset.remove. @@ -50,25 +49,25 @@ Fixpoint reg_list_dead end. (** Here is the transfer function for the dataflow analysis. - Since this is a backward dataflow analysis, it takes as argument - the abstract register set ``after'' the given instruction, - i.e. the registers that are live after; and it returns as result - the abstract register set ``before'' the given instruction, - i.e. the registers that must be live before. - The general relation between ``live before'' and ``live after'' - an instruction is that a register is live before if either - it is one of the arguments of the instruction, or it is not the result - of the instruction and it is live after. - However, if the result of a side-effect-free instruction is not - live ``after'', the whole instruction will be removed later - (since it computes a useless result), thus its arguments need not - be live ``before''. *) + Since this is a backward dataflow analysis, it takes as argument + the abstract register set ``after'' the given instruction, + i.e. the registers that are live after; and it returns as result + the abstract register set ``before'' the given instruction, + i.e. the registers that must be live before. + The general relation between ``live before'' and ``live after'' + an instruction is that a register is live before if either + it is one of the arguments of the instruction, or it is not the result + of the instruction and it is live after. + However, if the result of a side-effect-free instruction is not + live ``after'', the whole instruction will be removed later + (since it computes a useless result), thus its arguments need not + be live ``before''. *) Definition transfer (f: RTL.function) (pc: node) (after: Regset.t) : Regset.t := match f.(fn_code)!pc with | None => - after + Regset.empty | Some i => match i with | Inop s => @@ -88,18 +87,20 @@ Definition transfer | Icall sig ros args res s => reg_list_live args (reg_sum_live ros (reg_dead res after)) + | Itailcall sig ros args => + reg_list_live args (reg_sum_live ros Regset.empty) | Ialloc arg res s => reg_live arg (reg_dead res after) | Icond cond args ifso ifnot => reg_list_live args after | Ireturn optarg => - reg_option_live optarg after + reg_option_live optarg Regset.empty end end. (** The liveness analysis is then obtained by instantiating the - general framework for backward dataflow analysis provided by - module [Kildall]. *) + general framework for backward dataflow analysis provided by + module [Kildall]. *) Module RegsetLat := LFSet(Regset). Module DS := Backward_Dataflow_Solver(RegsetLat)(NodeSetBackward). @@ -107,315 +108,108 @@ Module DS := Backward_Dataflow_Solver(RegsetLat)(NodeSetBackward). Definition analyze (f: RTL.function): option (PMap.t Regset.t) := DS.fixpoint (successors f) f.(fn_nextpc) (transfer f) nil. -(** * Spilling and reloading *) - -(** LTL operations, like those of the target processor, operate only - over machine registers, but not over stack slots. Consider - the RTL instruction -<< - r1 <- Iop(Oadd, r1 :: r2 :: nil) ->> - and assume that [r1] and [r2] are assigned to stack locations [S s1] - and [S s2], respectively. The translated LTL code must load these - stack locations into temporary integer registers (this is called - ``reloading''), perform the [Oadd] operation over these temporaries, - leave the result in a temporary, then store the temporary back to - stack location [S s1] (this is called ``spilling''). In other term, - the generated LTL code has the following shape: -<< - IT1 <- Bgetstack s1; - IT2 <- Bgetstack s2; - IT1 <- Bop(Oadd, IT1 :: IT2 :: nil); - Bsetstack s1 IT1; ->> - This section provides functions that assist in choosing appropriate - temporaries and inserting the required spilling and reloading - operations. *) - -(** ** Allocation of temporary registers for reloading and spilling. *) - -(** [reg_for l] returns a machine register appropriate for working - over the location [l]: either the machine register [m] if [l = R m], - or a temporary register of [l]'s type if [l] is a stack slot. *) - -Definition reg_for (l: loc) : mreg := - match l with - | R r => r - | S s => match slot_type s with Tint => IT1 | Tfloat => FT1 end - end. - -(** [regs_for ll] is similar, for a list of locations [ll] of length - at most 3. We ensure that distinct temporaries are used for - different elements of [ll]. *) - -Fixpoint regs_for_rec (locs: list loc) (itmps ftmps: list mreg) - {struct locs} : list mreg := - match locs, itmps, ftmps with - | l1 :: ls, it1 :: its, ft1 :: fts => - match l1 with - | R r => r - | S s => match slot_type s with Tint => it1 | Tfloat => ft1 end - end - :: regs_for_rec ls its fts - | _, _, _ => nil - end. - -Definition regs_for (locs: list loc) := - regs_for_rec locs (IT1 :: IT2 :: IT3 :: nil) (FT1 :: FT2 :: FT3 :: nil). - -(** ** Insertion of LTL reloads, stores and moves *) +(** * Translation from RTL to LTL *) Require Import LTL. -(** [add_spill src dst k] prepends to [k] the instructions needed - to assign location [dst] the value of machine register [mreg]. *) - -Definition add_spill (src: mreg) (dst: loc) (k: block) := - match dst with - | R rd => if mreg_eq src rd then k else Bop Omove (src :: nil) rd k - | S sl => Bsetstack src sl k - end. - -(** [add_reload src dst k] prepends to [k] the instructions needed - to assign machine register [mreg] the value of the location [src]. *) - -Definition add_reload (src: loc) (dst: mreg) (k: block) := - match src with - | R rs => if mreg_eq rs dst then k else Bop Omove (rs :: nil) dst k - | S sl => Bgetstack sl dst k - end. - -(** [add_reloads] is similar for a list of locations (as sources) - and a list of machine registers (as destinations). *) - -Fixpoint add_reloads (srcs: list loc) (dsts: list mreg) (k: block) - {struct srcs} : block := - match srcs, dsts with - | s1 :: sl, t1 :: tl => - add_reload s1 t1 (add_reloads sl tl k) - | _, _ => - k - end. - -(** [add_move src dst k] prepends to [k] the instructions that copy - the value of location [src] into location [dst]. *) - -Definition add_move (src dst: loc) (k: block) := - if Loc.eq src dst then k else - match src, dst with - | R rs, _ => - add_spill rs dst k - | _, R rd => - add_reload src rd k - | S ss, S sd => - let tmp := - match slot_type ss with Tint => IT1 | Tfloat => FT1 end in - add_reload src tmp (add_spill tmp dst k) - end. - -(** [parallel_move srcs dsts k] is similar, but for a list of - source locations and a list of destination locations of the same - length. This is a parallel move, meaning that arbitrary overlap - between the sources and destinations is permitted. *) - -Definition parallel_move (srcs dsts: list loc) (k: block) : block := - List.fold_right - (fun p k => add_move (fst p) (snd p) k) - k (parmove srcs dsts). - -(** ** Constructors for LTL instructions *) - -(** The following functions generate LTL instructions operating - over the given locations. Appropriate reloading and spilling operations - are added around the core LTL instruction. *) - -Definition add_op (op: operation) (args: list loc) (res: loc) (s: node) := - match is_move_operation op args with - | Some src => - add_move src res (Bgoto s) - | None => - let rargs := regs_for args in - let rres := reg_for res in - add_reloads args rargs (Bop op rargs rres (add_spill rres res (Bgoto s))) - end. - -Definition add_load (chunk: memory_chunk) (addr: addressing) - (args: list loc) (dst: loc) (s: node) := - let rargs := regs_for args in - let rdst := reg_for dst in - add_reloads args rargs - (Bload chunk addr rargs rdst (add_spill rdst dst (Bgoto s))). - -Definition add_store (chunk: memory_chunk) (addr: addressing) - (args: list loc) (src: loc) (s: node) := - match regs_for (src :: args) with - | nil => Breturn (* never happens *) - | rsrc :: rargs => - add_reloads (src :: args) (rsrc :: rargs) - (Bstore chunk addr rargs rsrc (Bgoto s)) - end. - -Definition add_alloc (arg: loc) (res: loc) (s: node) := - add_reload arg Conventions.loc_alloc_argument - (Balloc (add_spill Conventions.loc_alloc_result res (Bgoto s))). - -(** For function calls, we also add appropriate moves to and from - the canonical locations for function arguments and function results, - as dictated by the calling conventions. *) - -Definition add_call (sig: signature) (ros: loc + ident) - (args: list loc) (res: loc) (s: node) := - let rargs := loc_arguments sig in - let rres := loc_result sig in - match ros with - | inl fn => - (add_reload fn IT3 - (parallel_move args rargs - (Bcall sig (inl _ IT3) (add_spill rres res (Bgoto s))))) - | inr id => - parallel_move args rargs - (Bcall sig (inr _ id) (add_spill rres res (Bgoto s))) - end. - -Definition add_cond (cond: condition) (args: list loc) (ifso ifnot: node) := - let rargs := regs_for args in - add_reloads args rargs (Bcond cond rargs ifso ifnot). - -(** For function returns, we add the appropriate move of the result - to the conventional location for the function result. If the function - returns with no value, we explicitly set the function result register - to the [Vundef] value, for consistency with RTL's semantics. *) - -Definition add_return (sig: signature) (optarg: option loc) := - match optarg with - | Some arg => add_reload arg (loc_result sig) Breturn - | None => Bop Oundef nil (loc_result sig) Breturn - end. - -(** For function entry points, we move from the parameter locations - dictated by the calling convention to the locations of the function - parameters. We also explicitly set to [Vundef] the locations - of pseudo-registers that are live at function entry but are not - parameters, again for consistency with RTL's semantics. *) - -Fixpoint add_undefs (ll: list loc) (b: block) {struct ll} : block := - match ll with - | nil => b - | R r :: ls => Bop Oundef nil r (add_undefs ls b) - | S s :: ls => add_undefs ls b - end. - -Definition add_entry (sig: signature) (params: list loc) (undefs: list loc) - (s: node) := - parallel_move (loc_parameters sig) params (add_undefs undefs (Bgoto s)). - -(** * Translation from RTL to LTL *) - -(** Each [RTL] instruction translates to an [LTL] basic block. +(** Each [RTL] instruction translates to an [LTL] instruction. The register assignment [assign] returned by register allocation is applied to the arguments and results of the RTL - instruction, followed by an invocation of the appropriate [LTL] - constructor function that will deal with spilling, reloading and - calling conventions. In addition, dead instructions are eliminated. + instruction. Moreover, dead instructions and redundant moves + are eliminated (turned into a [Lnop] instruction). Dead instructions are instructions without side-effects ([Iop] and [Iload]) whose result register is dead, i.e. whose result value - is never used. *) + is never used. Redundant moves are moves whose source and destination + are assigned the same location. *) + +Definition is_redundant_move + (op: operation) (args: list reg) (res: reg) (assign: reg -> loc) : bool := + match is_move_operation op args with + | None => false + | Some src => if Loc.eq (assign src) (assign res) then true else false + end. Definition transf_instr (f: RTL.function) (live: PMap.t Regset.t) (assign: reg -> loc) - (pc: node) (instr: RTL.instruction) : LTL.block := + (pc: node) (instr: RTL.instruction) : LTL.instruction := match instr with | Inop s => - Bgoto s + Lnop s | Iop op args res s => if Regset.mem res live!!pc then - add_op op (List.map assign args) (assign res) s + if is_redundant_move op args res assign then + Lnop s + else + Lop op (List.map assign args) (assign res) s else - Bgoto s + Lnop s | Iload chunk addr args dst s => if Regset.mem dst live!!pc then - add_load chunk addr (List.map assign args) (assign dst) s + Lload chunk addr (List.map assign args) (assign dst) s else - Bgoto s + Lnop s | Istore chunk addr args src s => - add_store chunk addr (List.map assign args) (assign src) s + Lstore chunk addr (List.map assign args) (assign src) s | Icall sig ros args res s => - add_call sig (sum_left_map assign ros) (List.map assign args) - (assign res) s + Lcall sig (sum_left_map assign ros) (List.map assign args) + (assign res) s + | Itailcall sig ros args => + Ltailcall sig (sum_left_map assign ros) (List.map assign args) | Ialloc arg res s => - add_alloc (assign arg) (assign res) s + Lalloc (assign arg) (assign res) s | Icond cond args ifso ifnot => - add_cond cond (List.map assign args) ifso ifnot + Lcond cond (List.map assign args) ifso ifnot | Ireturn optarg => - add_return f.(RTL.fn_sig) (option_map assign optarg) + Lreturn (option_map assign optarg) end. -Definition transf_entrypoint - (f: RTL.function) (live: PMap.t Regset.t) (assign: reg -> loc) - (newcode: LTL.code) : LTL.code := - let oldentry := RTL.fn_entrypoint f in - let newentry := RTL.fn_nextpc f in - let undefs := - Regset.elements (reg_list_dead (RTL.fn_params f) - (transfer f oldentry live!!oldentry)) in - PTree.set - newentry - (add_entry (RTL.fn_sig f) - (List.map assign (RTL.fn_params f)) - (List.map assign undefs) - oldentry) - newcode. - -Lemma transf_entrypoint_wf: +Lemma transf_body_wf: forall (f: RTL.function) (live: PMap.t Regset.t) (assign: reg -> loc), - let tc1 := PTree.map (transf_instr f live assign) (RTL.fn_code f) in - let tc2 := transf_entrypoint f live assign tc1 in - forall (pc: node), Plt pc (Psucc (RTL.fn_nextpc f)) \/ tc2!pc = None. + let tc := PTree.map (transf_instr f live assign) (RTL.fn_code f) in + forall (pc: node), Plt pc (RTL.fn_nextpc f) \/ tc!pc = None. Proof. - intros. case (plt pc (Psucc (RTL.fn_nextpc f))); intro. - left. auto. - right. - assert (pc <> RTL.fn_nextpc f). - red; intro. subst pc. elim n. apply Plt_succ. - assert (~ (Plt pc (RTL.fn_nextpc f))). - red; intro. elim n. apply Plt_trans_succ; auto. - unfold tc2. unfold transf_entrypoint. - rewrite PTree.gso; auto. - unfold tc1. rewrite PTree.gmap. - elim (RTL.fn_code_wf f pc); intro. - contradiction. unfold option_map. rewrite H1. auto. + intros. elim (RTL.fn_code_wf f pc); intro. + left. auto. right. unfold tc. rewrite PTree.gmap. + unfold option_map. rewrite H. auto. Qed. +Definition transf_fun (f: RTL.function) (live: PMap.t Regset.t) + (assign: reg -> loc) : LTL.function := + LTL.mkfunction + (RTL.fn_sig f) + (List.map assign (RTL.fn_params f)) + (RTL.fn_stacksize f) + (PTree.map (transf_instr f live assign) (RTL.fn_code f)) + (RTL.fn_entrypoint f) + (RTL.fn_nextpc f) + (transf_body_wf f live assign). + (** The translation of a function performs liveness analysis, construction and coloring of the inference graph, and per-instruction transformation as described above. *) -Definition transf_function (f: RTL.function) : option LTL.function := +Definition live0 (f: RTL.function) (live: PMap.t Regset.t) := + transfer f f.(RTL.fn_entrypoint) live!!(f.(RTL.fn_entrypoint)). + +Open Scope string_scope. + +Definition transf_function (f: RTL.function) : res LTL.function := match type_function f with - | None => None - | Some env => + | Error msg => Error msg + | OK env => match analyze f with - | None => None + | None => Error (msg "Liveness analysis failure") | Some live => - let pc0 := f.(RTL.fn_entrypoint) in - let live0 := transfer f pc0 live!!pc0 in - match regalloc f live live0 env with - | None => None - | Some assign => - Some (LTL.mkfunction - (RTL.fn_sig f) - (RTL.fn_stacksize f) - (transf_entrypoint f live assign - (PTree.map (transf_instr f live assign) (RTL.fn_code f))) - (RTL.fn_nextpc f) - (transf_entrypoint_wf f live assign)) - end + match regalloc f live (live0 f live) env with + | None => Error (msg "Incorrect graph coloring") + | Some assign => OK (transf_fun f live assign) + end end end. -Definition transf_fundef (fd: RTL.fundef) : option LTL.fundef := - transf_partial_fundef transf_function fd. +Definition transf_fundef (fd: RTL.fundef) : res LTL.fundef := + AST.transf_partial_fundef transf_function fd. -Definition transf_program (p: RTL.program) : option LTL.program := +Definition transf_program (p: RTL.program) : res LTL.program := transform_partial_program transf_fundef p. diff --git a/backend/Allocproof.v b/backend/Allocproof.v index f0b2968f..1b5a4156 100644 --- a/backend/Allocproof.v +++ b/backend/Allocproof.v @@ -1,16 +1,17 @@ (** Correctness proof for the [Allocation] pass (translation from RTL to LTL). *) -Require Import Relations. Require Import FSets. Require Import SetoidList. Require Import Coqlib. +Require Import Errors. Require Import Maps. Require Import AST. Require Import Integers. Require Import Values. Require Import Mem. Require Import Events. +Require Import Smallstep. Require Import Globalenvs. Require Import Op. Require Import Registers. @@ -20,7 +21,6 @@ Require Import Locations. Require Import Conventions. Require Import Coloring. Require Import Coloringproof. -Require Import Parallelmove. Require Import Allocation. (** * Semantic properties of calling conventions *) @@ -53,9 +53,27 @@ Proof. auto. case (In_dec Loc.eq (R (loc_result sig)) destroyed_at_call); intro. auto. - elim n0. apply loc_result_acceptable. + elim n0. apply loc_result_caller_save. Qed. +(** Function arguments for a tail call are preserved by a + [return_regs] operation. *) + +Lemma return_regs_arguments: + forall sig caller callee, + tailcall_possible sig -> + map (LTL.return_regs caller callee) (loc_arguments sig) = + map callee (loc_arguments sig). +Proof. + intros. apply list_map_exten; intros. + generalize (H x H0). destruct x; intro. + unfold LTL.return_regs. + destruct (In_dec Loc.eq (R m) temporaries). auto. + destruct (In_dec Loc.eq (R m) destroyed_at_call). auto. + elim n0. eapply arguments_caller_save; eauto. + contradiction. +Qed. + (** Acceptable locations that are not destroyed at call keep their values across a call. *) @@ -73,31 +91,22 @@ Proof. auto. Qed. -(** * Correctness condition for the liveness analysis *) - -(** The liveness information computed by the dataflow analysis is - correct in the following sense: all registers live ``before'' - an instruction are live ``after'' all of its predecessors. *) +(** Characterization of parallel assignments. *) -Lemma analyze_correct: - forall (f: function) (live: PMap.t Regset.t) (n s: node), - analyze f = Some live -> - f.(fn_code)!n <> None -> - f.(fn_code)!s <> None -> - In s (successors f n) -> - RegsetLat.ge live!!n (transfer f s live!!s). +Lemma parmov_spec: + forall ls srcs dsts, + Loc.norepet dsts -> List.length srcs = List.length dsts -> + List.map (LTL.parmov srcs dsts ls) dsts = List.map ls srcs /\ + (forall l, Loc.notin l dsts -> LTL.parmov srcs dsts ls l = ls l). Proof. - intros. - eapply DS.fixpoint_solution. - unfold analyze in H. eexact H. - elim (fn_code_wf f n); intro. auto. contradiction. - elim (fn_code_wf f s); intro. auto. contradiction. + induction srcs; destruct dsts; simpl; intros; try discriminate. auto. + inv H. inv H0. destruct (IHsrcs _ H4 H1). split. + f_equal. apply Locmap.gss. rewrite <- H. apply list_map_exten; intros. + symmetry. apply Locmap.gso. eapply Loc.in_notin_diff; eauto. + intros x [A B]. rewrite Locmap.gso; auto. apply Loc.diff_sym; auto. Qed. -Definition live0 (f: RTL.function) (live: PMap.t Regset.t) := - transfer f f.(RTL.fn_entrypoint) live!!(f.(RTL.fn_entrypoint)). - (** * Properties of allocated locations *) (** We list here various properties of the locations [alloc r], @@ -112,19 +121,6 @@ Variable live: PMap.t Regset.t. Variable alloc: reg -> loc. Hypothesis ALLOC: regalloc f live (live0 f live) env = Some alloc. -Lemma loc_acceptable_noteq_diff: - forall l1 l2, - loc_acceptable l1 -> l1 <> l2 -> Loc.diff l1 l2. -Proof. - unfold loc_acceptable, Loc.diff; destruct l1; destruct l2; - try (destruct s); try (destruct s0); intros; auto; try congruence. - case (zeq z z0); intro. - compare t t0; intro. - subst z0; subst t0; tauto. - tauto. tauto. - contradiction. contradiction. -Qed. - Lemma regalloc_noteq_diff: forall r1 l2, alloc r1 <> l2 -> Loc.diff (alloc r1) l2. @@ -134,18 +130,6 @@ Proof. auto. Qed. -Lemma loc_acceptable_notin_notin: - forall r ll, - loc_acceptable r -> - ~(In r ll) -> Loc.notin r ll. -Proof. - induction ll; simpl; intros. - auto. - split. apply loc_acceptable_noteq_diff. assumption. - apply sym_not_equal. tauto. - apply IHll. assumption. tauto. -Qed. - Lemma regalloc_notin_notin: forall r ll, ~(In (alloc r) ll) -> Loc.notin (alloc r) ll. @@ -153,6 +137,15 @@ Proof. intros. apply loc_acceptable_notin_notin. eapply regalloc_acceptable; eauto. auto. Qed. + +Lemma regalloc_notin_notin_2: + forall l rl, + ~(In l (map alloc rl)) -> Loc.notin l (map alloc rl). +Proof. + induction rl; simpl; intros. auto. + split. apply Loc.diff_sym. apply regalloc_noteq_diff. tauto. + apply IHrl. tauto. +Qed. Lemma regalloc_norepet_norepet: forall rl, @@ -215,7 +208,7 @@ Hypothesis REGALLOC: regalloc f flive (live0 f flive) env = Some assign. of [assign r] can be arbitrary. *) Definition agree (live: Regset.t) (rs: regset) (ls: locset) : Prop := - forall (r: reg), Regset.In r live -> ls (assign r) = rs#r. + forall (r: reg), Regset.In r live -> Val.lessdef (rs#r) (ls (assign r)). (** What follows is a long list of lemmas expressing properties of the [agree_live_regs] predicate that are useful for the @@ -232,6 +225,24 @@ Proof. apply H0. apply H. auto. Qed. +Lemma agree_succ: + forall n s rs ls live, + analyze f = Some live -> + In s (RTL.successors f n) -> + agree live!!n rs ls -> + agree (transfer f s live!!s) rs ls. +Proof. + intros. + elim (RTL.fn_code_wf f n); intro. + elim (RTL.fn_code_wf f s); intro. + apply agree_increasing with (live!!n). + eapply DS.fixpoint_solution. unfold analyze in H; eauto. + auto. auto. auto. auto. + unfold transfer. rewrite H3. + red; intros. elim (Regset.empty_1 _ H4). + unfold RTL.successors in H0; rewrite H2 in H0; elim H0. +Qed. + (** Some useful special cases of [agree_increasing]. *) @@ -266,7 +277,7 @@ Qed. Lemma agree_eval_reg: forall r live rs ls, - agree (reg_live r live) rs ls -> ls (assign r) = rs#r. + agree (reg_live r live) rs ls -> Val.lessdef (rs#r) (ls (assign r)). Proof. intros. apply H. apply Regset.add_1. auto. Qed. @@ -276,11 +287,11 @@ Qed. Lemma agree_eval_regs: forall rl live rs ls, agree (reg_list_live rl live) rs ls -> - List.map ls (List.map assign rl) = rs##rl. + Val.lessdef_list (rs##rl) (List.map ls (List.map assign rl)). Proof. induction rl; simpl; intros. - reflexivity. - apply (f_equal2 (@cons val)). + constructor. + constructor. apply agree_eval_reg with live. apply agree_reg_list_live with rl. auto. eapply IHrl. eexact H. @@ -322,21 +333,18 @@ Qed. are mapped to locations other than that of [r]. *) Lemma agree_assign_live: - forall live r rs ls ls' v, + forall live r rs ls v v', (forall s, Regset.In s live -> s <> r -> assign s <> assign r) -> - ls' (assign r) = v -> - (forall l, Loc.diff l (assign r) -> Loc.notin l temporaries -> ls' l = ls l) -> + Val.lessdef v v' -> agree (reg_dead r live) rs ls -> - agree live (rs#r <- v) ls'. + agree live (rs#r <- v) (Locmap.set (assign r) v' ls). Proof. - unfold agree; intros. - case (Reg.eq r r0); intro. - subst r0. rewrite Regmap.gss. assumption. - rewrite Regmap.gso; auto. - rewrite H1. apply H2. apply Regset.remove_2; auto. - eapply regalloc_noteq_diff. eauto. apply H. auto. auto. - eapply regalloc_not_temporary; eauto. + unfold agree; intros. rewrite Regmap.gsspec. + destruct (peq r0 r). + subst r0. rewrite Locmap.gss. auto. + rewrite Locmap.gso. apply H1. apply Regset.remove_2; auto. + eapply regalloc_noteq_diff. eauto. apply sym_not_equal. apply H. auto. auto. Qed. (** This is a special case of the previous lemma where the value [v] @@ -347,30 +355,47 @@ Qed. are mapped to locations other than that of [res]. *) Lemma agree_move_live: - forall live arg res rs (ls ls': locset), + forall live arg res rs (ls: locset), (forall r, Regset.In r live -> r <> res -> r <> arg -> assign r <> assign res) -> - ls' (assign res) = ls (assign arg) -> - (forall l, Loc.diff l (assign res) -> Loc.notin l temporaries -> ls' l = ls l) -> agree (reg_live arg (reg_dead res live)) rs ls -> - agree live (rs#res <- (rs#arg)) ls'. + agree live (rs#res <- (rs#arg)) (Locmap.set (assign res) (ls (assign arg)) ls). Proof. - unfold agree; intros. - case (Reg.eq res r); intro. - subst r. rewrite Regmap.gss. rewrite H0. apply H2. + unfold agree; intros. rewrite Regmap.gsspec. destruct (peq r res). + subst r. rewrite Locmap.gss. apply H0. apply Regset.add_1; auto. - rewrite Regmap.gso; auto. - case (Loc.eq (assign r) (assign res)); intro. - rewrite e. rewrite H0. - case (Reg.eq arg r); intro. - subst r. apply H2. apply Regset.add_1; auto. - elim (H r); auto. - rewrite H1. apply H2. - case (Reg.eq arg r); intro. subst r. apply Regset.add_1; auto. - apply Regset.add_2. apply Regset.remove_2. auto. auto. - eapply regalloc_noteq_diff; eauto. - eapply regalloc_not_temporary; eauto. + destruct (Reg.eq r arg). + subst r. + replace (Locmap.set (assign res) (ls (assign arg)) ls (assign arg)) + with (ls (assign arg)). + apply H0. apply Regset.add_1. auto. + symmetry. destruct (Loc.eq (assign arg) (assign res)). + rewrite <- e. apply Locmap.gss. + apply Locmap.gso. eapply regalloc_noteq_diff; eauto. + + rewrite Locmap.gso. apply H0. apply Regset.add_2. apply Regset.remove_2. auto. auto. + eapply regalloc_noteq_diff; eauto. apply sym_not_equal. apply H; auto. +Qed. + +(** Yet another special case corresponding to the case of + a redundant move. *) + +Lemma agree_redundant_move_live: + forall live arg res rs (ls: locset), + (forall r, + Regset.In r live -> r <> res -> r <> arg -> + assign r <> assign res) -> + agree (reg_live arg (reg_dead res live)) rs ls -> + assign res = assign arg -> + agree live (rs#res <- (rs#arg)) ls. +Proof. + intros. + apply agree_exten with (Locmap.set (assign res) (ls (assign arg)) ls). + eapply agree_move_live; eauto. + intros. symmetry. rewrite H1. destruct (Loc.eq l (assign arg)). + subst l. apply Locmap.gss. + apply Locmap.gso. eapply regalloc_noteq_diff; eauto. Qed. (** This complicated lemma states agreement between the states after @@ -384,7 +409,7 @@ Lemma agree_call: ~(In (assign r) Conventions.destroyed_at_call)) -> (forall r, Regset.In r live -> r <> res -> assign r <> assign res) -> - ls' (assign res) = v -> + Val.lessdef v (ls' (assign res)) -> (forall l, Loc.notin l destroyed_at_call -> loc_acceptable l -> Loc.diff l (assign res) -> ls' l = ls l) -> @@ -413,757 +438,33 @@ Lemma agree_init_regs: (forall r1 r2, In r1 rl -> Regset.In r2 live -> r1 <> r2 -> assign r1 <> assign r2) -> - List.map ls (List.map assign rl) = vl -> - agree (reg_list_dead rl live) (Regmap.init Vundef) ls -> + Val.lessdef_list vl (List.map ls (List.map assign rl)) -> agree live (init_regs vl rl) ls. Proof. induction rl; simpl; intros. - assumption. - destruct vl. discriminate. - assert (agree (reg_dead a live) (init_regs vl rl) ls). - apply IHrl. intros. apply H. tauto. - eapply Regset.remove_3; eauto. - auto. congruence. assumption. + red; intros. rewrite Regmap.gi. auto. + inv H0. + assert (agree live (init_regs vl1 rl) ls). + apply IHrl. intros. apply H. tauto. auto. auto. auto. red; intros. case (Reg.eq a r); intro. - subst r. rewrite Regmap.gss. congruence. - rewrite Regmap.gso; auto. apply H2. - apply Regset.remove_2; auto. + subst r. rewrite Regmap.gss. auto. + rewrite Regmap.gso; auto. Qed. Lemma agree_parameters: forall vl ls, let params := f.(RTL.fn_params) in - List.map ls (List.map assign params) = vl -> - (forall r, - Regset.In r (reg_list_dead params (live0 f flive)) -> - ls (assign r) = Vundef) -> - agree (live0 f flive) (init_regs vl params) ls. + Val.lessdef_list vl (List.map ls (List.map assign params)) -> + agree (live0 f flive) + (init_regs vl params) + ls. Proof. intros. apply agree_init_regs. intros. eapply regalloc_correct_3; eauto. - assumption. - red; intros. rewrite Regmap.gi. auto. -Qed. - -End AGREE. - -(** * Correctness of the LTL constructors *) - -(** This section proves theorems that establish the correctness of the - LTL constructor functions such as [add_op]. The theorems are of - the general form ``the generated LTL instructions execute and - modify the location set in the expected way: the result location(s) - contain the expected values and other, non-temporary locations keep - their values''. *) - -Section LTL_CONSTRUCTORS. - -Variable ge: LTL.genv. -Variable sp: val. - -Lemma reg_for_spec: - forall l, - R(reg_for l) = l \/ In (R (reg_for l)) temporaries. -Proof. - intros. unfold reg_for. destruct l. tauto. - case (slot_type s); simpl; tauto. -Qed. - -Lemma add_reload_correct: - forall src dst k rs m, - exists rs', - exec_instrs ge sp (add_reload src dst k) rs m E0 k rs' m /\ - rs' (R dst) = rs src /\ - forall l, Loc.diff (R dst) l -> rs' l = rs l. -Proof. - intros. unfold add_reload. destruct src. - case (mreg_eq m0 dst); intro. - subst dst. exists rs. split. apply exec_refl. tauto. - exists (Locmap.set (R dst) (rs (R m0)) rs). - split. apply exec_one; apply exec_Bop. reflexivity. - split. apply Locmap.gss. - intros; apply Locmap.gso; auto. - exists (Locmap.set (R dst) (rs (S s)) rs). - split. apply exec_one; apply exec_Bgetstack. - split. apply Locmap.gss. - intros; apply Locmap.gso; auto. -Qed. - -Lemma add_spill_correct: - forall src dst k rs m, - exists rs', - exec_instrs ge sp (add_spill src dst k) rs m E0 k rs' m /\ - rs' dst = rs (R src) /\ - forall l, Loc.diff dst l -> rs' l = rs l. -Proof. - intros. unfold add_spill. destruct dst. - case (mreg_eq src m0); intro. - subst src. exists rs. split. apply exec_refl. tauto. - exists (Locmap.set (R m0) (rs (R src)) rs). - split. apply exec_one. apply exec_Bop. reflexivity. - split. apply Locmap.gss. - intros; apply Locmap.gso; auto. - exists (Locmap.set (S s) (rs (R src)) rs). - split. apply exec_one. apply exec_Bsetstack. - split. apply Locmap.gss. - intros; apply Locmap.gso; auto. -Qed. - -Lemma add_reloads_correct_rec: - forall srcs itmps ftmps k rs m, - (List.length srcs <= List.length itmps)%nat -> - (List.length srcs <= List.length ftmps)%nat -> - (forall r, In (R r) srcs -> In r itmps -> False) -> - (forall r, In (R r) srcs -> In r ftmps -> False) -> - list_disjoint itmps ftmps -> - list_norepet itmps -> - list_norepet ftmps -> - exists rs', - exec_instrs ge sp (add_reloads srcs (regs_for_rec srcs itmps ftmps) k) rs m E0 k rs' m /\ - reglist (regs_for_rec srcs itmps ftmps) rs' = map rs srcs /\ - (forall r, ~(In r itmps) -> ~(In r ftmps) -> rs' (R r) = rs (R r)) /\ - (forall s, rs' (S s) = rs (S s)). -Proof. - induction srcs; simpl; intros. - (* base case *) - exists rs. split. apply exec_refl. tauto. - (* inductive case *) - destruct itmps; simpl in H. omegaContradiction. - destruct ftmps; simpl in H0. omegaContradiction. - assert (R1: (length srcs <= length itmps)%nat). omega. - assert (R2: (length srcs <= length ftmps)%nat). omega. - assert (R3: forall r, In (R r) srcs -> In r itmps -> False). - intros. apply H1 with r. tauto. auto with coqlib. - assert (R4: forall r, In (R r) srcs -> In r ftmps -> False). - intros. apply H2 with r. tauto. auto with coqlib. - assert (R5: list_disjoint itmps ftmps). - eapply list_disjoint_cons_left. - eapply list_disjoint_cons_right. eauto. - assert (R6: list_norepet itmps). - inversion H4; auto. - assert (R7: list_norepet ftmps). - inversion H5; auto. - destruct a. - (* a is a register *) - generalize (IHsrcs itmps ftmps k rs m R1 R2 R3 R4 R5 R6 R7). - intros [rs' [EX [RES [OTH1 OTH2]]]]. - exists rs'. split. - unfold add_reload. case (mreg_eq m2 m2); intro; tauto. - split. simpl. apply (f_equal2 (@cons val)). - apply OTH1. - red; intro; apply H1 with m2. tauto. auto with coqlib. - red; intro; apply H2 with m2. tauto. auto with coqlib. - assumption. - split. intros. apply OTH1. simpl in H6; tauto. simpl in H7; tauto. - auto. - (* a is a stack location *) - set (tmp := match slot_type s with Tint => m0 | Tfloat => m1 end). - assert (NI: ~(In tmp itmps)). - unfold tmp; case (slot_type s). - inversion H4; auto. - apply list_disjoint_notin with (m1 :: ftmps). - apply list_disjoint_sym. apply list_disjoint_cons_left with m0. - auto. auto with coqlib. - assert (NF: ~(In tmp ftmps)). - unfold tmp; case (slot_type s). - apply list_disjoint_notin with (m0 :: itmps). - apply list_disjoint_cons_right with m1. - auto. auto with coqlib. - inversion H5; auto. - generalize - (add_reload_correct (S s) tmp - (add_reloads srcs (regs_for_rec srcs itmps ftmps) k) rs m). - intros [rs1 [EX1 [RES1 OTH]]]. - generalize (IHsrcs itmps ftmps k rs1 m R1 R2 R3 R4 R5 R6 R7). - intros [rs' [EX [RES [OTH1 OTH2]]]]. - exists rs'. - split. eapply exec_trans; eauto. traceEq. - split. simpl. apply (f_equal2 (@cons val)). - rewrite OTH1; auto. - rewrite RES. apply list_map_exten. intros. - symmetry. apply OTH. - destruct x; try exact I. simpl. red; intro; subst m2. - generalize H6; unfold tmp. case (slot_type s). - intro. apply H1 with m0. tauto. auto with coqlib. - intro. apply H2 with m1. tauto. auto with coqlib. - split. intros. simpl in H6; simpl in H7. - rewrite OTH1. apply OTH. - simpl. unfold tmp. case (slot_type s); tauto. - tauto. tauto. - intros. rewrite OTH2. apply OTH. exact I. -Qed. - -Lemma add_reloads_correct: - forall srcs k rs m, - (List.length srcs <= 3)%nat -> - Loc.disjoint srcs temporaries -> - exists rs', - exec_instrs ge sp (add_reloads srcs (regs_for srcs) k) rs m E0 k rs' m /\ - reglist (regs_for srcs) rs' = List.map rs srcs /\ - forall l, Loc.notin l temporaries -> rs' l = rs l. -Proof. - intros. - pose (itmps := IT1 :: IT2 :: IT3 :: nil). - pose (ftmps := FT1 :: FT2 :: FT3 :: nil). - assert (R1: (List.length srcs <= List.length itmps)%nat). - unfold itmps; simpl; assumption. - assert (R2: (List.length srcs <= List.length ftmps)%nat). - unfold ftmps; simpl; assumption. - assert (R3: forall r, In (R r) srcs -> In r itmps -> False). - intros. assert (In (R r) temporaries). - simpl in H2; simpl; intuition congruence. - generalize (H0 _ _ H1 H3). simpl. tauto. - assert (R4: forall r, In (R r) srcs -> In r ftmps -> False). - intros. assert (In (R r) temporaries). - simpl in H2; simpl; intuition congruence. - generalize (H0 _ _ H1 H3). simpl. tauto. - assert (R5: list_disjoint itmps ftmps). - red; intros r1 r2; simpl; intuition congruence. - assert (R6: list_norepet itmps). - unfold itmps. NoRepet. - assert (R7: list_norepet ftmps). - unfold ftmps. NoRepet. - generalize (add_reloads_correct_rec srcs itmps ftmps k rs m - R1 R2 R3 R4 R5 R6 R7). - intros [rs' [EX [RES [OTH1 OTH2]]]]. - exists rs'. split. exact EX. - split. exact RES. - intros. destruct l. apply OTH1. - generalize (Loc.notin_not_in _ _ H1). simpl. intuition congruence. - generalize (Loc.notin_not_in _ _ H1). simpl. intuition congruence. - apply OTH2. -Qed. - -Lemma add_move_correct: - forall src dst k rs m, - exists rs', - exec_instrs ge sp (add_move src dst k) rs m E0 k rs' m /\ - rs' dst = rs src /\ - forall l, Loc.diff l dst -> Loc.diff l (R IT1) -> Loc.diff l (R FT1) -> rs' l = rs l. -Proof. - intros; unfold add_move. - case (Loc.eq src dst); intro. - subst dst. exists rs. split. apply exec_refl. tauto. - destruct src. - (* src is a register *) - generalize (add_spill_correct m0 dst k rs m); intros [rs' [EX [RES OTH]]]. - exists rs'; intuition. apply OTH; apply Loc.diff_sym; auto. - destruct dst. - (* src is a stack slot, dst a register *) - generalize (add_reload_correct (S s) m0 k rs m); intros [rs' [EX [RES OTH]]]. - exists rs'; intuition. apply OTH; apply Loc.diff_sym; auto. - (* src and dst are stack slots *) - set (tmp := match slot_type s with Tint => IT1 | Tfloat => FT1 end). - generalize (add_reload_correct (S s) tmp (add_spill tmp (S s0) k) rs m); - intros [rs1 [EX1 [RES1 OTH1]]]. - generalize (add_spill_correct tmp (S s0) k rs1 m); - intros [rs2 [EX2 [RES2 OTH2]]]. - exists rs2. split. - eapply exec_trans; eauto. traceEq. - split. congruence. - intros. rewrite OTH2. apply OTH1. - apply Loc.diff_sym. unfold tmp; case (slot_type s); auto. - apply Loc.diff_sym; auto. -Qed. - -Lemma effect_move_sequence: - forall k moves rs m, - let k' := List.fold_right (fun p k => add_move (fst p) (snd p) k) k moves in - exists rs', - exec_instrs ge sp k' rs m E0 k rs' m /\ - effect_seqmove moves rs rs'. -Proof. - induction moves; intros until m; simpl. - exists rs; split. constructor. constructor. - destruct a as [src dst]; simpl. - set (k1 := fold_right - (fun (p : loc * loc) (k : block) => add_move (fst p) (snd p) k) - k moves) in *. - destruct (add_move_correct src dst k1 rs m) as [rs1 [A [B C]]]. - destruct (IHmoves rs1 m) as [rs' [D E]]. - exists rs'; split. - eapply exec_trans; eauto. traceEq. - econstructor; eauto. red. tauto. -Qed. - -Theorem parallel_move_correct: - forall srcs dsts k rs m, - List.length srcs = List.length dsts -> - Loc.no_overlap srcs dsts -> - Loc.norepet dsts -> - Loc.disjoint srcs temporaries -> - Loc.disjoint dsts temporaries -> - exists rs', - exec_instrs ge sp (parallel_move srcs dsts k) rs m E0 k rs' m /\ - List.map rs' dsts = List.map rs srcs /\ - rs' (R IT3) = rs (R IT3) /\ - forall l, Loc.notin l dsts -> Loc.notin l temporaries -> rs' l = rs l. -Proof. - intros. - generalize (effect_move_sequence k (parmove srcs dsts) rs m). - intros [rs' [EXEC EFFECT]]. - exists rs'. split. exact EXEC. - apply effect_parmove; auto. -Qed. - -Lemma add_op_correct: - forall op args res s rs m v, - (List.length args <= 3)%nat -> - Loc.disjoint args temporaries -> - eval_operation ge sp op (List.map rs args) = Some v -> - exists rs', - exec_block ge sp (add_op op args res s) rs m E0 (Cont s) rs' m /\ - rs' res = v /\ - forall l, Loc.diff l res -> Loc.notin l temporaries -> rs' l = rs l. -Proof. - intros. unfold add_op. - caseEq (is_move_operation op args). - (* move *) - intros arg IMO. - generalize (is_move_operation_correct op args IMO). - intros [EQ1 EQ2]. subst op; subst args. - generalize (add_move_correct arg res (Bgoto s) rs m). - intros [rs' [EX [RES OTHER]]]. - exists rs'. split. - apply exec_Bgoto. exact EX. - split. simpl in H1. congruence. - intros. unfold temporaries in H3; simpl in H3. - apply OTHER. assumption. tauto. tauto. - (* other ops *) - intros. - set (rargs := regs_for args). set (rres := reg_for res). - generalize (add_reloads_correct args - (Bop op rargs rres (add_spill rres res (Bgoto s))) - rs m H H0). - intros [rs1 [EX1 [RES1 OTHER1]]]. - pose (rs2 := Locmap.set (R rres) v rs1). - generalize (add_spill_correct rres res (Bgoto s) rs2 m). - intros [rs3 [EX3 [RES3 OTHER3]]]. - exists rs3. - split. apply exec_Bgoto. eapply exec_trans. eexact EX1. - eapply exec_trans; eauto. - apply exec_one. unfold rs2. apply exec_Bop. - unfold rargs. rewrite RES1. auto. traceEq. - split. rewrite RES3. unfold rs2; apply Locmap.gss. - intros. rewrite OTHER3. unfold rs2. rewrite Locmap.gso. - apply OTHER1. assumption. - apply Loc.diff_sym. unfold rres. elim (reg_for_spec res); intro. - rewrite H5; auto. - eapply Loc.in_notin_diff; eauto. apply Loc.diff_sym; auto. -Qed. - -Lemma add_load_correct: - forall chunk addr args res s rs m a v, - (List.length args <= 2)%nat -> - Loc.disjoint args temporaries -> - eval_addressing ge sp addr (List.map rs args) = Some a -> - loadv chunk m a = Some v -> - exists rs', - exec_block ge sp (add_load chunk addr args res s) rs m E0 (Cont s) rs' m /\ - rs' res = v /\ - forall l, Loc.diff l res -> Loc.notin l temporaries -> rs' l = rs l. -Proof. - intros. unfold add_load. - set (rargs := regs_for args). set (rres := reg_for res). - assert (LL: (List.length args <= 3)%nat). omega. - generalize (add_reloads_correct args - (Bload chunk addr rargs rres (add_spill rres res (Bgoto s))) - rs m LL H0). - intros [rs1 [EX1 [RES1 OTHER1]]]. - pose (rs2 := Locmap.set (R rres) v rs1). - generalize (add_spill_correct rres res (Bgoto s) rs2 m). - intros [rs3 [EX3 [RES3 OTHER3]]]. - exists rs3. - split. apply exec_Bgoto. eapply exec_trans; eauto. - eapply exec_trans; eauto. - apply exec_one. unfold rs2. apply exec_Bload with a. - unfold rargs; rewrite RES1. assumption. assumption. traceEq. - split. rewrite RES3. unfold rs2; apply Locmap.gss. - intros. rewrite OTHER3. unfold rs2. rewrite Locmap.gso. - apply OTHER1. assumption. - apply Loc.diff_sym. unfold rres. elim (reg_for_spec res); intro. - rewrite H5; auto. - eapply Loc.in_notin_diff; eauto. apply Loc.diff_sym; auto. -Qed. - -Lemma add_store_correct: - forall chunk addr args src s rs m m' a, - (List.length args <= 2)%nat -> - Loc.disjoint args temporaries -> - Loc.notin src temporaries -> - eval_addressing ge sp addr (List.map rs args) = Some a -> - storev chunk m a (rs src) = Some m' -> - exists rs', - exec_block ge sp (add_store chunk addr args src s) rs m E0 (Cont s) rs' m' /\ - forall l, Loc.notin l temporaries -> rs' l = rs l. -Proof. - intros. - assert (LL: (List.length (src :: args) <= 3)%nat). - simpl. omega. - assert (DISJ: Loc.disjoint (src :: args) temporaries). - red; intros. elim H4; intro. subst x1. - eapply Loc.in_notin_diff; eauto. - auto with coqlib. - unfold add_store. caseEq (regs_for (src :: args)). - unfold regs_for; simpl; intro; discriminate. - intros rsrc rargs EQ. - generalize (add_reloads_correct (src :: args) - (Bstore chunk addr rargs rsrc (Bgoto s)) - rs m LL DISJ). - intros [rs1 [EX1 [RES1 OTHER1]]]. - rewrite EQ in RES1. simpl in RES1. injection RES1. - intros RES2 RES3. - exists rs1. - split. apply exec_Bgoto. - eapply exec_trans. rewrite <- EQ. eexact EX1. - apply exec_one. apply exec_Bstore with a. - rewrite RES2. assumption. rewrite RES3. assumption. traceEq. - exact OTHER1. -Qed. - -Lemma add_alloc_correct: - forall arg res s rs m m' sz b, - rs arg = Vint sz -> - Mem.alloc m 0 (Int.signed sz) = (m', b) -> - exists rs', - exec_block ge sp (add_alloc arg res s) rs m E0 (Cont s) rs' m' /\ - rs' res = Vptr b Int.zero /\ - forall l, - Loc.diff l (R Conventions.loc_alloc_argument) -> - Loc.diff l (R Conventions.loc_alloc_result) -> - Loc.diff l res -> - rs' l = rs l. -Proof. - intros; unfold add_alloc. - generalize (add_reload_correct arg loc_alloc_argument - (Balloc (add_spill loc_alloc_result res (Bgoto s))) - rs m). - intros [rs1 [EX1 [RES1 OTHER1]]]. - pose (rs2 := Locmap.set (R loc_alloc_result) (Vptr b Int.zero) rs1). - generalize (add_spill_correct loc_alloc_result res (Bgoto s) rs2 m'). - intros [rs3 [EX3 [RES3 OTHER3]]]. - exists rs3. - split. apply exec_Bgoto. eapply exec_trans. eexact EX1. - eapply exec_trans. apply exec_one. eapply exec_Balloc; eauto. congruence. - fold rs2. eexact EX3. reflexivity. traceEq. - split. rewrite RES3; unfold rs2. apply Locmap.gss. - intros. rewrite OTHER3. unfold rs2. rewrite Locmap.gso. - apply OTHER1. apply Loc.diff_sym; auto. - apply Loc.diff_sym; auto. - apply Loc.diff_sym; auto. -Qed. - -Lemma add_cond_correct: - forall cond args ifso ifnot rs m b s, - (List.length args <= 3)%nat -> - Loc.disjoint args temporaries -> - eval_condition cond (List.map rs args) = Some b -> - s = (if b then ifso else ifnot) -> - exists rs', - exec_block ge sp (add_cond cond args ifso ifnot) rs m E0 (Cont s) rs' m /\ - forall l, Loc.notin l temporaries -> rs' l = rs l. -Proof. - intros. unfold add_cond. - set (rargs := regs_for args). - generalize (add_reloads_correct args - (Bcond cond rargs ifso ifnot) - rs m H H0). - intros [rs1 [EX1 [RES1 OTHER1]]]. - fold rargs in EX1. - exists rs1. - split. destruct b; subst s. - eapply exec_Bcond_true. eexact EX1. - unfold rargs; rewrite RES1. assumption. - eapply exec_Bcond_false. eexact EX1. - unfold rargs; rewrite RES1. assumption. - exact OTHER1. -Qed. - -Definition find_function2 (los: loc + ident) (ls: locset) : option fundef := - match los with - | inl l => Genv.find_funct ge (ls l) - | inr symb => - match Genv.find_symbol ge symb with - | None => None - | Some b => Genv.find_funct_ptr ge b - end - end. - -Lemma add_call_correct: - forall f vargs m t vres m' sig los args res s ls - (EXECF: - forall lsi, - List.map lsi (loc_arguments (funsig f)) = vargs -> - exists lso, - exec_function ge f lsi m t lso m' - /\ lso (R (loc_result (funsig f))) = vres) - (FIND: find_function2 los ls = Some f) - (SIG: sig = funsig f) - (VARGS: List.map ls args = vargs) - (LARGS: List.length args = List.length sig.(sig_args)) - (AARGS: locs_acceptable args) - (RES: loc_acceptable res), - exists ls', - exec_block ge sp (add_call sig los args res s) ls m t (Cont s) ls' m' /\ - ls' res = vres /\ - forall l, - Loc.notin l destroyed_at_call -> loc_acceptable l -> Loc.diff l res -> - ls' l = ls l. -Proof. - intros until los. - case los; intro fn; intros; simpl in FIND; rewrite <- SIG in EXECF; unfold add_call. - (* indirect call *) - assert (LEN: List.length args = List.length (loc_arguments sig)). - rewrite LARGS. symmetry. apply loc_arguments_length. - pose (DISJ := locs_acceptable_disj_temporaries args AARGS). - generalize (add_reload_correct fn IT3 - (parallel_move args (loc_arguments sig) - (Bcall sig (inl ident IT3) - (add_spill (loc_result sig) res (Bgoto s)))) - ls m). - intros [ls1 [EX1 [RES1 OTHER1]]]. - generalize - (parallel_move_correct args (loc_arguments sig) - (Bcall sig (inl ident IT3) - (add_spill (loc_result sig) res (Bgoto s))) - ls1 m LEN - (no_overlap_arguments args sig AARGS) - (loc_arguments_norepet sig) - DISJ - (loc_arguments_not_temporaries sig)). - intros [ls2 [EX2 [RES2 [TMP2 OTHER2]]]]. - assert (PARAMS: List.map ls2 (loc_arguments sig) = vargs). - rewrite <- VARGS. rewrite RES2. - apply list_map_exten. intros. symmetry. apply OTHER1. - apply Loc.diff_sym. apply DISJ. auto. simpl; tauto. - generalize (EXECF ls2 PARAMS). - intros [ls3 [EX3 RES3]]. - pose (ls4 := return_regs ls2 ls3). - generalize (add_spill_correct (loc_result sig) res - (Bgoto s) ls4 m'). - intros [ls5 [EX5 [RES5 OTHER5]]]. - exists ls5. - (* Execution *) - split. apply exec_Bgoto. - eapply exec_trans. eexact EX1. - eapply exec_trans. eexact EX2. - eapply exec_trans. apply exec_one. apply exec_Bcall with f. - unfold find_function. rewrite TMP2. rewrite RES1. - assumption. assumption. eexact EX3. - eexact EX5. reflexivity. reflexivity. traceEq. - (* Result *) - split. rewrite RES5. unfold ls4. rewrite return_regs_result. - assumption. - (* Other regs *) - intros. rewrite OTHER5; auto. - unfold ls4; rewrite return_regs_not_destroyed; auto. - rewrite OTHER2. apply OTHER1. - apply Loc.diff_sym. apply Loc.in_notin_diff with temporaries. - apply temporaries_not_acceptable; auto. simpl; tauto. - apply arguments_not_preserved; auto. - apply temporaries_not_acceptable; auto. - apply Loc.diff_sym; auto. - (* direct call *) - assert (LEN: List.length args = List.length (loc_arguments sig)). - rewrite LARGS. symmetry. apply loc_arguments_length. - pose (DISJ := locs_acceptable_disj_temporaries args AARGS). - generalize - (parallel_move_correct args (loc_arguments sig) - (Bcall sig (inr mreg fn) - (add_spill (loc_result sig) res (Bgoto s))) - ls m LEN - (no_overlap_arguments args sig AARGS) - (loc_arguments_norepet sig) - DISJ (loc_arguments_not_temporaries sig)). - intros [ls2 [EX2 [RES2 [TMP2 OTHER2]]]]. - assert (PARAMS: List.map ls2 (loc_arguments sig) = vargs). - rewrite <- VARGS. rewrite RES2. auto. - generalize (EXECF ls2 PARAMS). - intros [ls3 [EX3 RES3]]. - pose (ls4 := return_regs ls2 ls3). - generalize (add_spill_correct (loc_result sig) res - (Bgoto s) ls4 m'). - intros [ls5 [EX5 [RES5 OTHER5]]]. - exists ls5. - (* Execution *) - split. apply exec_Bgoto. - eapply exec_trans. eexact EX2. - eapply exec_trans. apply exec_one. apply exec_Bcall with f. - unfold find_function. assumption. assumption. eexact EX3. - eexact EX5. reflexivity. traceEq. - (* Result *) - split. rewrite RES5. - unfold ls4. rewrite return_regs_result. - assumption. - (* Other regs *) - intros. rewrite OTHER5; auto. - unfold ls4; rewrite return_regs_not_destroyed; auto. - apply OTHER2. - apply arguments_not_preserved; auto. - apply temporaries_not_acceptable; auto. - apply Loc.diff_sym; auto. -Qed. - -Lemma add_undefs_correct: - forall res b ls m, - (forall l, In l res -> loc_acceptable l) -> - (forall ofs ty, In (S (Local ofs ty)) res -> ls (S (Local ofs ty)) = Vundef) -> - exists ls', - exec_instrs ge sp (add_undefs res b) ls m E0 b ls' m /\ - (forall l, In l res -> ls' l = Vundef) /\ - (forall l, Loc.notin l res -> ls' l = ls l). -Proof. - induction res; simpl; intros. - exists ls. split. apply exec_refl. tauto. - assert (ACC: forall l, In l res -> loc_acceptable l). - intros. apply H. tauto. - destruct a. - (* a is a register *) - pose (ls1 := Locmap.set (R m0) Vundef ls). - assert (UNDEFS: forall ofs ty, In (S (Local ofs ty)) res -> ls1 (S (Local ofs ty)) = Vundef). - intros. unfold ls1; rewrite Locmap.gso. auto. red; auto. - generalize (IHres b (Locmap.set (R m0) Vundef ls) m ACC UNDEFS). - intros [ls2 [EX2 [RES2 OTHER2]]]. - exists ls2. split. - eapply exec_trans. apply exec_one. apply exec_Bop. - simpl; reflexivity. eexact EX2. traceEq. - split. intros. case (In_dec Loc.eq l res); intro. - apply RES2; auto. - rewrite OTHER2. elim H1; intro. - subst l. apply Locmap.gss. - contradiction. - apply loc_acceptable_notin_notin; auto. - intros. rewrite OTHER2. apply Locmap.gso. - apply Loc.diff_sym; tauto. tauto. - (* a is a stack location *) - assert (UNDEFS: forall ofs ty, In (S (Local ofs ty)) res -> ls (S (Local ofs ty)) = Vundef). - intros. apply H0. tauto. - generalize (IHres b ls m ACC UNDEFS). - intros [ls2 [EX2 [RES2 OTHER2]]]. - exists ls2. split. assumption. - split. intros. case (In_dec Loc.eq l res); intro. auto. - rewrite OTHER2. elim H1; intro. - subst l. generalize (H (S s) (in_eq _ _)). - unfold loc_acceptable; destruct s; intuition auto. - contradiction. - apply loc_acceptable_notin_notin; auto. - intros. apply OTHER2. tauto. -Qed. - -Lemma add_entry_correct: - forall sig params undefs s ls m, - List.length params = List.length sig.(sig_args) -> - Loc.norepet params -> - locs_acceptable params -> - Loc.disjoint params undefs -> - locs_acceptable undefs -> - (forall ofs ty, ls (S (Local ofs ty)) = Vundef) -> - exists ls', - exec_block ge sp (add_entry sig params undefs s) ls m E0 (Cont s) ls' m /\ - List.map ls' params = List.map ls (loc_parameters sig) /\ - (forall l, In l undefs -> ls' l = Vundef). -Proof. - intros. - assert (List.length (loc_parameters sig) = List.length params). - unfold loc_parameters. rewrite list_length_map. - rewrite loc_arguments_length. auto. - assert (DISJ: Loc.disjoint params temporaries). - apply locs_acceptable_disj_temporaries; auto. - generalize (parallel_move_correct _ _ (add_undefs undefs (Bgoto s)) - ls m H5 - (no_overlap_parameters _ _ H1) - H0 (loc_parameters_not_temporaries sig) DISJ). - intros [ls1 [EX1 [RES1 [TMP1 OTHER1]]]]. - assert (forall ofs ty, In (S (Local ofs ty)) undefs -> ls1 (S (Local ofs ty)) = Vundef). - intros. rewrite OTHER1. auto. apply Loc.disjoint_notin with undefs. - apply Loc.disjoint_sym. auto. auto. - simpl; tauto. - generalize (add_undefs_correct undefs (Bgoto s) ls1 m H3 H6). - intros [ls2 [EX2 [RES2 OTHER2]]]. - exists ls2. - split. apply exec_Bgoto. unfold add_entry. - eapply exec_trans. eexact EX1. eexact EX2. traceEq. - split. rewrite <- RES1. apply list_map_exten. - intros. symmetry. apply OTHER2. eapply Loc.disjoint_notin; eauto. - exact RES2. -Qed. - -Lemma add_return_correct: - forall sig optarg ls m, - exists ls', - exec_block ge sp (add_return sig optarg) ls m E0 Return ls' m /\ - match optarg with - | Some arg => ls' (R (loc_result sig)) = ls arg - | None => ls' (R (loc_result sig)) = Vundef - end. -Proof. - intros. unfold add_return. - destruct optarg. - generalize (add_reload_correct l (loc_result sig) Breturn ls m). - intros [ls1 [EX1 [RES1 OTH1]]]. - exists ls1. - split. apply exec_Breturn. assumption. assumption. - exists (Locmap.set (R (loc_result sig)) Vundef ls). - split. apply exec_Breturn. apply exec_one. - apply exec_Bop. reflexivity. apply Locmap.gss. -Qed. - -End LTL_CONSTRUCTORS. - -(** * Exploitation of the typing hypothesis *) - -(** Register allocation is applied to RTL code that passed type inference - (see file [RTLtyping]), and therefore is well-typed in the type system - of [RTLtyping]. We exploit this hypothesis to obtain information on - the number of arguments to operations, addressing modes and conditions. *) - -Remark length_type_of_condition: - forall (c: condition), (List.length (type_of_condition c) <= 3)%nat. -Proof. - destruct c; unfold type_of_condition; simpl; omega. -Qed. - -Remark length_type_of_operation: - forall (op: operation), (List.length (fst (type_of_operation op)) <= 3)%nat. -Proof. - destruct op; unfold type_of_operation; simpl; try omega. - apply length_type_of_condition. -Qed. - -Remark length_type_of_addressing: - forall (addr: addressing), (List.length (type_of_addressing addr) <= 2)%nat. -Proof. - destruct addr; unfold type_of_addressing; simpl; omega. Qed. -Lemma length_op_args: - forall (env: regenv) (op: operation) (args: list reg) (res: reg), - (List.map env args, env res) = type_of_operation op -> - (List.length args <= 3)%nat. -Proof. - intros. rewrite <- (list_length_map env). - generalize (length_type_of_operation op). - rewrite <- H. simpl. auto. -Qed. - -Lemma length_addr_args: - forall (env: regenv) (addr: addressing) (args: list reg), - List.map env args = type_of_addressing addr -> - (List.length args <= 2)%nat. -Proof. - intros. rewrite <- (list_length_map env). - rewrite H. apply length_type_of_addressing. -Qed. - -Lemma length_cond_args: - forall (env: regenv) (cond: condition) (args: list reg), - List.map env args = type_of_condition cond -> - (List.length args <= 3)%nat. -Proof. - intros. rewrite <- (list_length_map env). - rewrite H. apply length_type_of_condition. -Qed. +End AGREE. (** * Preservation of semantics *) @@ -1176,7 +477,7 @@ Section PRESERVATION. Variable prog: RTL.program. Variable tprog: LTL.program. -Hypothesis TRANSF: transf_program prog = Some tprog. +Hypothesis TRANSF: transf_program prog = OK tprog. Let ge := Genv.globalenv prog. Let tge := Genv.globalenv tprog. @@ -1193,740 +494,460 @@ 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 = Some tf. -Proof. - intros. - generalize - (Genv.find_funct_transf_partial transf_fundef TRANSF H). - case (transf_fundef f). - intros tf [A B]. exists tf. tauto. - intros [A B]. elim B. reflexivity. -Qed. + Genv.find_funct tge v = Some tf /\ transf_fundef f = OK tf. +Proof (Genv.find_funct_transf_partial transf_fundef TRANSF). Lemma function_ptr_translated: - forall (b: Values.block) (f: RTL.fundef), + 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 = Some tf. -Proof. - intros. - generalize - (Genv.find_funct_ptr_transf_partial transf_fundef TRANSF H). - case (transf_fundef f). - intros tf [A B]. exists tf. tauto. - intros [A B]. elim B. reflexivity. -Qed. + Genv.find_funct_ptr tge b = Some tf /\ transf_fundef f = OK tf. +Proof (Genv.find_funct_ptr_transf_partial transf_fundef TRANSF). Lemma sig_function_translated: forall f tf, - transf_fundef f = Some tf -> + transf_fundef f = OK tf -> LTL.funsig tf = RTL.funsig f. Proof. - intros f tf. destruct f; simpl. + intros f tf. destruct f; simpl. unfold transf_function. destruct (type_function f). destruct (analyze f). - destruct (regalloc f t). - intro EQ; injection EQ; intro EQ1; rewrite <- EQ1; simpl; auto. - congruence. congruence. congruence. - intro EQ; inversion EQ; subst tf. reflexivity. -Qed. - -Lemma entrypoint_function_translated: - forall f tf, - transf_function f = Some tf -> - tf.(LTL.fn_entrypoint) = f.(RTL.fn_nextpc). -Proof. - intros f tf. unfold transf_function. - destruct (type_function f). - destruct (analyze f). - destruct (regalloc f t). - intro EQ; injection EQ; intro EQ1; rewrite <- EQ1; simpl; auto. - intros; discriminate. - intros; discriminate. - intros; discriminate. + destruct (regalloc f t). + intro. monadInv H. inv EQ. auto. + simpl; congruence. simpl; congruence. simpl; congruence. + intro EQ; inv EQ. auto. Qed. (** The proof of semantic preservation is a simulation argument based on diagrams of the following form: << - pc, rs, m ------------------- pc, ls, m - | | - | | - v v - pc', rs', m' ---------------- Cont pc', ls', m' + st1 --------------- st2 + | | + t| |t + | | + v v + st1'--------------- st2' >> Hypotheses: the left vertical arrow represents a transition in the - original RTL code. The top horizontal bar expresses agreement between - [rs] and [ls] over the pseudo-registers live before the RTL instruction - at [pc]. + original RTL code. The top horizontal bar is the [match_states] + relation defined below. It implies agreement between + the RTL register map [rs] and the LTL location map [ls] + over the pseudo-registers live before the RTL instruction at [pc]. - Conclusions: the right vertical arrow is an [exec_blocks] transition + Conclusions: the right vertical arrow is an [exec_instrs] transition in the LTL code generated by translation of the current function. - The bottom horizontal bar expresses agreement between [rs'] and [ls'] - over the pseudo-registers live after the RTL instruction at [pc] - (which implies agreement over the pseudo-registers live before - the instruction at [pc']). - - We capture these diagrams in the following propositions parameterized - by the transition in the original RTL code (the left arrow). + The bottom horizontal bar is the [match_states] relation. *) -Definition exec_instr_prop - (c: RTL.code) (sp: val) - (pc: node) (rs: regset) (m: mem) (t: trace) - (pc': node) (rs': regset) (m': mem) : Prop := - forall f env live assign ls - (CF: c = f.(RTL.fn_code)) - (WT: wt_function f env) - (ASG: regalloc f live (live0 f live) env = Some assign) - (AG: agree assign (transfer f pc live!!pc) rs ls), - let tc := PTree.map (transf_instr f live assign) c in - exists ls', - exec_blocks tge tc sp pc ls m t (Cont pc') ls' m' /\ - agree assign live!!pc rs' ls'. - -Definition exec_instrs_prop - (c: RTL.code) (sp: val) - (pc: node) (rs: regset) (m: mem) (t: trace) - (pc': node) (rs': regset) (m': mem) : Prop := - forall f env live assign ls, - forall (CF: c = f.(RTL.fn_code)) - (WT: wt_function f env) - (ANL: analyze f = Some live) - (ASG: regalloc f live (live0 f live) env = Some assign) - (AG: agree assign (transfer f pc live!!pc) rs ls) - (VALIDPC': c!pc' <> None), - let tc := PTree.map (transf_instr f live assign) c in - exists ls', - exec_blocks tge tc sp pc ls m t (Cont pc') ls' m' /\ - agree assign (transfer f pc' live!!pc') rs' ls'. - -Definition exec_function_prop - (f: RTL.fundef) (args: list val) (m: mem) - (t: trace) (res: val) (m': mem) : Prop := - forall ls tf, - transf_fundef f = Some tf -> - List.map ls (Conventions.loc_arguments (funsig tf)) = args -> - exists ls', - LTL.exec_function tge tf ls m t ls' m' /\ - ls' (R (Conventions.loc_result (funsig tf))) = res. - -(** The simulation proof is by structural induction over the RTL evaluation - derivation. We prove each case of the proof as a separate lemma. - There is one lemma for each RTL evaluation rule. Each lemma concludes - one of the [exec_*_prop] predicates, and takes the induction hypotheses - (if any) as hypotheses also expressed with the [exec_*_prop] predicates. -*) +Inductive match_stackframes: list RTL.stackframe -> list LTL.stackframe -> signature -> Prop := + | match_stackframes_nil: forall ty_args, + match_stackframes nil nil (mksignature ty_args (Some Tint)) + | match_stackframes_cons: + forall s ts sig res f sp pc rs ls env live assign, + match_stackframes s ts (RTL.fn_sig f) -> + wt_function f env -> + analyze f = Some live -> + regalloc f live (live0 f live) env = Some assign -> + (forall rv ls1, + (forall l, Loc.notin l destroyed_at_call -> loc_acceptable l -> ls1 l = ls l) -> + Val.lessdef rv (ls1 (R (loc_result sig))) -> + agree assign (transfer f pc live!!pc) + (rs#res <- rv) + (Locmap.set (assign res) (ls1 (R (loc_result sig))) ls1)) -> + match_stackframes + (RTL.Stackframe res (RTL.fn_code f) sp pc rs :: s) + (LTL.Stackframe (assign res) (transf_fun f live assign) sp ls pc :: ts) + sig. + +Inductive match_states: RTL.state -> LTL.state -> Prop := + | match_states_intro: + forall s f sp pc rs m ts ls tm live assign env + (STACKS: match_stackframes s ts (RTL.fn_sig f)) + (WT: wt_function f env) + (ANL: analyze f = Some live) + (ASG: regalloc f live (live0 f live) env = Some assign) + (AG: agree assign (transfer f pc live!!pc) rs ls) + (MMD: Mem.lessdef m tm), + match_states (RTL.State s (RTL.fn_code f) sp pc rs m) + (LTL.State ts (transf_fun f live assign) sp pc ls tm) + | match_states_call: + forall s f args m ts tf ls tm, + match_stackframes s ts (RTL.funsig f) -> + transf_fundef f = OK tf -> + Val.lessdef_list args (List.map ls (loc_arguments (funsig tf))) -> + Mem.lessdef m tm -> + (forall l, Loc.notin l destroyed_at_call -> loc_acceptable l -> ls l = parent_locset ts l) -> + match_states (RTL.Callstate s f args m) + (LTL.Callstate ts tf ls tm) + | match_states_return: + forall s v m ts sig ls tm, + match_stackframes s ts sig -> + Val.lessdef v (ls (R (loc_result sig))) -> + Mem.lessdef m tm -> + (forall l, Loc.notin l destroyed_at_call -> loc_acceptable l -> ls l = parent_locset ts l) -> + match_states (RTL.Returnstate s v m) + (LTL.Returnstate ts sig ls tm). + +Remark match_stackframes_change: + forall s ts sig, + match_stackframes s ts sig -> + forall sig', + sig_res sig' = sig_res sig -> + match_stackframes s ts sig'. +Proof. + induction 1; intros. + destruct sig'. simpl in H; inv H. constructor. + assert (loc_result sig' = loc_result sig). + unfold loc_result. rewrite H4; auto. + econstructor; eauto. + rewrite H5. auto. +Qed. + +(** The simulation proof is by case analysis over the RTL transition + taken in the source program. *) Ltac CleanupHyps := match goal with + | H: (match_states _ _) |- _ => + inv H; CleanupHyps | H1: (PTree.get _ _ = Some _), - H2: (_ = RTL.fn_code _), - H3: (agree _ (transfer _ _ _) _ _) |- _ => - unfold transfer in H3; rewrite <- H2 in H3; rewrite H1 in H3; - simpl in H3; - CleanupHyps + H2: (agree _ (transfer _ _ _) _ _) |- _ => + unfold transfer in H2; rewrite H1 in H2; simpl in H2; CleanupHyps + | _ => idtac + end. + +Ltac WellTypedHyp := + match goal with | H1: (PTree.get _ _ = Some _), - H2: (_ = RTL.fn_code _), - H3: (wt_function _ _) |- _ => - let H := fresh in + H2: (wt_function _ _) |- _ => let R := fresh "WTI" in ( - generalize (wt_instrs _ _ H3); intro H; - rewrite <- H2 in H; generalize (H _ _ H1); - intro R; clear H; clear H3); - CleanupHyps + generalize (wt_instrs _ _ H2 _ _ H1); intro R) | _ => idtac end. -Ltac CleanupGoal := +Ltac TranslInstr := match goal with - | H1: (PTree.get _ _ = Some _) |- _ => - eapply exec_blocks_one; - [rewrite PTree.gmap; rewrite H1; - unfold option_map; unfold transf_instr; reflexivity - |idtac] + | H: (PTree.get _ _ = Some _) |- _ => + simpl; rewrite PTree.gmap; rewrite H; simpl; auto end. -Lemma transl_Inop_correct: - forall (c : PTree.t instruction) (sp: val) (pc : positive) - (rs : regset) (m : mem) (pc' : RTL.node), - c ! pc = Some (Inop pc') -> - exec_instr_prop c sp pc rs m E0 pc' rs m. +Ltac MatchStates := + match goal with + | |- match_states (RTL.State _ _ _ _ _ _) (LTL.State _ _ _ _ _ _) => + eapply match_states_intro; eauto; MatchStates + | H: (PTree.get ?pc _ = Some _) |- agree _ _ _ _ => + eapply agree_succ with (n := pc); eauto; MatchStates + | H: (PTree.get _ _ = Some _) |- In _ (RTL.successors _ _) => + unfold RTL.successors; rewrite H; auto with coqlib + | _ => idtac + end. + + +Lemma transl_find_function: + forall ros f args lv rs ls alloc, + RTL.find_function ge ros rs = Some f -> + agree alloc (reg_list_live args (reg_sum_live ros lv)) rs ls -> + exists tf, + LTL.find_function tge (sum_left_map alloc ros) ls = Some tf /\ + transf_fundef f = OK tf. Proof. - intros; red; intros; CleanupHyps. - exists ls. split. - CleanupGoal. apply exec_Bgoto. apply exec_refl. - assumption. + intros; destruct ros; simpl in *. + assert (Val.lessdef (rs#r) (ls (alloc r))). + eapply agree_eval_reg. eapply agree_reg_list_live; eauto. + inv H1. apply functions_translated. auto. + exploit Genv.find_funct_inv; eauto. intros [b EQ]. congruence. + rewrite symbols_preserved. destruct (Genv.find_symbol ge i). + apply function_ptr_translated. auto. discriminate. Qed. -Lemma transl_Iop_correct: - forall (c : PTree.t instruction) (sp: val) (pc : positive) - (rs : Regmap.t val) (m : mem) (op : operation) (args : list reg) - (res : reg) (pc' : RTL.node) (v: val), - c ! pc = Some (Iop op args res pc') -> - eval_operation ge sp op (rs ## args) = Some v -> - exec_instr_prop c sp pc rs m E0 pc' (rs # res <- v) m. +Theorem transl_step_correct: + forall s1 t s2, RTL.step ge s1 t s2 -> + forall s1', match_states s1 s1' -> + exists s2', LTL.step tge s1' t s2' /\ match_states s2 s2'. Proof. - intros; red; intros; CleanupHyps. + induction 1; intros; CleanupHyps; WellTypedHyp. + + (* Inop *) + econstructor; split. + eapply exec_Lnop. TranslInstr. MatchStates. + + (* Iop *) + generalize (PTree.gmap (transf_instr f live assign) pc (RTL.fn_code f)). + rewrite H. simpl. caseEq (Regset.mem res live!!pc); intro LV; rewrite LV in AG. generalize (Regset.mem_2 _ _ LV). intro LV'. - assert (LL: (List.length (List.map assign args) <= 3)%nat). - rewrite list_length_map. - inversion WTI. simpl; omega. simpl; omega. - eapply length_op_args. eauto. - assert (DISJ: Loc.disjoint (List.map assign args) temporaries). - eapply regalloc_disj_temporaries; eauto. - assert (eval_operation tge sp op (map ls (map assign args)) = Some v). - replace (map ls (map assign args)) with rs##args. - rewrite (eval_operation_preserved symbols_preserved). assumption. - symmetry. eapply agree_eval_regs; eauto. - generalize (add_op_correct tge sp op - (List.map assign args) (assign res) - pc' ls m v LL DISJ H1). - intros [ls' [EX [RES OTHER]]]. - exists ls'. split. - CleanupGoal. rewrite LV. exact EX. - rewrite CF in H. generalize (regalloc_correct_1 f env live _ _ _ _ ASG H). - unfold correct_alloc_instr. + unfold correct_alloc_instr, is_redundant_move. caseEq (is_move_operation op args). (* Special case for moves *) intros arg IMO CORR. generalize (is_move_operation_correct _ _ IMO). intros [EQ1 EQ2]. subst op; subst args. - injection H0; intro. rewrite <- H2. - apply agree_move_live with f env live ls; auto. - rewrite RES. rewrite <- H2. symmetry. eapply agree_eval_reg. - simpl in AG. eexact AG. + injection H0; intro. + destruct (Loc.eq (assign arg) (assign res)); intro CODE. + (* sub-case: redundant move *) + econstructor; split. eapply exec_Lnop; eauto. + MatchStates. + rewrite <- H1. eapply agree_redundant_move_live; eauto. + (* sub-case: non-redundant move *) + econstructor; split. eapply exec_Lop; eauto. simpl. eauto. + MatchStates. + rewrite <- H1. eapply agree_move_live; eauto. (* Not a move *) - intros INMO CORR. - apply agree_assign_live with f env live ls; auto. + intros INMO CORR CODE. + assert (exists v1, + eval_operation tge sp op (map ls (map assign args)) tm = Some v1 + /\ Val.lessdef v v1). + apply eval_operation_lessdef with m (rs##args); auto. + eapply agree_eval_regs; eauto. + rewrite (eval_operation_preserved symbols_preserved). assumption. + destruct H1 as [v1 [EV VMD]]. + econstructor; split. eapply exec_Lop; eauto. + MatchStates. + apply agree_assign_live with f env live; auto. eapply agree_reg_list_live; eauto. (* Result is not live, instruction turned into a nop *) - exists ls. split. - CleanupGoal. rewrite LV. - apply exec_Bgoto; apply exec_refl. - apply agree_assign_dead; auto. + intro CODE. econstructor; split. eapply exec_Lnop; eauto. + MatchStates. apply agree_assign_dead; auto. red; intro. exploit Regset.mem_1; eauto. congruence. -Qed. -Lemma transl_Iload_correct: - forall (c : PTree.t instruction) (sp: val) (pc : positive) - (rs : Regmap.t val) (m : mem) (chunk : memory_chunk) - (addr : addressing) (args : list reg) (dst : reg) (pc' : RTL.node) - (a v : val), - c ! pc = Some (Iload chunk addr args dst pc') -> - eval_addressing ge sp addr rs ## args = Some a -> - loadv chunk m a = Some v -> - exec_instr_prop c sp pc rs m E0 pc' rs # dst <- v m. -Proof. - intros; red; intros; CleanupHyps. + (* Iload *) caseEq (Regset.mem dst live!!pc); intro LV; rewrite LV in AG. (* dst is live *) exploit Regset.mem_2; eauto. intro LV'. - assert (LL: (List.length (List.map assign args) <= 2)%nat). - rewrite list_length_map. - inversion WTI. - eapply length_addr_args. eauto. - assert (DISJ: Loc.disjoint (List.map assign args) temporaries). - eapply regalloc_disj_temporaries; eauto. - assert (EADDR: - eval_addressing tge sp addr (map ls (map assign args)) = Some a). - rewrite <- H0. - replace (rs##args) with (map ls (map assign args)). - apply eval_addressing_preserved. exact symbols_preserved. + assert (exists a', + eval_addressing tge sp addr (map ls (map assign args)) = Some a' + /\ Val.lessdef a a'). + apply eval_addressing_lessdef with (rs##args). eapply agree_eval_regs; eauto. - generalize (add_load_correct tge sp chunk addr - (List.map assign args) (assign dst) - pc' ls m _ _ LL DISJ EADDR H1). - intros [ls' [EX [RES OTHER]]]. - exists ls'. split. CleanupGoal. rewrite LV. exact EX. - rewrite CF in H. + rewrite <- H0. apply eval_addressing_preserved. exact symbols_preserved. + destruct H2 as [a' [EVAL VMD]]. + exploit Mem.loadv_lessdef; eauto. + intros [v' [LOADV VMD2]]. + econstructor; split. + eapply exec_Lload; eauto. TranslInstr. rewrite LV; auto. generalize (regalloc_correct_1 f env live _ _ _ _ ASG H). unfold correct_alloc_instr. intro CORR. + MatchStates. eapply agree_assign_live; eauto. eapply agree_reg_list_live; eauto. (* dst is dead *) - exists ls. split. - CleanupGoal. rewrite LV. - apply exec_Bgoto; apply exec_refl. - apply agree_assign_dead; auto. + econstructor; split. + eapply exec_Lnop. TranslInstr. rewrite LV; auto. + MatchStates. apply agree_assign_dead; auto. red; intro; exploit Regset.mem_1; eauto. congruence. -Qed. -Lemma transl_Istore_correct: - forall (c : PTree.t instruction) (sp: val) (pc : positive) - (rs : Regmap.t val) (m : mem) (chunk : memory_chunk) - (addr : addressing) (args : list reg) (src : reg) (pc' : RTL.node) - (a : val) (m' : mem), - c ! pc = Some (Istore chunk addr args src pc') -> - eval_addressing ge sp addr rs ## args = Some a -> - storev chunk m a rs # src = Some m' -> - exec_instr_prop c sp pc rs m E0 pc' rs m'. -Proof. - intros; red; intros; CleanupHyps. - assert (LL: (List.length (List.map assign args) <= 2)%nat). - rewrite list_length_map. - inversion WTI. - eapply length_addr_args. eauto. - assert (DISJ: Loc.disjoint (List.map assign args) temporaries). - eapply regalloc_disj_temporaries; eauto. - assert (SRC: Loc.notin (assign src) temporaries). - eapply regalloc_not_temporary; eauto. - assert (EADDR: - eval_addressing tge sp addr (map ls (map assign args)) = Some a). - rewrite <- H0. - replace (rs##args) with (map ls (map assign args)). - apply eval_addressing_preserved. exact symbols_preserved. + (* Istore *) + assert (exists a', + eval_addressing tge sp addr (map ls (map assign args)) = Some a' + /\ Val.lessdef a a'). + apply eval_addressing_lessdef with (rs##args). eapply agree_eval_regs; eauto. - assert (ESRC: ls (assign src) = rs#src). + rewrite <- H0. apply eval_addressing_preserved. exact symbols_preserved. + destruct H2 as [a' [EVAL VMD]]. + assert (ESRC: Val.lessdef rs#src (ls (assign src))). eapply agree_eval_reg. eapply agree_reg_list_live. eauto. - rewrite <- ESRC in H1. - generalize (add_store_correct tge sp chunk addr - (List.map assign args) (assign src) - pc' ls m m' a LL DISJ SRC EADDR H1). - intros [ls' [EX RES]]. - exists ls'. split. CleanupGoal. exact EX. - rewrite CF in H. - generalize (regalloc_correct_1 f env live _ _ _ _ ASG H). - unfold correct_alloc_instr. intro CORR. - eapply agree_exten. eauto. - eapply agree_reg_live. eapply agree_reg_list_live. eauto. - assumption. -Qed. - -Lemma transl_Icall_correct: - forall (c : PTree.t instruction) (sp: val) (pc : positive) - (rs : regset) (m : mem) (sig : signature) (ros : reg + ident) - (args : list reg) (res : reg) (pc' : RTL.node) - (f : RTL.fundef) (vres : val) (m' : mem) (t: trace), - c ! pc = Some (Icall sig ros args res pc') -> - RTL.find_function ge ros rs = Some f -> - RTL.funsig f = sig -> - RTL.exec_function ge f (rs##args) m t vres m' -> - exec_function_prop f (rs##args) m t vres m' -> - exec_instr_prop c sp pc rs m t pc' (rs#res <- vres) m'. -Proof. - intros; red; intros; CleanupHyps. - set (los := sum_left_map assign ros). - assert (FIND: exists tf, - find_function2 tge los ls = Some tf /\ - transf_fundef f = Some tf). - unfold los. destruct ros; simpl; simpl in H0. - apply functions_translated. - replace (ls (assign r)) with rs#r. assumption. - simpl in AG. symmetry; eapply agree_eval_reg. - eapply agree_reg_list_live; eauto. - rewrite symbols_preserved. destruct (Genv.find_symbol ge i). - apply function_ptr_translated. auto. - discriminate. - elim FIND; intros tf [AFIND TRF]; clear FIND. - assert (ASIG: sig = funsig tf). - rewrite (sig_function_translated _ _ TRF). auto. - generalize (fun ls => H3 ls tf TRF); intro AEXECF. - assert (AVARGS: List.map ls (List.map assign args) = rs##args). - eapply agree_eval_regs; eauto. - assert (ALARGS: List.length (List.map assign args) = - List.length sig.(sig_args)). - inversion WTI. rewrite <- H10. - repeat rewrite list_length_map. auto. - assert (AACCEPT: locs_acceptable (List.map assign args)). - eapply regsalloc_acceptable; eauto. - rewrite CF in H. - generalize (regalloc_correct_1 f0 env live _ _ _ _ ASG H). - unfold correct_alloc_instr. intros [CORR1 CORR2]. - assert (ARES: loc_acceptable (assign res)). - eapply regalloc_acceptable; eauto. - generalize (add_call_correct tge sp tf _ _ _ _ _ _ _ _ _ pc' _ - AEXECF AFIND ASIG AVARGS ALARGS - AACCEPT ARES). - intros [ls' [EX [RES OTHER]]]. - exists ls'. - split. rewrite CF. CleanupGoal. exact EX. - simpl. eapply agree_call; eauto. -Qed. - -Lemma transl_Ialloc_correct: - forall (c : PTree.t instruction) (sp: val) (pc : positive) - (rs : Regmap.t val) (m : mem) (pc': RTL.node) (arg res: reg) - (sz: int) (m': mem) (b: Values.block), - c ! pc = Some (Ialloc arg res pc') -> - rs#arg = Vint sz -> - Mem.alloc m 0 (Int.signed sz) = (m', b) -> - exec_instr_prop c sp pc rs m E0 pc' (rs # res <- (Vptr b Int.zero)) m'. -Proof. - intros; red; intros; CleanupHyps. - assert (SZ: ls (assign arg) = Vint sz). + assert (exists tm', storev chunk tm a' (ls (assign src)) = Some tm' + /\ Mem.lessdef m' tm'). + eapply Mem.storev_lessdef; eauto. + destruct H2 as [m1' [STORE MMD']]. + econstructor; split. + eapply exec_Lstore; eauto. TranslInstr. + MatchStates. eapply agree_reg_live. eapply agree_reg_list_live. eauto. + + (* Icall *) + exploit transl_find_function; eauto. intros [tf [TFIND TF]]. + generalize (regalloc_correct_1 f0 env live _ _ _ _ ASG H). unfold correct_alloc_instr. intros [CORR1 CORR2]. + exploit (parmov_spec ls (map assign args) + (loc_arguments (RTL.funsig f))). + apply loc_arguments_norepet. + rewrite loc_arguments_length. inv WTI. + rewrite <- H7. repeat rewrite list_length_map. auto. + intros [PM1 PM2]. + econstructor; split. + eapply exec_Lcall; eauto. TranslInstr. + rewrite (sig_function_translated _ _ TF). eauto. + rewrite (sig_function_translated _ _ TF). + econstructor; eauto. + econstructor; eauto. + intros. eapply agree_succ with (n := pc); eauto. + unfold RTL.successors; rewrite H; auto with coqlib. + eapply agree_call with (ls := ls); eauto. + rewrite Locmap.gss. auto. + intros. rewrite Locmap.gso. rewrite H1; auto. apply PM2; auto. + eapply arguments_not_preserved; eauto. apply Loc.diff_sym; auto. + rewrite (sig_function_translated _ _ TF). + change Regset.elt with reg in PM1. + rewrite PM1. eapply agree_eval_regs; eauto. + + (* Itailcall *) + exploit transl_find_function; eauto. intros [tf [TFIND TF]]. + exploit (parmov_spec ls (map assign args) + (loc_arguments (RTL.funsig f))). + apply loc_arguments_norepet. + rewrite loc_arguments_length. inv WTI. + rewrite <- H6. repeat rewrite list_length_map. auto. + intros [PM1 PM2]. + econstructor; split. + eapply exec_Ltailcall; eauto. TranslInstr. + rewrite (sig_function_translated _ _ TF). eauto. + rewrite (sig_function_translated _ _ TF). + econstructor; eauto. + apply match_stackframes_change with (RTL.fn_sig f0); auto. + inv WTI. auto. + rewrite (sig_function_translated _ _ TF). + rewrite return_regs_arguments. + change Regset.elt with reg in PM1. + rewrite PM1. eapply agree_eval_regs; eauto. + inv WTI; auto. + apply free_lessdef; auto. + intros. rewrite return_regs_not_destroyed; auto. + + (* Ialloc *) + assert (Val.lessdef (Vint sz) (ls (assign arg))). rewrite <- H0. eapply agree_eval_reg. eauto. - generalize (add_alloc_correct tge sp (assign arg) (assign res) - pc' ls m m' sz b SZ H1). - intros [ls' [EX [RES OTHER]]]. - exists ls'. - split. CleanupGoal. exact EX. - rewrite CF in H. + inversion H2. subst v. + pose (ls1 := Locmap.set (R loc_alloc_argument) (ls (assign arg)) ls). + pose (ls2 := Locmap.set (R loc_alloc_result) (Vptr b Int.zero) ls1). + pose (ls3 := Locmap.set (assign res) (ls2 (R loc_alloc_result)) ls2). + caseEq (alloc tm 0 (Int.signed sz)). intros tm' b1 ALLOC1. + exploit Mem.alloc_lessdef; eauto. intros [EQ MMD1]. subst b1. + exists (State ts (transf_fun f live assign) sp pc' ls3 tm'); split. + unfold ls3, ls2, ls1. eapply exec_Lalloc; eauto. TranslInstr. generalize (regalloc_correct_1 f env live _ _ _ _ ASG H). unfold correct_alloc_instr. intros [CORR1 CORR2]. - eapply agree_call with (args := arg :: nil) (ros := inr reg 1%positive) (ls := ls) (ls' := ls'); eauto. - intros. apply OTHER. - eapply Loc.in_notin_diff; eauto. - unfold loc_alloc_argument, destroyed_at_call; simpl; tauto. - eapply Loc.in_notin_diff; eauto. + MatchStates. + eapply agree_call with (args := arg :: nil) (ros := inr reg 1%positive) (ls := ls); eauto. + unfold ls3; rewrite Locmap.gss. + unfold ls2; rewrite Locmap.gss. auto. + intros. unfold ls3; rewrite Locmap.gso. + unfold ls2; rewrite Locmap.gso. + unfold ls1; apply Locmap.gso. + apply Loc.diff_sym. eapply Loc.in_notin_diff; eauto. unfold loc_alloc_argument, destroyed_at_call; simpl; tauto. - auto. -Qed. - -Lemma transl_Icond_true_correct: - forall (c : PTree.t instruction) (sp: val) (pc : positive) - (rs : Regmap.t val) (m : mem) (cond : condition) (args : list reg) - (ifso ifnot : RTL.node), - c ! pc = Some (Icond cond args ifso ifnot) -> - eval_condition cond rs ## args = Some true -> - exec_instr_prop c sp pc rs m E0 ifso rs m. -Proof. - intros; red; intros; CleanupHyps. - assert (LL: (List.length (map assign args) <= 3)%nat). - rewrite list_length_map. inversion WTI. - eapply length_cond_args. eauto. - assert (DISJ: Loc.disjoint (map assign args) temporaries). - eapply regalloc_disj_temporaries; eauto. - assert (COND: eval_condition cond (map ls (map assign args)) = Some true). - replace (map ls (map assign args)) with rs##args. assumption. - symmetry. eapply agree_eval_regs; eauto. - generalize (add_cond_correct tge sp _ _ _ ifnot _ m _ _ - LL DISJ COND (refl_equal ifso)). - intros [ls' [EX OTHER]]. - exists ls'. split. - CleanupGoal. assumption. - eapply agree_exten. eauto. eapply agree_reg_list_live. eauto. - assumption. -Qed. - -Lemma transl_Icond_false_correct: - forall (c : PTree.t instruction) (sp: val) (pc : positive) - (rs : Regmap.t val) (m : mem) (cond : condition) (args : list reg) - (ifso ifnot : RTL.node), - c ! pc = Some (Icond cond args ifso ifnot) -> - eval_condition cond rs ## args = Some false -> - exec_instr_prop c sp pc rs m E0 ifnot rs m. -Proof. - intros; red; intros; CleanupHyps. - assert (LL: (List.length (map assign args) <= 3)%nat). - rewrite list_length_map. inversion WTI. - eapply length_cond_args. eauto. - assert (DISJ: Loc.disjoint (map assign args) temporaries). - eapply regalloc_disj_temporaries; eauto. - assert (COND: eval_condition cond (map ls (map assign args)) = Some false). - replace (map ls (map assign args)) with rs##args. assumption. - symmetry. eapply agree_eval_regs; eauto. - generalize (add_cond_correct tge sp _ _ ifso _ _ m _ _ - LL DISJ COND (refl_equal ifnot)). - intros [ls' [EX OTHER]]. - exists ls'. split. - CleanupGoal. assumption. - eapply agree_exten. eauto. eapply agree_reg_list_live. eauto. - assumption. -Qed. - -Lemma transl_refl_correct: - forall (c : RTL.code) (sp: val) (pc : RTL.node) (rs : regset) - (m : mem), exec_instrs_prop c sp pc rs m E0 pc rs m. -Proof. - intros; red; intros. - exists ls. split. apply exec_blocks_refl. assumption. -Qed. - -Lemma transl_one_correct: - forall (c : RTL.code) (sp: val) (pc : RTL.node) (rs : regset) - (m : mem) (t: trace) (pc' : RTL.node) (rs' : regset) (m' : mem), - RTL.exec_instr ge c sp pc rs m t pc' rs' m' -> - exec_instr_prop c sp pc rs m t pc' rs' m' -> - exec_instrs_prop c sp pc rs m t pc' rs' m'. -Proof. - intros; red; intros. - generalize (H0 f env live assign ls CF WT ASG AG). - intros [ls' [EX AG']]. - exists ls'. split. - exact EX. - apply agree_increasing with live!!pc. - apply analyze_correct. auto. - rewrite <- CF. eapply exec_instr_present; eauto. - rewrite <- CF. auto. - eapply RTL.successors_correct. - rewrite <- CF. eexact H. exact AG'. -Qed. - -Lemma transl_trans_correct: - forall (c : RTL.code) (sp: val) (pc1 : RTL.node) (rs1 : regset) - (m1 : mem) (t1: trace) (pc2 : RTL.node) (rs2 : regset) (m2 : mem) - (t2: trace) (pc3 : RTL.node) (rs3 : regset) (m3 : mem) (t3: trace), - RTL.exec_instrs ge c sp pc1 rs1 m1 t1 pc2 rs2 m2 -> - exec_instrs_prop c sp pc1 rs1 m1 t1 pc2 rs2 m2 -> - RTL.exec_instrs ge c sp pc2 rs2 m2 t2 pc3 rs3 m3 -> - exec_instrs_prop c sp pc2 rs2 m2 t2 pc3 rs3 m3 -> - t3 = t1 ** t2 -> - exec_instrs_prop c sp pc1 rs1 m1 t3 pc3 rs3 m3. -Proof. - intros; red; intros. - assert (VALIDPC2: c!pc2 <> None). - eapply exec_instrs_present; eauto. - generalize (H0 f env live assign ls CF WT ANL ASG AG VALIDPC2). - intros [ls1 [EX1 AG1]]. - generalize (H2 f env live assign ls1 CF WT ANL ASG AG1 VALIDPC'). - intros [ls2 [EX2 AG2]]. - exists ls2. split. - eapply exec_blocks_trans. eexact EX1. eexact EX2. auto. - exact AG2. -Qed. - -Remark regset_mem_reg_list_dead: - forall rl r live, - Regset.In r (reg_list_dead rl live) -> - ~(In r rl) /\ Regset.In r live. -Proof. - induction rl; simpl; intros. - tauto. - elim (IHrl r (reg_dead a live) H). intros. - assert (a <> r). red; intro; subst r. - exploit Regset.remove_1; eauto. - intuition. eapply Regset.remove_3; eauto. -Qed. - -Lemma transf_entrypoint_correct: - forall f env live assign c ls args sp m, - wt_function f env -> - regalloc f live (live0 f live) env = Some assign -> - c!(RTL.fn_nextpc f) = None -> - List.map ls (loc_parameters (RTL.fn_sig f)) = args -> - (forall ofs ty, ls (S (Local ofs ty)) = Vundef) -> - let tc := transf_entrypoint f live assign c in - exists ls', - exec_blocks tge tc sp (RTL.fn_nextpc f) ls m E0 - (Cont (RTL.fn_entrypoint f)) ls' m /\ - agree assign (transfer f (RTL.fn_entrypoint f) live!!(RTL.fn_entrypoint f)) - (init_regs args (RTL.fn_params f)) ls'. -Proof. - intros until m. - unfold transf_entrypoint. - set (oldentry := RTL.fn_entrypoint f). - set (newentry := RTL.fn_nextpc f). - set (params := RTL.fn_params f). - set (undefs := Regset.elements (reg_list_dead params (transfer f oldentry live!!oldentry))). - intros. - - assert (A1: List.length (List.map assign params) = - List.length (RTL.fn_sig f).(sig_args)). - rewrite <- (wt_params _ _ H). - repeat (rewrite list_length_map). auto. - assert (A2: Loc.norepet (List.map assign (RTL.fn_params f))). - eapply regalloc_norepet_norepet; eauto. - eapply regalloc_correct_2; eauto. - eapply wt_norepet; eauto. - assert (A3: locs_acceptable (List.map assign (RTL.fn_params f))). - eapply regsalloc_acceptable; eauto. - assert (A4: Loc.disjoint - (List.map assign (RTL.fn_params f)) - (List.map assign undefs)). - red. intros ap au INAP INAU. - generalize (list_in_map_inv _ _ _ INAP). - intros [p [AP INP]]. clear INAP; subst ap. - generalize (list_in_map_inv _ _ _ INAU). - intros [u [AU INU]]. clear INAU; subst au. - assert (INU': InA Regset.E.eq u undefs). - rewrite InA_alt. exists u; intuition. - generalize (Regset.elements_2 _ _ INU'). intro. - generalize (regset_mem_reg_list_dead _ _ _ H4). - intros [A B]. - eapply regalloc_noteq_diff; eauto. - eapply regalloc_correct_3; eauto. - red; intro; subst u. elim (A INP). - assert (A5: forall l, In l (List.map assign undefs) -> loc_acceptable l). - intros. - generalize (list_in_map_inv _ _ _ H4). - intros [r [AR INR]]. clear H4; subst l. - eapply regalloc_acceptable; eauto. - generalize (add_entry_correct - tge sp (RTL.fn_sig f) - (List.map assign (RTL.fn_params f)) - (List.map assign undefs) - oldentry ls m A1 A2 A3 A4 A5 H3). - intros [ls1 [EX1 [PARAMS1 UNDEFS1]]]. - exists ls1. - split. eapply exec_blocks_one. - rewrite PTree.gss. reflexivity. - assumption. - change (transfer f oldentry live!!oldentry) - with (live0 f live). - unfold params; eapply agree_parameters; eauto. - change Regset.elt with reg in PARAMS1. - rewrite PARAMS1. assumption. - fold oldentry; fold params. intros. - apply UNDEFS1. apply in_map. - unfold undefs. - change (transfer f oldentry live!!oldentry) - with (live0 f live). - exploit Regset.elements_1; eauto. - rewrite InA_alt. intros [r' [C D]]. hnf in C. subst r'. auto. -Qed. - -Lemma transl_function_correct: - forall (f : RTL.function) (m m1 : mem) (stk : Values.block) - (args : list val) (t: trace) (pc : RTL.node) (rs : regset) (m2 : mem) - (or : option reg) (vres : val), - alloc m 0 (RTL.fn_stacksize f) = (m1, stk) -> - RTL.exec_instrs ge (RTL.fn_code f) (Vptr stk Int.zero) - (RTL.fn_entrypoint f) (init_regs args (fn_params f)) m1 t pc rs m2 -> - exec_instrs_prop (RTL.fn_code f) (Vptr stk Int.zero) - (RTL.fn_entrypoint f) (init_regs args (fn_params f)) m1 t pc rs m2 -> - (RTL.fn_code f) ! pc = Some (Ireturn or) -> - vres = regmap_optget or Vundef rs -> - exec_function_prop (Internal f) args m t vres (free m2 stk). -Proof. - intros; red; intros until tf. - unfold transf_fundef, transf_partial_fundef, transf_function. - caseEq (type_function f). - intros env TRF. - caseEq (analyze f). - intros live ANL. - change (transfer f (RTL.fn_entrypoint f) live!!(RTL.fn_entrypoint f)) - with (live0 f live). - caseEq (regalloc f live (live0 f live) env). - intros alloc ASG. - set (tc1 := PTree.map (transf_instr f live alloc) (RTL.fn_code f)). - set (tc2 := transf_entrypoint f live alloc tc1). - intro EQ; injection EQ; intro TF; clear EQ. intro VARGS. - generalize (type_function_correct _ _ TRF); intro WTF. - assert (NEWINSTR: tc1!(RTL.fn_nextpc f) = None). - unfold tc1; rewrite PTree.gmap. unfold option_map. - elim (RTL.fn_code_wf f (fn_nextpc f)); intro. - elim (Plt_ne _ _ H4). auto. - rewrite H4. auto. - pose (ls1 := call_regs ls). - assert (VARGS1: List.map ls1 (loc_parameters (RTL.fn_sig f)) = args). - replace (RTL.fn_sig f) with (funsig tf). - rewrite <- VARGS. unfold loc_parameters. - rewrite list_map_compose. apply list_map_exten. - intros. symmetry. unfold ls1. eapply call_regs_param_of_arg; eauto. - rewrite <- TF; reflexivity. - assert (VUNDEFS: forall (ofs : Z) (ty : typ), ls1 (S (Local ofs ty)) = Vundef). - intros. reflexivity. - generalize (transf_entrypoint_correct f env live alloc - tc1 ls1 args (Vptr stk Int.zero) m1 - WTF ASG NEWINSTR VARGS1 VUNDEFS). - fold tc2. intros [ls2 [EX2 AGREE2]]. - assert (VALIDPC: f.(RTL.fn_code)!pc <> None). congruence. - generalize (H1 f env live alloc ls2 - (refl_equal _) WTF ANL ASG AGREE2 VALIDPC). - fold tc1. intros [ls3 [EX3 AGREE3]]. - generalize (add_return_correct tge (Vptr stk Int.zero) (RTL.fn_sig f) - (option_map alloc or) ls3 m2). - intros [ls4 [EX4 RES4]]. - exists ls4. - (* Execution *) - split. rewrite <- TF; apply exec_funct_internal with m1; simpl. - assumption. - fold ls1. - eapply exec_blocks_trans. eexact EX2. - apply exec_blocks_extends with tc1. - intro p. unfold tc2. unfold transf_entrypoint. - case (peq p (fn_nextpc f)); intro. - subst p. right. unfold tc1; rewrite PTree.gmap. - elim (RTL.fn_code_wf f (fn_nextpc f)); intro. - elim (Plt_ne _ _ H4); auto. rewrite H4; reflexivity. - left; apply PTree.gso; auto. - eapply exec_blocks_trans. eexact EX3. - eapply exec_blocks_one. - unfold tc1. rewrite PTree.gmap. rewrite H2. simpl. reflexivity. - eexact EX4. reflexivity. traceEq. - destruct or. - simpl in RES4. simpl in H3. - rewrite H3. rewrite <- TF; simpl. rewrite RES4. - eapply agree_eval_reg; eauto. - unfold transfer in AGREE3; rewrite H2 in AGREE3. - unfold reg_option_live in AGREE3. eexact AGREE3. - simpl in RES4. simpl in H3. - rewrite <- TF; simpl. congruence. - intros; discriminate. - intros; discriminate. - intros; discriminate. -Qed. + apply Loc.diff_sym. eapply Loc.in_notin_diff; eauto. + unfold loc_alloc_result, destroyed_at_call; simpl; tauto. + apply Loc.diff_sym; auto. -Lemma transl_external_function_correct: - forall (ef : external_function) (args : list val) (m : mem) - (t: trace) (res: val), - event_match ef args t res -> - exec_function_prop (External ef) args m t res m. -Proof. - intros; red; intros. - simpl in H0. - simplify_eq H0; intro. - exists (Locmap.set (R (loc_result (funsig tf))) res ls); split. - subst tf. eapply exec_funct_external; eauto. - apply Locmap.gss. + (* Icond, true *) + assert (COND: eval_condition cond (map ls (map assign args)) tm = Some true). + eapply eval_condition_lessdef; eauto. + eapply agree_eval_regs; eauto. + econstructor; split. + eapply exec_Lcond_true; eauto. TranslInstr. + MatchStates. eapply agree_reg_list_live. eauto. + (* Icond, false *) + assert (COND: eval_condition cond (map ls (map assign args)) tm = Some false). + eapply eval_condition_lessdef; eauto. + eapply agree_eval_regs; eauto. + econstructor; split. + eapply exec_Lcond_false; eauto. TranslInstr. + MatchStates. eapply agree_reg_list_live. eauto. + + (* Ireturn *) + econstructor; split. + eapply exec_Lreturn; eauto. TranslInstr; eauto. + econstructor; eauto. + rewrite return_regs_result. + inv WTI. destruct or; simpl in *. + rewrite Locmap.gss. eapply agree_eval_reg; eauto. + constructor. + apply free_lessdef; auto. + intros. apply return_regs_not_destroyed; auto. + + (* internal function *) + generalize H6. simpl. unfold transf_function. + caseEq (type_function f); simpl; try congruence. intros env TYP. + assert (WTF: wt_function f env). apply type_function_correct; auto. + caseEq (analyze f); simpl; try congruence. intros live ANL. + caseEq (regalloc f live (live0 f live) env); simpl; try congruence. + intros alloc ALLOC EQ. inv EQ. simpl in *. + caseEq (Mem.alloc tm 0 (RTL.fn_stacksize f)). intros tm' stk' MEMALLOC. + exploit alloc_lessdef; eauto. intros [EQ LDM]. subst stk'. + econstructor; split. + eapply exec_function_internal; simpl; eauto. + simpl. econstructor; eauto. + apply agree_init_regs. intros; eapply regalloc_correct_3; eauto. + inv WTF. + exploit (parmov_spec (call_regs ls) + (loc_parameters (RTL.fn_sig f)) + (map alloc (RTL.fn_params f))). + eapply regalloc_norepet_norepet; eauto. + eapply regalloc_correct_2; eauto. + rewrite loc_parameters_length. symmetry. + transitivity (length (map env (RTL.fn_params f))). + repeat rewrite list_length_map. auto. + rewrite wt_params; auto. + intros [PM1 PM2]. + change Regset.elt with reg in PM1. rewrite PM1. + replace (map (call_regs ls) (loc_parameters (RTL.fn_sig f))) + with (map ls (loc_arguments (RTL.fn_sig f))). + auto. + symmetry. unfold loc_parameters. rewrite list_map_compose. + apply list_map_exten. intros. symmetry. eapply call_regs_param_of_arg; eauto. + + (* external function *) + injection H6; intro EQ; inv EQ. + exploit event_match_lessdef; eauto. intros [tres [A B]]. + econstructor; split. + eapply exec_function_external; eauto. + eapply match_states_return; eauto. + rewrite Locmap.gss. auto. + intros. rewrite <- H10; auto. apply Locmap.gso. + apply Loc.diff_sym. eapply Loc.in_notin_diff; eauto. + apply loc_result_caller_save. + + (* return *) + inv H3. + econstructor; split. + eapply exec_return; eauto. + econstructor; eauto. Qed. -(** The correctness of the code transformation is obtained by - structural induction (and case analysis on the last rule used) - on the RTL evaluation derivation. - This is a 3-way mutual induction, using [exec_instr_prop], - [exec_instrs_prop] and [exec_function_prop] as the induction - hypotheses, and the lemmas above as cases for the induction. *) - -Theorem transl_function_correctness: - forall f args m t res m', - RTL.exec_function ge f args m t res m' -> - exec_function_prop f args m t res m'. -Proof - (exec_function_ind_3 ge - exec_instr_prop - exec_instrs_prop - exec_function_prop - - transl_Inop_correct - transl_Iop_correct - transl_Iload_correct - transl_Istore_correct - transl_Icall_correct - transl_Ialloc_correct - transl_Icond_true_correct - transl_Icond_false_correct - - transl_refl_correct - transl_one_correct - transl_trans_correct - - transl_function_correct - transl_external_function_correct). - (** The semantic equivalence between the original and transformed programs follows easily. *) -Theorem transl_program_correct: - forall (t: trace) (r: val), - RTL.exec_program prog t r -> LTL.exec_program tprog t r. +Lemma transf_initial_states: + forall st1, RTL.initial_state prog st1 -> + exists st2, LTL.initial_state tprog st2 /\ match_states st1 st2. Proof. - intros t r [b [f [m [FIND1 [FIND2 [SIG EXEC]]]]]]. - generalize (function_ptr_translated _ _ FIND2). - intros [tf [TFIND TRF]]. + intros. inversion H. + exploit function_ptr_translated; eauto. intros [tf [FIND TR]]. assert (SIG2: funsig tf = mksignature nil (Some Tint)). - rewrite <- SIG. apply sig_function_translated; auto. - assert (VPARAMS: map (Locmap.init Vundef) (loc_arguments (funsig tf)) = nil). - rewrite SIG2. reflexivity. - generalize (transl_function_correctness _ _ _ _ _ _ EXEC - (Locmap.init Vundef) tf TRF VPARAMS). - intros [ls' [TEXEC RES]]. - red. exists b; exists tf; exists ls'; exists m. - split. rewrite symbols_preserved. - rewrite (transform_partial_program_main _ _ TRANSF). - assumption. - split. assumption. - split. assumption. - split. replace (Genv.init_mem tprog) with (Genv.init_mem prog). - assumption. symmetry. - exact (Genv.init_mem_transf_partial _ _ TRANSF). - assumption. + rewrite <- H2. apply sig_function_translated; auto. + assert (VPARAMS: Val.lessdef_list nil (map (Locmap.init Vundef) (loc_arguments (funsig tf)))). + rewrite SIG2. simpl. constructor. + assert (GENV: (Genv.init_mem tprog) = (Genv.init_mem prog)). + exact (Genv.init_mem_transf_partial _ _ TRANSF). + assert (MMD: Mem.lessdef (Genv.init_mem prog) (Genv.init_mem tprog)). + rewrite GENV. apply Mem.lessdef_refl. + exists (LTL.Callstate nil tf (Locmap.init Vundef) (Genv.init_mem tprog)); split. + econstructor; eauto. + rewrite symbols_preserved. + rewrite (transform_partial_program_main _ _ TRANSF). auto. + constructor; auto. rewrite H2; constructor. +Qed. + +Lemma transf_final_states: + forall st1 st2 r, + match_states st1 st2 -> RTL.final_state st1 r -> LTL.final_state st2 r. +Proof. + intros. inv H0. inv H. inv H3. econstructor. + inv H4. auto. +Qed. + +Theorem transf_program_correct: + forall (beh: program_behavior), + RTL.exec_program prog beh -> LTL.exec_program tprog beh. +Proof. + unfold RTL.exec_program, LTL.exec_program; intros. + eapply simulation_step_preservation; eauto. + eexact transf_initial_states. + eexact transf_final_states. + exact transl_step_correct. Qed. End PRESERVATION. diff --git a/backend/Alloctyping.v b/backend/Alloctyping.v index 4c4c4f76..c0abf0d6 100644 --- a/backend/Alloctyping.v +++ b/backend/Alloctyping.v @@ -2,6 +2,7 @@ Require Import Coqlib. Require Import Maps. +Require Import Errors. Require Import AST. Require Import Op. Require Import Registers. @@ -15,7 +16,6 @@ Require Import Allocproof. Require Import RTLtyping. Require Import LTLtyping. Require Import Conventions. -Require Import Parallelmove. (** This file proves that register allocation (the translation from RTL to LTL defined in file [Allocation]) preserves typing: @@ -30,9 +30,10 @@ Variable live: PMap.t Regset.t. Variable alloc: reg -> loc. Variable tf: LTL.function. -Hypothesis TYPE_RTL: type_function f = Some env. +Hypothesis TYPE_RTL: type_function f = OK env. +Hypothesis LIVE: analyze f = Some live. Hypothesis ALLOC: regalloc f live (live0 f live) env = Some alloc. -Hypothesis TRANSL: transf_function f = Some tf. +Hypothesis TRANSL: transf_function f = OK tf. Lemma wt_rtl_function: RTLtyping.wt_function f env. Proof. @@ -51,473 +52,90 @@ Proof. intros. symmetry. apply alloc_type. Qed. -(** [loc_read_ok l] states whether location [l] is well-formed in an - argument context (for reading). *) - -Definition loc_read_ok (l: loc) : Prop := - match l with R r => True | S s => slot_bounded tf s end. - -(** [loc_write_ok l] states whether location [l] is well-formed in a - result context (for writing). *) - -Definition loc_write_ok (l: loc) : Prop := - match l with - | R r => True - | S (Incoming _ _) => False - | S s => slot_bounded tf s end. - -Definition locs_read_ok (ll: list loc) : Prop := - forall l, In l ll -> loc_read_ok l. - -Definition locs_write_ok (ll: list loc) : Prop := - forall l, In l ll -> loc_write_ok l. - -Remark loc_write_ok_read_ok: - forall l, loc_write_ok l -> loc_read_ok l. -Proof. - destruct l; simpl. auto. - destruct s; tauto. -Qed. -Hint Resolve loc_write_ok_read_ok: allocty. - -Remark locs_write_ok_read_ok: - forall ll, locs_write_ok ll -> locs_read_ok ll. -Proof. - unfold locs_write_ok, locs_read_ok. auto with allocty. -Qed. -Hint Resolve locs_write_ok_read_ok: allocty. - -Lemma alloc_write_ok: - forall r, loc_write_ok (alloc r). +Lemma alloc_acceptable: + forall r, loc_acceptable (alloc r). Proof. - intros. generalize (regalloc_acceptable _ _ _ _ _ r ALLOC). - destruct (alloc r); simpl. auto. - destruct s; try contradiction. simpl. omega. + intros. eapply regalloc_acceptable; eauto. Qed. -Hint Resolve alloc_write_ok: allocty. -Lemma allocs_write_ok: - forall rl, locs_write_ok (List.map alloc rl). +Lemma allocs_acceptable: + forall rl, locs_acceptable (List.map alloc rl). Proof. - intros; red; intros. - generalize (list_in_map_inv _ _ _ H). intros [r [EQ IN]]. - subst l. auto with allocty. + intros. eapply regsalloc_acceptable; eauto. Qed. -Hint Resolve allocs_write_ok: allocty. - -(** * Typing LTL constructors *) - -(** We show that the LTL constructor functions defined in [Allocation] - generate well-typed LTL basic blocks, given sufficient typing - and well-formedness hypotheses over the locations involved. *) -Lemma wt_add_reload: - forall src dst k, - loc_read_ok src -> - Loc.type src = mreg_type dst -> - wt_block tf k -> - wt_block tf (add_reload src dst k). +Remark transf_unroll: + tf = transf_fun f live alloc. Proof. - intros. unfold add_reload. destruct src. - case (mreg_eq m dst); intro. auto. apply wt_Bopmove. exact H0. auto. - apply wt_Bgetstack. exact H0. exact H. auto. + generalize TRANSL. unfold transf_function. + rewrite TYPE_RTL. rewrite LIVE. rewrite ALLOC. congruence. Qed. -Lemma wt_add_spill: - forall src dst k, - loc_write_ok dst -> - mreg_type src = Loc.type dst -> - wt_block tf k -> - wt_block tf (add_spill src dst k). +Lemma valid_successor_transf: + forall s, + RTLtyping.valid_successor f s -> + LTLtyping.valid_successor tf s. Proof. - intros. unfold add_spill. destruct dst. - case (mreg_eq src m); intro. auto. - apply wt_Bopmove. exact H0. auto. - apply wt_Bsetstack. generalize H. simpl. destruct s; auto. - symmetry. exact H0. generalize H. simpl. destruct s; auto. contradiction. - auto. -Qed. + unfold RTLtyping.valid_successor, LTLtyping.valid_successor. + intros s [i AT]. + rewrite transf_unroll; simpl. rewrite PTree.gmap. + rewrite AT. exists (transf_instr f live alloc s i). auto. +Qed. -Lemma wt_add_reloads: - forall srcs dsts k, - locs_read_ok srcs -> - List.map Loc.type srcs = List.map mreg_type dsts -> - wt_block tf k -> - wt_block tf (add_reloads srcs dsts k). -Proof. - induction srcs; intros. - destruct dsts. simpl; auto. simpl in H0; discriminate. - destruct dsts; simpl in H0. discriminate. simpl. - apply wt_add_reload. apply H; apply in_eq. congruence. - apply IHsrcs. red; intros; apply H; apply in_cons; auto. - congruence. auto. -Qed. - -Lemma wt_reg_for: - forall l, mreg_type (reg_for l) = Loc.type l. -Proof. - intros. destruct l; simpl. auto. - case (slot_type s); reflexivity. -Qed. -Hint Resolve wt_reg_for: allocty. - -Lemma wt_regs_for_rec: - forall locs itmps ftmps, - (List.length locs <= List.length itmps)%nat -> - (List.length locs <= List.length ftmps)%nat -> - (forall r, In r itmps -> mreg_type r = Tint) -> - (forall r, In r ftmps -> mreg_type r = Tfloat) -> - List.map mreg_type (regs_for_rec locs itmps ftmps) = List.map Loc.type locs. -Proof. - induction locs; intros. - simpl. auto. - destruct itmps; simpl in H. omegaContradiction. - destruct ftmps; simpl in H0. omegaContradiction. - simpl. apply (f_equal2 (@cons typ)). - destruct a. reflexivity. simpl. case (slot_type s). - apply H1; apply in_eq. apply H2; apply in_eq. - apply IHlocs. omega. omega. - intros; apply H1; apply in_cons; auto. - intros; apply H2; apply in_cons; auto. -Qed. - -Lemma wt_regs_for: - forall locs, - (List.length locs <= 3)%nat -> - List.map mreg_type (regs_for locs) = List.map Loc.type locs. -Proof. - intros. unfold regs_for. apply wt_regs_for_rec. - simpl. auto. simpl. auto. - simpl; intros; intuition; subst r; reflexivity. - simpl; intros; intuition; subst r; reflexivity. -Qed. -Hint Resolve wt_regs_for: allocty. - -Lemma wt_add_move: - forall src dst b, - loc_read_ok src -> loc_write_ok dst -> - Loc.type src = Loc.type dst -> - wt_block tf b -> - wt_block tf (add_move src dst b). -Proof. - intros. unfold add_move. - case (Loc.eq src dst); intro. - auto. - destruct src. apply wt_add_spill; auto. - destruct dst. apply wt_add_reload; auto. - set (tmp := match slot_type s with Tint => IT1 | Tfloat => FT1 end). - apply wt_add_reload. auto. - simpl. unfold tmp. case (slot_type s); reflexivity. - apply wt_add_spill. auto. - simpl. simpl in H1. rewrite <- H1. unfold tmp. case (slot_type s); reflexivity. - auto. -Qed. - -Lemma wt_add_moves: - forall b moves, - (forall s d, In (s, d) moves -> - loc_read_ok s /\ loc_write_ok d /\ Loc.type s = Loc.type d) -> - wt_block tf b -> - wt_block tf - (List.fold_right (fun p k => add_move (fst p) (snd p) k) b moves). -Proof. - induction moves; simpl; intros. - auto. - destruct a as [s d]. simpl. - elim (H s d). intros A [B C]. apply wt_add_move; auto. auto. -Qed. - -Theorem wt_parallel_move: - forall srcs dsts b, - List.map Loc.type srcs = List.map Loc.type dsts -> - locs_read_ok srcs -> - locs_write_ok dsts -> wt_block tf b -> wt_block tf (parallel_move srcs dsts b). -Proof. - intros. unfold parallel_move. apply wt_add_moves; auto. - intros. - elim (parmove_prop_2 _ _ _ _ H3); intros A B. - split. destruct A as [C|[C|C]]. - apply H0; auto. subst s; exact I. subst s; exact I. - split. destruct B as [C|[C|C]]. - apply H1; auto. subst d; exact I. subst d; exact I. - eapply parmove_prop_3; eauto. -Qed. - -Lemma wt_add_op_move: - forall src res s, - Loc.type src = Loc.type res -> - loc_read_ok src -> loc_write_ok res -> - wt_block tf (add_op Omove (src :: nil) res s). -Proof. - intros. unfold add_op. simpl. - apply wt_add_move. auto. auto. auto. constructor. -Qed. - -Lemma wt_add_op_undef: - forall res s, - loc_write_ok res -> - wt_block tf (add_op Oundef nil res s). -Proof. - intros. unfold add_op. simpl. - apply wt_Bopundef. apply wt_add_spill. auto. auto with allocty. - constructor. -Qed. - -Lemma wt_add_op_others: - forall op args res s, - op <> Omove -> op <> Oundef -> - (List.map Loc.type args, Loc.type res) = type_of_operation op -> - locs_read_ok args -> - loc_write_ok res -> - wt_block tf (add_op op args res s). -Proof. - intros. unfold add_op. - caseEq (is_move_operation op args). intros. - generalize (is_move_operation_correct op args H4). tauto. - intro. assert ((List.length args <= 3)%nat). - replace (length args) with (length (fst (type_of_operation op))). - apply Allocproof.length_type_of_operation. - rewrite <- H1. simpl. apply list_length_map. - generalize (wt_regs_for args H5); intro. - generalize (wt_reg_for res); intro. - apply wt_add_reloads. auto. auto. - apply wt_Bop. auto. auto. congruence. - apply wt_add_spill. auto. auto. constructor. -Qed. - -Lemma wt_add_load: - forall chunk addr args dst s, - List.map Loc.type args = type_of_addressing addr -> - Loc.type dst = type_of_chunk chunk -> - locs_read_ok args -> - loc_write_ok dst -> - wt_block tf (add_load chunk addr args dst s). -Proof. - intros. unfold add_load. - assert ((List.length args <= 2)%nat). - replace (length args) with (length (type_of_addressing addr)). - apply Allocproof.length_type_of_addressing. - rewrite <- H. apply list_length_map. - assert ((List.length args <= 3)%nat). omega. - generalize (wt_regs_for args H4); intro. - generalize (wt_reg_for dst); intro. - apply wt_add_reloads. auto. auto. - apply wt_Bload. congruence. congruence. - apply wt_add_spill. auto. auto. constructor. -Qed. - -Lemma wt_add_store: - forall chunk addr args src s, - List.map Loc.type args = type_of_addressing addr -> - Loc.type src = type_of_chunk chunk -> - locs_read_ok args -> - loc_read_ok src -> - wt_block tf (add_store chunk addr args src s). -Proof. - intros. unfold add_store. - assert ((List.length args <= 2)%nat). - replace (length args) with (length (type_of_addressing addr)). - apply Allocproof.length_type_of_addressing. - rewrite <- H. apply list_length_map. - assert ((List.length (src :: args) <= 3)%nat). simpl. omega. - generalize (wt_regs_for (src :: args) H4); intro. - caseEq (regs_for (src :: args)). - intro. constructor. - intros rsrc rargs EQ. rewrite EQ in H5. simpl in H5. - apply wt_add_reloads. - red; intros. elim H6; intro. subst l; auto. auto. - simpl. congruence. - apply wt_Bstore. congruence. congruence. constructor. -Qed. - -Lemma wt_add_call: - forall sig los args res s, - match los with inl l => Loc.type l = Tint | inr s => True end -> - List.map Loc.type args = sig.(sig_args) -> - Loc.type res = match sig.(sig_res) with None => Tint | Some ty => ty end -> - locs_read_ok args -> - match los with inl l => loc_read_ok l | inr s => True end -> - loc_write_ok res -> - wt_block tf (add_call sig los args res s). -Proof. - intros. - assert (locs_write_ok (loc_arguments sig)). - red; intros. generalize (loc_arguments_acceptable sig l H5). - destruct l; simpl. auto. - destruct s0; try contradiction. simpl. omega. - unfold add_call. destruct los. - apply wt_add_reload. auto. simpl; congruence. - apply wt_parallel_move. rewrite loc_arguments_type. auto. - auto. auto. - apply wt_Bcall. reflexivity. - apply wt_add_spill. auto. - rewrite loc_result_type. auto. constructor. - apply wt_parallel_move. rewrite loc_arguments_type. auto. - auto. auto. - apply wt_Bcall. auto. - apply wt_add_spill. auto. - rewrite loc_result_type. auto. constructor. -Qed. - -Lemma wt_add_alloc: - forall arg res s, - Loc.type arg = Tint -> Loc.type res = Tint -> - loc_read_ok arg -> loc_write_ok res -> - wt_block tf (add_alloc arg res s). -Proof. - intros. - unfold add_alloc. apply wt_add_reload. auto. rewrite H; reflexivity. - apply wt_Balloc. apply wt_add_spill. auto. rewrite H0; reflexivity. - apply wt_Bgoto. -Qed. - -Lemma wt_add_cond: - forall cond args ifso ifnot, - List.map Loc.type args = type_of_condition cond -> - locs_read_ok args -> - wt_block tf (add_cond cond args ifso ifnot). -Proof. - intros. - assert ((List.length args) <= 3)%nat. - replace (length args) with (length (type_of_condition cond)). - apply Allocproof.length_type_of_condition. - rewrite <- H. apply list_length_map. - generalize (wt_regs_for args H1). intro. - unfold add_cond. apply wt_add_reloads. - auto. auto. - apply wt_Bcond. congruence. -Qed. - -Lemma wt_add_return: - forall sig optarg, - option_map Loc.type optarg = sig.(sig_res) -> - match optarg with None => True | Some arg => loc_read_ok arg end -> - wt_block tf (add_return sig optarg). -Proof. - intros. unfold add_return. destruct optarg. - apply wt_add_reload. auto. rewrite loc_result_type. - simpl in H. destruct (sig_res sig). congruence. discriminate. - constructor. - apply wt_Bopundef. constructor. -Qed. - -Lemma wt_add_undefs: - forall ll b, - wt_block tf b -> wt_block tf (add_undefs ll b). -Proof. - induction ll; intros. - simpl. auto. - simpl. destruct a. apply wt_Bopundef. auto. auto. -Qed. - -Lemma wt_add_entry: - forall params undefs s, - List.map Loc.type params = sig_args (RTL.fn_sig f) -> - locs_write_ok params -> - wt_block tf (add_entry (RTL.fn_sig f) params undefs s). -Proof. - set (sig := RTL.fn_sig f). - assert (sig = tf.(fn_sig)). - unfold sig. - assert (transf_fundef (Internal f) = Some (Internal tf)). - unfold transf_fundef, transf_partial_fundef. rewrite TRANSL; auto. - generalize (Allocproof.sig_function_translated _ _ H). simpl; auto. - assert (locs_read_ok (loc_parameters sig)). - red; unfold loc_parameters. intros. - generalize (list_in_map_inv _ _ _ H0). intros [l1 [EQ IN]]. - subst l. generalize (loc_arguments_acceptable _ _ IN). - destruct l1. simpl. auto. - destruct s; try contradiction. - simpl; intros. split. omega. rewrite <- H. - apply loc_arguments_bounded. auto. - intros. unfold add_entry. - apply wt_parallel_move. rewrite loc_parameters_type. auto. - auto. auto. - apply wt_add_undefs. constructor. -Qed. +Hint Resolve alloc_acceptable allocs_acceptable: allocty. +Hint Rewrite alloc_type alloc_types: allocty. +Hint Resolve valid_successor_transf: allocty. (** * Type preservation during translation from RTL to LTL *) +Ltac WT := + constructor; auto with allocty; autorewrite with allocty; auto. + Lemma wt_transf_instr: forall pc instr, - RTLtyping.wt_instr env f.(RTL.fn_sig) instr -> - wt_block tf (transf_instr f live alloc pc instr). + RTLtyping.wt_instr env f instr -> + wt_instr tf (transf_instr f live alloc pc instr). Proof. - intros. inversion H; simpl. + intros. inv H; simpl. (* nop *) - constructor. + WT. (* move *) - case (Regset.mem r live!!pc). - apply wt_add_op_move; auto with allocty. - repeat rewrite alloc_type. auto. constructor. - (* undef *) - case (Regset.mem r live!!pc). - apply wt_add_op_undef; auto with allocty. - constructor. + destruct (Regset.mem r live!!pc). + destruct (is_redundant_move Omove (r1 :: nil) r alloc); WT. + WT. (* other ops *) - case (Regset.mem res live!!pc). - apply wt_add_op_others; auto with allocty. - rewrite alloc_types. rewrite alloc_type. auto. - constructor. + destruct (Regset.mem res live!!pc). + destruct (is_redundant_move op args res alloc); WT. + WT. (* load *) - case (Regset.mem dst live!!pc). - apply wt_add_load; auto with allocty. - rewrite alloc_types. auto. rewrite alloc_type. auto. - constructor. + destruct (Regset.mem dst live!!pc); WT. (* store *) - apply wt_add_store; auto with allocty. - rewrite alloc_types. auto. rewrite alloc_type. auto. + WT. (* call *) - apply wt_add_call. - destruct ros; simpl. rewrite alloc_type; auto. auto. - rewrite alloc_types; auto. - rewrite alloc_type. auto. - auto with allocty. + WT. + destruct ros; simpl. autorewrite with allocty; auto. auto. + destruct ros; simpl; auto with allocty. + (* tailcall *) + WT. + destruct ros; simpl. autorewrite with allocty; auto. auto. destruct ros; simpl; auto with allocty. - auto with allocty. + rewrite transf_unroll; auto. (* alloc *) - apply wt_add_alloc; auto with allocty. - rewrite alloc_type; auto. rewrite alloc_type; auto. + WT. (* cond *) - apply wt_add_cond. rewrite alloc_types; auto. auto with allocty. + WT. (* return *) - apply wt_add_return. - destruct optres; simpl. rewrite alloc_type. exact H0. exact H0. + WT. + rewrite transf_unroll; simpl. + destruct optres; simpl. autorewrite with allocty. auto. auto. destruct optres; simpl; auto with allocty. Qed. -Lemma wt_transf_instrs: - let c := PTree.map (transf_instr f live alloc) (RTL.fn_code f) in - forall pc b, c!pc = Some b -> wt_block tf b. -Proof. - intros until b. - unfold c. rewrite PTree.gmap. caseEq (RTL.fn_code f)!pc. - intros instr EQ. simpl. intros. injection H; intro; subst b. - apply wt_transf_instr. eapply RTLtyping.wt_instrs; eauto. - apply wt_rtl_function. - simpl; intros; discriminate. -Qed. - -Lemma wt_transf_entrypoint: - let c := transf_entrypoint f live alloc - (PTree.map (transf_instr f live alloc) (RTL.fn_code f)) in - (forall pc b, c!pc = Some b -> wt_block tf b). -Proof. - simpl. unfold transf_entrypoint. - intros pc b. rewrite PTree.gsspec. - case (peq pc (fn_nextpc f)); intros. - injection H; intro; subst b. - apply wt_add_entry. - rewrite alloc_types. eapply RTLtyping.wt_params. apply wt_rtl_function. - auto with allocty. - apply wt_transf_instrs with pc; auto. -Qed. - End TYPING_FUNCTION. Lemma wt_transf_function: forall f tf, - transf_function f = Some tf -> wt_function tf. + transf_function f = OK tf -> wt_function tf. Proof. intros. generalize H; unfold transf_function. caseEq (type_function f). intros env TYP. @@ -527,19 +145,27 @@ Proof. with (live0 f live). caseEq (regalloc f live (live0 f live) env). intros alloc ALLOC. - intro EQ; injection EQ; intro; subst tf. - red. simpl. intros. eapply wt_transf_entrypoint; eauto. - intros; discriminate. - intros; discriminate. - intros; discriminate. -Qed. + intro EQ; injection EQ; intro. + assert (RTLtyping.wt_function f env). apply type_function_correct; auto. + inversion H1. + constructor; rewrite <- H0; simpl. + rewrite (alloc_types _ _ _ _ ALLOC). auto. + eapply regsalloc_acceptable; eauto. + eapply regalloc_norepet_norepet; eauto. + eapply regalloc_correct_2; eauto. + intros until instr. rewrite PTree.gmap. + caseEq (RTL.fn_code f)!pc; simpl; intros. + inversion H3. eapply wt_transf_instr; eauto. congruence. discriminate. + eapply valid_successor_transf; eauto. congruence. + congruence. congruence. congruence. +Qed. Lemma wt_transf_fundef: forall f tf, - transf_fundef f = Some tf -> wt_fundef tf. + transf_fundef f = OK tf -> wt_fundef tf. Proof. intros until tf; destruct f; simpl. - caseEq (transf_function f). intros g TF EQ. inversion EQ. + caseEq (transf_function f); simpl. intros g TF EQ. inversion EQ. constructor. eapply wt_transf_function; eauto. congruence. intros. inversion H. constructor. @@ -547,7 +173,7 @@ Qed. Lemma program_typing_preserved: forall (p: RTL.program) (tp: LTL.program), - transf_program p = Some tp -> + transf_program p = OK tp -> LTLtyping.wt_program tp. Proof. intros; red; intros. diff --git a/backend/Bounds.v b/backend/Bounds.v new file mode 100644 index 00000000..a0f09ce8 --- /dev/null +++ b/backend/Bounds.v @@ -0,0 +1,357 @@ +(** Computation of resource bounds forr Linear code. *) + +Require Import Coqlib. +Require Import Maps. +Require Import AST. +Require Import Op. +Require Import Locations. +Require Import Linear. +Require Import Lineartyping. +Require Import Conventions. + +(** * Resource bounds for a function *) + +(** The [bounds] record capture how many local and outgoing stack slots + and callee-save registers are used by a function. *) + +(** We demand that all bounds are positive or null, + and moreover [bound_outgoing] is greater or equal to 6. + These properties are used later to reason about the layout of + the activation record. *) + +Record bounds : Set := mkbounds { + bound_int_local: Z; + bound_float_local: Z; + bound_int_callee_save: Z; + bound_float_callee_save: Z; + bound_outgoing: Z; + bound_int_local_pos: bound_int_local >= 0; + bound_float_local_pos: bound_float_local >= 0; + bound_int_callee_save_pos: bound_int_callee_save >= 0; + bound_float_callee_save_pos: bound_float_callee_save >= 0; + bound_outgoing_pos: bound_outgoing >= 6 +}. + +(** The following predicates define the correctness of a set of bounds + for the code of a function. *) + +Section BELOW. + +Variable funct: function. +Variable b: bounds. + +Definition mreg_within_bounds (r: mreg) := + match mreg_type r with + | Tint => index_int_callee_save r < bound_int_callee_save b + | Tfloat => index_float_callee_save r < bound_float_callee_save b + end. + +Definition slot_within_bounds (s: slot) := + match s with + | Local ofs Tint => 0 <= ofs < bound_int_local b + | Local ofs Tfloat => 0 <= ofs < bound_float_local b + | Outgoing ofs ty => 14 <= ofs /\ ofs + typesize ty <= bound_outgoing b + | Incoming ofs ty => 14 <= ofs /\ ofs + typesize ty <= size_arguments funct.(fn_sig) + end. + +Definition instr_within_bounds (i: instruction) := + match i with + | Lgetstack s r => slot_within_bounds s /\ mreg_within_bounds r + | Lsetstack r s => slot_within_bounds s + | Lop op args res => mreg_within_bounds res + | Lload chunk addr args dst => mreg_within_bounds dst + | Lcall sig ros => size_arguments sig <= bound_outgoing b + | _ => True + end. + +End BELOW. + +Definition function_within_bounds (f: function) (b: bounds) : Prop := + forall instr, In instr f.(fn_code) -> instr_within_bounds f b instr. + +(** * Inference of resource bounds for a function *) + +(** The resource bounds for a function are computed by a linear scan + of its instructions. *) + +Section BOUNDS. + +Variable f: function. + +(** In the proof of the [Stacking] pass, we only need to bound the + registers written by an instruction. Therefore, this function + returns these registers, ignoring registers used only as + arguments. *) + +Definition regs_of_instr (i: instruction) : list mreg := + match i with + | Lgetstack s r => r :: nil + | Lsetstack r s => r :: nil + | Lop op args res => res :: nil + | Lload chunk addr args dst => dst :: nil + | Lstore chunk addr args src => nil + | Lcall sig ros => nil + | Ltailcall sig ros => nil + | Lalloc => nil + | Llabel lbl => nil + | Lgoto lbl => nil + | Lcond cond args lbl => nil + | Lreturn => nil + end. + +Definition slots_of_instr (i: instruction) : list slot := + match i with + | Lgetstack s r => s :: nil + | Lsetstack r s => s :: nil + | _ => nil + end. + +Definition max_over_list (A: Set) (valu: A -> Z) (l: list A) : Z := + List.fold_left (fun m l => Zmax m (valu l)) l 0. + +Definition max_over_instrs (valu: instruction -> Z) : Z := + max_over_list instruction valu f.(fn_code). + +Definition max_over_regs_of_instr (valu: mreg -> Z) (i: instruction) : Z := + max_over_list mreg valu (regs_of_instr i). + +Definition max_over_slots_of_instr (valu: slot -> Z) (i: instruction) : Z := + max_over_list slot valu (slots_of_instr i). + +Definition max_over_regs_of_funct (valu: mreg -> Z) : Z := + max_over_instrs (max_over_regs_of_instr valu). + +Definition max_over_slots_of_funct (valu: slot -> Z) : Z := + max_over_instrs (max_over_slots_of_instr valu). + +Definition int_callee_save (r: mreg) := 1 + index_int_callee_save r. + +Definition float_callee_save (r: mreg) := 1 + index_float_callee_save r. + +Definition int_local (s: slot) := + match s with Local ofs Tint => 1 + ofs | _ => 0 end. + +Definition float_local (s: slot) := + match s with Local ofs Tfloat => 1 + ofs | _ => 0 end. + +Definition outgoing_slot (s: slot) := + match s with Outgoing ofs ty => ofs + typesize ty | _ => 0 end. + +Definition outgoing_space (i: instruction) := + match i with Lcall sig _ => size_arguments sig | _ => 0 end. + +Lemma max_over_list_pos: + forall (A: Set) (valu: A -> Z) (l: list A), + max_over_list A valu l >= 0. +Proof. + intros until valu. unfold max_over_list. + assert (forall l z, fold_left (fun x y => Zmax x (valu y)) l z >= z). + induction l; simpl; intros. + omega. apply Zge_trans with (Zmax z (valu a)). + auto. apply Zle_ge. apply Zmax1. auto. +Qed. + +Lemma max_over_slots_of_funct_pos: + forall (valu: slot -> Z), max_over_slots_of_funct valu >= 0. +Proof. + intros. unfold max_over_slots_of_funct. + unfold max_over_instrs. apply max_over_list_pos. +Qed. + +Lemma max_over_regs_of_funct_pos: + forall (valu: mreg -> Z), max_over_regs_of_funct valu >= 0. +Proof. + intros. unfold max_over_regs_of_funct. + unfold max_over_instrs. apply max_over_list_pos. +Qed. + +Remark Zmax_6: forall x, Zmax 6 x >= 6. +Proof. + intros. apply Zle_ge. apply Zmax_bound_l. omega. +Qed. + +Definition function_bounds := + mkbounds + (max_over_slots_of_funct int_local) + (max_over_slots_of_funct float_local) + (max_over_regs_of_funct int_callee_save) + (max_over_regs_of_funct float_callee_save) + (Zmax 6 + (Zmax (max_over_instrs outgoing_space) + (max_over_slots_of_funct outgoing_slot))) + (max_over_slots_of_funct_pos int_local) + (max_over_slots_of_funct_pos float_local) + (max_over_regs_of_funct_pos int_callee_save) + (max_over_regs_of_funct_pos float_callee_save) + (Zmax_6 _). + +(** We now show the correctness of the inferred bounds. *) + +Lemma max_over_list_bound: + forall (A: Set) (valu: A -> Z) (l: list A) (x: A), + In x l -> valu x <= max_over_list A valu l. +Proof. + intros until x. unfold max_over_list. + assert (forall c z, + let f := fold_left (fun x y => Zmax x (valu y)) c z in + z <= f /\ (In x c -> valu x <= f)). + induction c; simpl; intros. + split. omega. tauto. + elim (IHc (Zmax z (valu a))); intros. + split. apply Zle_trans with (Zmax z (valu a)). apply Zmax1. auto. + intro H1; elim H1; intro. + subst a. apply Zle_trans with (Zmax z (valu x)). + apply Zmax2. auto. auto. + intro. elim (H l 0); intros. auto. +Qed. + +Lemma max_over_instrs_bound: + forall (valu: instruction -> Z) i, + In i f.(fn_code) -> valu i <= max_over_instrs valu. +Proof. + intros. unfold max_over_instrs. apply max_over_list_bound; auto. +Qed. + +Lemma max_over_regs_of_funct_bound: + forall (valu: mreg -> Z) i r, + In i f.(fn_code) -> In r (regs_of_instr i) -> + valu r <= max_over_regs_of_funct valu. +Proof. + intros. unfold max_over_regs_of_funct. + apply Zle_trans with (max_over_regs_of_instr valu i). + unfold max_over_regs_of_instr. apply max_over_list_bound. auto. + apply max_over_instrs_bound. auto. +Qed. + +Lemma max_over_slots_of_funct_bound: + forall (valu: slot -> Z) i s, + In i f.(fn_code) -> In s (slots_of_instr i) -> + valu s <= max_over_slots_of_funct valu. +Proof. + intros. unfold max_over_slots_of_funct. + apply Zle_trans with (max_over_slots_of_instr valu i). + unfold max_over_slots_of_instr. apply max_over_list_bound. auto. + apply max_over_instrs_bound. auto. +Qed. + +Lemma int_callee_save_bound: + forall i r, + In i f.(fn_code) -> In r (regs_of_instr i) -> + index_int_callee_save r < bound_int_callee_save function_bounds. +Proof. + intros. apply Zlt_le_trans with (int_callee_save r). + unfold int_callee_save. omega. + unfold function_bounds, bound_int_callee_save. + eapply max_over_regs_of_funct_bound; eauto. +Qed. + +Lemma float_callee_save_bound: + forall i r, + In i f.(fn_code) -> In r (regs_of_instr i) -> + index_float_callee_save r < bound_float_callee_save function_bounds. +Proof. + intros. apply Zlt_le_trans with (float_callee_save r). + unfold float_callee_save. omega. + unfold function_bounds, bound_float_callee_save. + eapply max_over_regs_of_funct_bound; eauto. +Qed. + +Lemma int_local_slot_bound: + forall i ofs, + In i f.(fn_code) -> In (Local ofs Tint) (slots_of_instr i) -> + ofs < bound_int_local function_bounds. +Proof. + intros. apply Zlt_le_trans with (int_local (Local ofs Tint)). + unfold int_local. omega. + unfold function_bounds, bound_int_local. + eapply max_over_slots_of_funct_bound; eauto. +Qed. + +Lemma float_local_slot_bound: + forall i ofs, + In i f.(fn_code) -> In (Local ofs Tfloat) (slots_of_instr i) -> + ofs < bound_float_local function_bounds. +Proof. + intros. apply Zlt_le_trans with (float_local (Local ofs Tfloat)). + unfold float_local. omega. + unfold function_bounds, bound_float_local. + eapply max_over_slots_of_funct_bound; eauto. +Qed. + +Lemma outgoing_slot_bound: + forall i ofs ty, + In i f.(fn_code) -> In (Outgoing ofs ty) (slots_of_instr i) -> + ofs + typesize ty <= bound_outgoing function_bounds. +Proof. + intros. change (ofs + typesize ty) with (outgoing_slot (Outgoing ofs ty)). + unfold function_bounds, bound_outgoing. + apply Zmax_bound_r. apply Zmax_bound_r. + eapply max_over_slots_of_funct_bound; eauto. +Qed. + +Lemma size_arguments_bound: + forall sig ros, + In (Lcall sig ros) f.(fn_code) -> + size_arguments sig <= bound_outgoing function_bounds. +Proof. + intros. change (size_arguments sig) with (outgoing_space (Lcall sig ros)). + unfold function_bounds, bound_outgoing. + apply Zmax_bound_r. apply Zmax_bound_l. + apply max_over_instrs_bound; auto. +Qed. + +(** Consequently, all machine registers or stack slots mentioned by one + of the instructions of function [f] are within bounds. *) + +Lemma mreg_is_within_bounds: + forall i, In i f.(fn_code) -> + forall r, In r (regs_of_instr i) -> + mreg_within_bounds function_bounds r. +Proof. + intros. unfold mreg_within_bounds. + case (mreg_type r). + eapply int_callee_save_bound; eauto. + eapply float_callee_save_bound; eauto. +Qed. + +Lemma slot_is_within_bounds: + forall i, In i f.(fn_code) -> + forall s, In s (slots_of_instr i) -> Lineartyping.slot_valid f s -> + slot_within_bounds f function_bounds s. +Proof. + intros. unfold slot_within_bounds. + destruct s. + destruct t. + split. exact H1. eapply int_local_slot_bound; eauto. + split. exact H1. eapply float_local_slot_bound; eauto. + exact H1. + split. exact H1. eapply outgoing_slot_bound; eauto. +Qed. + +(** It follows that every instruction in the function is within bounds, + in the sense of the [instr_within_bounds] predicate. *) + +Lemma instr_is_within_bounds: + forall i, + In i f.(fn_code) -> + Lineartyping.wt_instr f i -> + instr_within_bounds f function_bounds i. +Proof. + intros; + destruct i; + generalize (mreg_is_within_bounds _ H); generalize (slot_is_within_bounds _ H); + simpl; intros; auto. + inv H0. split; auto. + inv H0; auto. + eapply size_arguments_bound; eauto. +Qed. + +Lemma function_is_within_bounds: + Lineartyping.wt_code f f.(fn_code) -> + function_within_bounds f function_bounds. +Proof. + intros; red; intros. apply instr_is_within_bounds; auto. +Qed. + +End BOUNDS. + diff --git a/backend/CSE.v b/backend/CSE.v index 68010133..a7901d61 100644 --- a/backend/CSE.v +++ b/backend/CSE.v @@ -251,7 +251,7 @@ Definition equation_holds (vres: valnum) (rh: rhs) : Prop := match rh with | Op op vl => - eval_operation ge sp op (List.map valuation vl) = + eval_operation ge sp op (List.map valuation vl) m = Some (valuation vres) | Load chunk addr vl => exists a, @@ -337,6 +337,8 @@ Definition transfer (f: function) (pc: node) (before: numbering) := kill_loads before | Icall sig ros args res s => empty_numbering + | Itailcall sig ros args => + empty_numbering | Ialloc arg res s => add_unknown before res | Icond cond args ifso ifnot => @@ -373,7 +375,6 @@ Definition is_trivial_op (op: operation) : bool := | Ointconst _ => true | Oaddrsymbol _ _ => true | Oaddrstack _ => true - | Oundef => true | _ => false end. @@ -426,7 +427,8 @@ Definition transf_function (f: function) : function := f.(fn_nextpc) (transf_code_wf f approxs f.(fn_code_wf)). -Definition transf_fundef := AST.transf_fundef transf_function. +Definition transf_fundef (f: fundef) : fundef := + AST.transf_fundef transf_function f. Definition transf_program (p: program) : program := transform_program transf_fundef p. diff --git a/backend/CSEproof.v b/backend/CSEproof.v index 79657c55..d46a39f1 100644 --- a/backend/CSEproof.v +++ b/backend/CSEproof.v @@ -9,6 +9,7 @@ Require Import Values. Require Import Mem. Require Import Events. Require Import Globalenvs. +Require Import Smallstep. Require Import Op. Require Import Registers. Require Import RTL. @@ -218,6 +219,7 @@ Proof. apply wf_add_load; auto. apply wf_kill_loads; auto. apply wf_empty_numbering. + apply wf_empty_numbering. apply wf_add_unknown; auto. Qed. @@ -387,7 +389,7 @@ Definition rhs_evals_to (valu: valnum -> val) (rh: rhs) (v: val) : Prop := match rh with | Op op vl => - eval_operation ge sp op (List.map valu vl) = Some v + eval_operation ge sp op (List.map valu vl) m = Some v | Load chunk addr vl => exists a, eval_addressing ge sp addr (List.map valu vl) = Some a /\ @@ -468,7 +470,7 @@ Lemma add_op_satisfiable: forall n rs op args dst v, wf_numbering n -> numbering_satisfiable ge sp rs m n -> - eval_operation ge sp op rs##args = Some v -> + eval_operation ge sp op rs##args m = Some v -> numbering_satisfiable ge sp (rs#dst <- v) m (add_op n dst op args). Proof. intros. inversion H0. @@ -545,7 +547,7 @@ Proof. intros. destruct H0 as [valu [A B]]. exists valu; split; intros. generalize (A _ _ H0). destruct rh; simpl. - auto. + intro. eapply eval_operation_alloc; eauto. intros [addr [C D]]. exists addr; split. auto. destruct addr; simpl in *; try discriminate. eapply Mem.load_alloc_other; eauto. @@ -569,17 +571,21 @@ Proof. Qed. Lemma kill_load_satisfiable: - forall n rs m', + forall n rs chunk addr v m', + Mem.storev chunk m addr v = Some m' -> numbering_satisfiable ge sp rs m n -> numbering_satisfiable ge sp rs m' (kill_loads n). Proof. - intros. inversion H. inversion H0. + intros. inversion H0. inversion H1. generalize (kill_load_eqs_incl n.(num_eqs)). intro. exists x. split; intros. - generalize (H1 _ _ (H3 _ H4)). - generalize (kill_load_eqs_ops _ _ _ H4). - destruct rh; simpl. auto. tauto. - apply H2. assumption. + generalize (H2 _ _ (H4 _ H5)). + generalize (kill_load_eqs_ops _ _ _ H5). + destruct rh; simpl. + intros. destruct addr; simpl in H; try discriminate. + eapply eval_operation_store; eauto. + tauto. + apply H3. assumption. Qed. (** Correctness of [reg_valnum]: if it returns a register [r], @@ -633,7 +639,7 @@ Lemma find_op_correct: wf_numbering n -> numbering_satisfiable ge sp rs m n -> find_op n op args = Some r -> - eval_operation ge sp op rs##args = Some rs#r. + eval_operation ge sp op rs##args m = Some rs#r. Proof. intros until r. intros WF [valu NH]. unfold find_op. caseEq (valnum_regs n args). intros n' vl VR FIND. @@ -664,29 +670,6 @@ Qed. End SATISFIABILITY. -(** The transfer function preserves satisfiability of numberings. *) - -Lemma transfer_correct: - forall ge c sp pc rs m t pc' rs' m' f n, - exec_instr ge c sp pc rs m t pc' rs' m' -> - c = f.(fn_code) -> - wf_numbering n -> - numbering_satisfiable ge sp rs m n -> - numbering_satisfiable ge sp rs' m' (transfer f pc n). -Proof. - induction 1; intros; subst c; unfold transfer; rewrite H; auto. - (* Iop *) - eapply add_op_satisfiable; eauto. - (* Iload *) - eapply add_load_satisfiable; eauto. - (* Istore *) - eapply kill_load_satisfiable; eauto. - (* Icall *) - apply empty_numbering_satisfiable. - (* Ialloc *) - apply add_unknown_satisfiable; auto. eapply alloc_satisfiable; eauto. -Qed. - (** The numberings associated to each instruction by the static analysis are inductively satisfiable, in the following sense: the numbering at the function entry point is satisfiable, and for any RTL execution @@ -694,43 +677,25 @@ Qed. satisfiability at [pc']. *) Theorem analysis_correct_1: - forall ge c sp pc rs m t pc' rs' m' f, - exec_instr ge c sp pc rs m t pc' rs' m' -> - c = f.(fn_code) -> - numbering_satisfiable ge sp rs m (analyze f)!!pc -> - numbering_satisfiable ge sp rs' m' (analyze f)!!pc'. + forall ge sp rs m f pc pc', + In pc' (successors f pc) -> + numbering_satisfiable ge sp rs m (transfer f pc (analyze f)!!pc) -> + numbering_satisfiable ge sp rs m (analyze f)!!pc'. Proof. - intros until f. intros EXEC CODE. + intros until pc'. generalize (wf_analyze f pc). unfold analyze. caseEq (Solver.fixpoint (successors f) (fn_nextpc f) (transfer f) (fn_entrypoint f)). - intros res FIXPOINT WF NS. - assert (numbering_satisfiable ge sp rs' m' (transfer f pc res!!pc)). - eapply transfer_correct; eauto. + intros res FIXPOINT WF SUCC NS. assert (Numbering.ge res!!pc' (transfer f pc res!!pc)). eapply Solver.fixpoint_solution; eauto. elim (fn_code_wf f pc); intro. auto. - rewrite <- CODE in H0. - elim (exec_instr_present _ _ _ _ _ _ _ _ _ _ EXEC H0). - rewrite CODE in EXEC. eapply successors_correct; eauto. - apply H0. auto. + unfold successors in SUCC; rewrite H in SUCC; contradiction. + apply H. auto. intros. rewrite PMap.gi. apply empty_numbering_satisfiable. Qed. -Theorem analysis_correct_N: - forall ge c sp pc rs m t pc' rs' m' f, - exec_instrs ge c sp pc rs m t pc' rs' m' -> - c = f.(fn_code) -> - numbering_satisfiable ge sp rs m (analyze f)!!pc -> - numbering_satisfiable ge sp rs' m' (analyze f)!!pc'. -Proof. - induction 1; intros. - assumption. - eapply analysis_correct_1; eauto. - eauto. -Qed. - Theorem analysis_correct_entry: forall ge sp rs m f, numbering_satisfiable ge sp rs m (analyze f)!!(f.(fn_entrypoint)). @@ -773,49 +738,67 @@ Lemma funct_ptr_translated: Genv.find_funct_ptr tge b = Some (transf_fundef f). Proof (@Genv.find_funct_ptr_transf _ _ _ transf_fundef prog). -Lemma sig_translated: - forall (f: RTL.fundef), - funsig (transf_fundef f) = funsig f. +Lemma sig_preserved: + forall f, funsig (transf_fundef f) = funsig f. Proof. - intros; case f; intros; reflexivity. + destruct f; reflexivity. +Qed. + +Lemma find_function_translated: + forall ros rs f, + find_function ge ros rs = Some f -> + find_function tge ros rs = Some (transf_fundef f). +Proof. + intros until f; destruct ros; simpl. + intro. apply functions_translated; auto. + rewrite symbols_preserved. destruct (Genv.find_symbol ge i); intro. + apply funct_ptr_translated; auto. + discriminate. Qed. (** The proof of semantic preservation is a simulation argument using diagrams of the following form: << - pc, rs, m ------------------------ pc, rs, m - | | - | | - v v - pc', rs', m' --------------------- pc', rs', m' + st1 --------------- st2 + | | + t| |t + | | + v v + st1'--------------- st2' >> Left: RTL execution in the original program. Right: RTL execution in - the optimized program. Precondition (top): the numbering at [pc] - (returned by the static analysis) is satisfiable. Postcondition: none. + the optimized program. Precondition (top) and postcondition (bottom): + agreement between the states, including the fact that + the numbering at [pc] (returned by the static analysis) is satisfiable. *) -Definition exec_instr_prop - (c: code) (sp: val) - (pc: node) (rs: regset) (m: mem) (t: trace) - (pc': node) (rs': regset) (m': mem) : Prop := - forall f - (CF: c = f.(RTL.fn_code)) - (SAT: numbering_satisfiable ge sp rs m (analyze f)!!pc), - exec_instr tge (transf_code (analyze f) c) sp pc rs m t pc' rs' m'. - -Definition exec_instrs_prop - (c: code) (sp: val) - (pc: node) (rs: regset) (m: mem) (t: trace) - (pc': node) (rs': regset) (m': mem) : Prop := - forall f - (CF: c = f.(RTL.fn_code)) - (SAT: numbering_satisfiable ge sp rs m (analyze f)!!pc), - exec_instrs tge (transf_code (analyze f) c) sp pc rs m t pc' rs' m'. - -Definition exec_function_prop - (f: RTL.fundef) (args: list val) (m: mem) (t: trace) - (res: val) (m': mem) : Prop := - exec_function tge (transf_fundef f) args m t res m'. +Inductive match_stackframes: stackframe -> stackframe -> Prop := + match_stackframes_intro: + forall res c sp pc rs f, + c = f.(RTL.fn_code) -> + (forall v m, numbering_satisfiable ge sp (rs#res <- v) m (analyze f)!!pc) -> + match_stackframes + (Stackframe res c sp pc rs) + (Stackframe res (transf_code (analyze f) c) sp pc rs). + +Inductive match_states: state -> state -> Prop := + | match_states_intro: + forall s c sp pc rs m s' f + (CF: c = f.(RTL.fn_code)) + (SAT: numbering_satisfiable ge sp rs m (analyze f)!!pc) + (STACKS: list_forall2 match_stackframes s s'), + match_states (State s c sp pc rs m) + (State s' (transf_code (analyze f) c) sp pc rs m) + | match_states_call: + forall s f args m s', + list_forall2 match_stackframes s s' -> + match_states (Callstate s f args m) + (Callstate s' (transf_fundef f) args m) + | match_states_return: + forall s s' v m, + list_forall2 match_stackframes s s' -> + match_states (Returnstate s v m) + (Returnstate s' v m). Ltac TransfInstr := match goal with @@ -826,34 +809,49 @@ Ltac TransfInstr := unfold option_map; rewrite H1; reflexivity ] end. -(** The proof of simulation is by structural induction on the evaluation - derivation for the source program. *) +(** The proof of simulation is a case analysis over the transition + in the source code. *) -Lemma transf_function_correct: - forall f args m t res m', - exec_function ge f args m t res m' -> - exec_function_prop f args m t res m'. +Lemma transf_step_correct: + forall s1 t s2, step ge s1 t s2 -> + forall s1' (MS: match_states s1 s1'), + exists s2', step tge s1' t s2' /\ match_states s2 s2'. Proof. - apply (exec_function_ind_3 ge - exec_instr_prop exec_instrs_prop exec_function_prop); - intros; red; intros; try TransfInstr. + induction 1; intros; inv MS; try (TransfInstr; intro C). + (* Inop *) - intro; apply exec_Inop; auto. + exists (State s' (transf_code (analyze f) (fn_code f)) sp pc' rs m); split. + apply exec_Inop; auto. + econstructor; eauto. + apply analysis_correct_1 with pc. + unfold successors; rewrite H; auto with coqlib. + unfold transfer; rewrite H; auto. + (* Iop *) - assert (eval_operation tge sp op rs##args = Some v). + exists (State s' (transf_code (analyze f) (fn_code f)) sp pc' (rs#res <- v) m); split. + assert (eval_operation tge sp op rs##args m = Some v). rewrite <- H0. apply eval_operation_preserved. exact symbols_preserved. + generalize C; clear C. case (is_trivial_op op). intro. eapply exec_Iop'; eauto. caseEq (find_op (analyze f)!!pc op args). intros r FIND CODE. eapply exec_Iop'; eauto. simpl. - assert (eval_operation ge sp op rs##args = Some rs#r). + assert (eval_operation ge sp op rs##args m = Some rs#r). eapply find_op_correct; eauto. eapply wf_analyze; eauto. congruence. - intros. eapply exec_Iop'; eauto. + intros. eapply exec_Iop'; eauto. + econstructor; eauto. + apply analysis_correct_1 with pc. + unfold successors; rewrite H; auto with coqlib. + unfold transfer; rewrite H. + eapply add_op_satisfiable; eauto. apply wf_analyze. + (* Iload *) + exists (State s' (transf_code (analyze f) (fn_code f)) sp pc' (rs#dst <- v) m); split. assert (eval_addressing tge sp addr rs##args = Some a). rewrite <- H0. apply eval_addressing_preserved. exact symbols_preserved. + generalize C; clear C. caseEq (find_load (analyze f)!!pc chunk addr args). intros r FIND CODE. eapply exec_Iop'; eauto. simpl. assert (exists a, eval_addressing ge sp addr rs##args = Some a @@ -862,52 +860,125 @@ Proof. eapply wf_analyze; eauto. elim H3; intros a' [A B]. congruence. - intros. eapply exec_Iload'; eauto. + intros. eapply exec_Iload'; eauto. + econstructor; eauto. + apply analysis_correct_1 with pc. + unfold successors; rewrite H; auto with coqlib. + unfold transfer; rewrite H. + eapply add_load_satisfiable; eauto. apply wf_analyze. + (* Istore *) + exists (State s' (transf_code (analyze f) (fn_code f)) sp pc' rs m'); split. assert (eval_addressing tge sp addr rs##args = Some a). rewrite <- H0. apply eval_addressing_preserved. exact symbols_preserved. - intro; eapply exec_Istore; eauto. + eapply exec_Istore; eauto. + econstructor; eauto. + apply analysis_correct_1 with pc. + unfold successors; rewrite H; auto with coqlib. + unfold transfer; rewrite H. + eapply kill_load_satisfiable; eauto. + (* Icall *) - assert (find_function tge ros rs = Some (transf_fundef f)). - destruct ros; simpl in H0; simpl. - apply functions_translated; auto. - rewrite symbols_preserved. destruct (Genv.find_symbol ge i). - apply funct_ptr_translated; auto. discriminate. - intro; eapply exec_Icall with (f := transf_fundef f); eauto. - generalize (sig_translated f); congruence. + exploit find_function_translated; eauto. intro FIND'. + econstructor; split. + eapply exec_Icall with (f := transf_fundef f); eauto. + apply sig_preserved. + econstructor; eauto. + constructor; auto. + econstructor; eauto. + intros. apply analysis_correct_1 with pc. + unfold successors; rewrite H; auto with coqlib. + unfold transfer; rewrite H. + apply empty_numbering_satisfiable. + + (* Itailcall *) + exploit find_function_translated; eauto. intro FIND'. + econstructor; split. + eapply exec_Itailcall with (f := transf_fundef f); eauto. + apply sig_preserved. + econstructor; eauto. + (* Ialloc *) - intro; eapply exec_Ialloc; eauto. + exists (State s' (transf_code (analyze f) (fn_code f)) sp pc' (rs#res <- (Vptr b Int.zero)) m'); split. + eapply exec_Ialloc; eauto. + econstructor; eauto. + apply analysis_correct_1 with pc. + unfold successors; rewrite H; auto with coqlib. + unfold transfer; rewrite H. + apply add_unknown_satisfiable. apply wf_analyze; auto. + eapply alloc_satisfiable; eauto. + (* Icond true *) - intro; eapply exec_Icond_true; eauto. + econstructor; split. + eapply exec_Icond_true; eauto. + econstructor; eauto. + apply analysis_correct_1 with pc. + unfold successors; rewrite H; auto with coqlib. + unfold transfer; rewrite H; auto. + (* Icond false *) - intro; eapply exec_Icond_false; eauto. - (* refl *) - apply exec_refl. - (* one *) - apply exec_one; auto. - (* trans *) - eapply exec_trans; eauto. apply H2; auto. - eapply analysis_correct_N; eauto. + econstructor; split. + eapply exec_Icond_false; eauto. + econstructor; eauto. + apply analysis_correct_1 with pc. + unfold successors; rewrite H; auto with coqlib. + unfold transfer; rewrite H; auto. + + (* Ireturn *) + econstructor; split. + eapply exec_Ireturn; eauto. + constructor; auto. + (* internal function *) - intro. unfold transf_function; simpl; eapply exec_funct_internal; simpl; eauto. - eapply H1; eauto. eapply analysis_correct_entry; eauto. + simpl. econstructor; split. + eapply exec_function_internal; eauto. + simpl. econstructor; eauto. + apply analysis_correct_entry. + (* external function *) - unfold transf_function; simpl. apply exec_funct_external; auto. + simpl. econstructor; split. + eapply exec_function_external; eauto. + econstructor; eauto. + + (* return *) + inv H3. inv H1. + econstructor; split. + eapply exec_return; eauto. + econstructor; eauto. +Qed. + +Lemma transf_initial_states: + forall st1, initial_state prog st1 -> + exists st2, initial_state tprog st2 /\ match_states st1 st2. +Proof. + intros. inversion H. + exists (Callstate nil (transf_fundef f) nil (Genv.init_mem tprog)); split. + econstructor; eauto. + change (prog_main tprog) with (prog_main prog). + rewrite symbols_preserved. eauto. + apply funct_ptr_translated; auto. + rewrite <- H2. apply sig_preserved. + replace (Genv.init_mem tprog) with (Genv.init_mem prog). + constructor. constructor. auto. + symmetry. unfold tprog, transf_program. apply Genv.init_mem_transf. +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 H4. constructor. Qed. Theorem transf_program_correct: - forall (t: trace) (r: val), - exec_program prog t r -> exec_program tprog t r. -Proof. - intros t r [fptr [f [m [FINDS [FINDF [SIG EXEC]]]]]]. - red. exists fptr; exists (transf_fundef f); exists m. - split. change (prog_main tprog) with (prog_main prog). - rewrite symbols_preserved. assumption. - split. apply funct_ptr_translated; auto. - split. generalize (sig_translated f); congruence. - apply transf_function_correct. - unfold tprog, transf_program. rewrite Genv.init_mem_transf. - exact EXEC. + forall (beh: program_behavior), + exec_program prog beh -> exec_program tprog beh. +Proof. + unfold exec_program; intros. + eapply simulation_step_preservation; eauto. + eexact transf_initial_states. + eexact transf_final_states. + exact transf_step_correct. Qed. End PRESERVATION. diff --git a/backend/Cmconstr.v b/backend/Cmconstr.v deleted file mode 100644 index 2cc947c7..00000000 --- a/backend/Cmconstr.v +++ /dev/null @@ -1,1011 +0,0 @@ -(** Smart constructors for Cminor. This library provides functions - for building Cminor expressions and statements, especially expressions - consisting of operator applications. These functions examine their - arguments to choose cheaper forms of operators whenever possible. - - For instance, [add e1 e2] will return a Cminor expression semantically - equivalent to [Eop Oadd (e1 ::: e2 ::: Enil)], but will use a - [Oaddimm] operator if one of the arguments is an integer constant, - or suppress the addition altogether if one of the arguments is the - null integer. In passing, we perform operator reassociation - ([(e + c1) * c2] becomes [(e * c2) + (c1 * c2)]) and a small amount - of constant propagation. - - In more general terms, the purpose of the smart constructors is twofold: -- Perform instruction selection (for operators, loads, stores and - conditional expressions); -- Abstract over processor dependencies in operators and addressing modes, - providing Cminor providers with processor-independent ways of constructing - Cminor terms. -*) - -Require Import Coqlib. -Require Import Compare_dec. -Require Import Maps. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import Mem. -Require Import Op. -Require Import Globalenvs. -Require Import Cminor. - -Infix ":::" := Econs (at level 60, right associativity) : cminor_scope. - -Open Scope cminor_scope. - -(** * Lifting of let-bound variables *) - -(** Some of the smart constructors, as well as the Cminor producers, - generate [Elet] constructs to share the evaluation of a subexpression. - Owing to the use of de Bruijn indices for let-bound variables, - we need to shift de Bruijn indices when an expression [b] is put - in a [Elet a b] context. *) - -Fixpoint lift_expr (p: nat) (a: expr) {struct a}: expr := - match a with - | Evar id => Evar id - | Eop op bl => Eop op (lift_exprlist p bl) - | Eload chunk addr bl => Eload chunk addr (lift_exprlist p bl) - | Estore chunk addr bl c => - Estore chunk addr (lift_exprlist p bl) (lift_expr p c) - | Ecall sig b cl => Ecall sig (lift_expr p b) (lift_exprlist p cl) - | Econdition b c d => - Econdition (lift_condexpr p b) (lift_expr p c) (lift_expr p d) - | Elet b c => Elet (lift_expr p b) (lift_expr (S p) c) - | Eletvar n => - if le_gt_dec p n then Eletvar (S n) else Eletvar n - | Ealloc b => - Ealloc (lift_expr p b) - end - -with lift_condexpr (p: nat) (a: condexpr) {struct a}: condexpr := - match a with - | CEtrue => CEtrue - | CEfalse => CEfalse - | CEcond cond bl => CEcond cond (lift_exprlist p bl) - | CEcondition b c d => - CEcondition (lift_condexpr p b) (lift_condexpr p c) (lift_condexpr p d) - end - -with lift_exprlist (p: nat) (a: exprlist) {struct a}: exprlist := - match a with - | Enil => Enil - | Econs b cl => Econs (lift_expr p b) (lift_exprlist p cl) - end. - -Definition lift (a: expr): expr := lift_expr O a. - -(** * Smart constructors for operators *) - -Definition negint (e: expr) := Eop (Osubimm Int.zero) (e ::: Enil). -Definition negfloat (e: expr) := Eop Onegf (e ::: Enil). -Definition absfloat (e: expr) := Eop Oabsf (e ::: Enil). -Definition intoffloat (e: expr) := Eop Ointoffloat (e ::: Enil). -Definition floatofint (e: expr) := Eop Ofloatofint (e ::: Enil). -Definition floatofintu (e: expr) := Eop Ofloatofintu (e ::: Enil). - -(** ** Integer logical negation *) - -(** The natural way to write smart constructors is by pattern-matching - on their arguments, recognizing cases where cheaper operators - or combined operators are applicable. For instance, integer logical - negation has three special cases (not-and, not-or and not-xor), - along with a default case that uses not-or over its arguments and itself. - This is written naively as follows: -<< -Definition notint (e: expr) := - match e with - | Eop Oand (t1:::t2:::Enil) => Eop Onand (t1:::t2:::Enil) - | Eop Oor (t1:::t2:::Enil) => Eop Onor (t1:::t2:::Enil) - | Eop Oxor (t1:::t2:::Enil) => Eop Onxor (t1:::t2:::Enil) - | _ => Elet(e, Eop Onor (Eletvar O ::: Eletvar O ::: Enil) - end. ->> - However, Coq expands complex pattern-matchings like the above into - elementary matchings over all constructors of an inductive type, - resulting in much duplication of the final catch-all case. - Such duplications generate huge executable code and duplicate - cases in the correctness proofs. - - To limit this duplication, we use the following trick due to - Yves Bertot. We first define a dependent inductive type that - characterizes the expressions that match each of the 4 cases of interest. -*) - -Inductive notint_cases: forall (e: expr), Set := - | notint_case1: - forall (t1: expr) (t2: expr), - notint_cases (Eop Oand (t1:::t2:::Enil)) - | notint_case2: - forall (t1: expr) (t2: expr), - notint_cases (Eop Oor (t1:::t2:::Enil)) - | notint_case3: - forall (t1: expr) (t2: expr), - notint_cases (Eop Oxor (t1:::t2:::Enil)) - | notint_default: - forall (e: expr), - notint_cases e. - -(** We then define a classification function that takes an expression - and return in which case it falls. Note that the catch-all case - [notint_default] does not state that it is mutually exclusive with - the first three, more specific cases. The classification function - nonetheless chooses the specific cases in preference to the catch-all - case. *) - -Definition notint_match (e: expr) := - match e as z1 return notint_cases z1 with - | Eop Oand (t1:::t2:::Enil) => - notint_case1 t1 t2 - | Eop Oor (t1:::t2:::Enil) => - notint_case2 t1 t2 - | Eop Oxor (t1:::t2:::Enil) => - notint_case3 t1 t2 - | e => - notint_default e - end. - -(** Finally, the [notint] function we need is defined by a 4-case match - over the result of the classification function. Thus, no duplication - of the right-hand sides of this match occur, and the proof has only - 4 cases to consider (it proceeds by case over [notint_match e]). - Since the default case is not obviously exclusive with the three - specific cases, it is important that its right-hand side is - semantically correct for all possible values of [e], which is the - case here and for all other smart constructors. *) - -Definition notint (e: expr) := - match notint_match e with - | notint_case1 t1 t2 => - Eop Onand (t1:::t2:::Enil) - | notint_case2 t1 t2 => - Eop Onor (t1:::t2:::Enil) - | notint_case3 t1 t2 => - Eop Onxor (t1:::t2:::Enil) - | notint_default e => - Elet e (Eop Onor (Eletvar O ::: Eletvar O ::: Enil)) - end. - -(** This programming pattern will be applied systematically for the - other smart constructors in this file. *) - -(** ** Boolean negation *) - -Definition notbool_base (e: expr) := - Eop (Ocmp (Ccompuimm Ceq Int.zero)) (e ::: Enil). - -Fixpoint notbool (e: expr) {struct e} : expr := - match e with - | Eop (Ointconst n) Enil => - Eop (Ointconst (if Int.eq n Int.zero then Int.one else Int.zero)) Enil - | Eop (Ocmp cond) args => - Eop (Ocmp (negate_condition cond)) args - | Econdition e1 e2 e3 => - Econdition e1 (notbool e2) (notbool e3) - | _ => - notbool_base e - end. - -(** ** Integer addition and pointer addition *) - -(* -Definition addimm (n: int) (e: expr) := - if Int.eq n Int.zero then e else - match e with - | Eop (Ointconst m) Enil => Eop (Ointconst(Int.add n m)) Enil - | Eop (Oaddrsymbol s m) Enil => Eop (Oaddrsymbol s (Int.add n m)) Enil - | Eop (Oaddrstack m) Enil => Eop (Oaddrstack (Int.add n m)) Enil - | Eop (Oaddimm m) (t ::: Enil) => Eop (Oaddimm(Int.add n m)) (t ::: Enil) - | _ => Eop (Oaddimm n) (e ::: Enil) - end. -*) - -(** Addition of an integer constant. *) - -Inductive addimm_cases: forall (e: expr), Set := - | addimm_case1: - forall (m: int), - addimm_cases (Eop (Ointconst m) Enil) - | addimm_case2: - forall (s: ident) (m: int), - addimm_cases (Eop (Oaddrsymbol s m) Enil) - | addimm_case3: - forall (m: int), - addimm_cases (Eop (Oaddrstack m) Enil) - | addimm_case4: - forall (m: int) (t: expr), - addimm_cases (Eop (Oaddimm m) (t ::: Enil)) - | addimm_default: - forall (e: expr), - addimm_cases e. - -Definition addimm_match (e: expr) := - match e as z1 return addimm_cases z1 with - | Eop (Ointconst m) Enil => - addimm_case1 m - | Eop (Oaddrsymbol s m) Enil => - addimm_case2 s m - | Eop (Oaddrstack m) Enil => - addimm_case3 m - | Eop (Oaddimm m) (t ::: Enil) => - addimm_case4 m t - | e => - addimm_default e - end. - -Definition addimm (n: int) (e: expr) := - if Int.eq n Int.zero then e else - match addimm_match e with - | addimm_case1 m => - Eop (Ointconst(Int.add n m)) Enil - | addimm_case2 s m => - Eop (Oaddrsymbol s (Int.add n m)) Enil - | addimm_case3 m => - Eop (Oaddrstack (Int.add n m)) Enil - | addimm_case4 m t => - Eop (Oaddimm(Int.add n m)) (t ::: Enil) - | addimm_default e => - Eop (Oaddimm n) (e ::: Enil) - end. - -(** Addition of two integer or pointer expressions. *) - -(* -Definition add (e1: expr) (e2: expr) := - match e1, e2 with - | Eop (Ointconst n1) Enil, t2 => addimm n1 t2 - | Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddimm n2) (t2:::Enil) => addimm (Int.add n1 n2) (Eop Oadd (t1:::t2:::Enil)) - | Eop(Oaddimm n1) (t1:::Enil)), t2 => addimm n1 (Eop Oadd (t1:::t2:::Enil)) - | t1, Eop (Ointconst n2) Enil => addimm n2 t1 - | t1, Eop (Oaddimm n2) (t2:::Enil) => addimm n2 (Eop Oadd (t1:::t2:::Enil)) - | _, _ => Eop Oadd (e1:::e2:::Enil) - end. -*) - -Inductive add_cases: forall (e1: expr) (e2: expr), Set := - | add_case1: - forall (n1: int) (t2: expr), - add_cases (Eop (Ointconst n1) Enil) (t2) - | add_case2: - forall (n1: int) (t1: expr) (n2: int) (t2: expr), - add_cases (Eop (Oaddimm n1) (t1:::Enil)) (Eop (Oaddimm n2) (t2:::Enil)) - | add_case3: - forall (n1: int) (t1: expr) (t2: expr), - add_cases (Eop(Oaddimm n1) (t1:::Enil)) (t2) - | add_case4: - forall (t1: expr) (n2: int), - add_cases (t1) (Eop (Ointconst n2) Enil) - | add_case5: - forall (t1: expr) (n2: int) (t2: expr), - add_cases (t1) (Eop (Oaddimm n2) (t2:::Enil)) - | add_default: - forall (e1: expr) (e2: expr), - add_cases e1 e2. - -Definition add_match_aux (e1: expr) (e2: expr) := - match e2 as z2 return add_cases e1 z2 with - | Eop (Ointconst n2) Enil => - add_case4 e1 n2 - | Eop (Oaddimm n2) (t2:::Enil) => - add_case5 e1 n2 t2 - | e2 => - add_default e1 e2 - end. - -Definition add_match (e1: expr) (e2: expr) := - match e1 as z1, e2 as z2 return add_cases z1 z2 with - | Eop (Ointconst n1) Enil, t2 => - add_case1 n1 t2 - | Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddimm n2) (t2:::Enil) => - add_case2 n1 t1 n2 t2 - | Eop(Oaddimm n1) (t1:::Enil), t2 => - add_case3 n1 t1 t2 - | e1, e2 => - add_match_aux e1 e2 - end. - -Definition add (e1: expr) (e2: expr) := - match add_match e1 e2 with - | add_case1 n1 t2 => - addimm n1 t2 - | add_case2 n1 t1 n2 t2 => - addimm (Int.add n1 n2) (Eop Oadd (t1:::t2:::Enil)) - | add_case3 n1 t1 t2 => - addimm n1 (Eop Oadd (t1:::t2:::Enil)) - | add_case4 t1 n2 => - addimm n2 t1 - | add_case5 t1 n2 t2 => - addimm n2 (Eop Oadd (t1:::t2:::Enil)) - | add_default e1 e2 => - Eop Oadd (e1:::e2:::Enil) - end. - -(** ** Integer and pointer subtraction *) - -(* -Definition sub (e1: expr) (e2: expr) := - match e1, e2 with - | t1, Eop (Ointconst n2) Enil => addimm (Int.neg n2) t1 - | Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddimm n2) (t2:::Enil) => addimm -(intsub n1 n2) (Eop Osub (t1:::t2:::Enil)) - | Eop (Oaddimm n1) (t1:::Enil), t2 => addimm n1 (Eop Osub (t1:::t2:::Rni -l)) - | t1, Eop (Oaddimm n2) (t2:::Enil) => addimm (Int.neg n2) (Eop Osub (t1::: -:t2:::Enil)) - | _, _ => Eop Osub (e1:::e2:::Enil) - end. -*) - -Inductive sub_cases: forall (e1: expr) (e2: expr), Set := - | sub_case1: - forall (t1: expr) (n2: int), - sub_cases (t1) (Eop (Ointconst n2) Enil) - | sub_case2: - forall (n1: int) (t1: expr) (n2: int) (t2: expr), - sub_cases (Eop (Oaddimm n1) (t1:::Enil)) (Eop (Oaddimm n2) (t2:::Enil)) - | sub_case3: - forall (n1: int) (t1: expr) (t2: expr), - sub_cases (Eop (Oaddimm n1) (t1:::Enil)) (t2) - | sub_case4: - forall (t1: expr) (n2: int) (t2: expr), - sub_cases (t1) (Eop (Oaddimm n2) (t2:::Enil)) - | sub_default: - forall (e1: expr) (e2: expr), - sub_cases e1 e2. - -Definition sub_match_aux (e1: expr) (e2: expr) := - match e1 as z1 return sub_cases z1 e2 with - | Eop (Oaddimm n1) (t1:::Enil) => - sub_case3 n1 t1 e2 - | e1 => - sub_default e1 e2 - end. - -Definition sub_match (e1: expr) (e2: expr) := - match e2 as z2, e1 as z1 return sub_cases z1 z2 with - | Eop (Ointconst n2) Enil, t1 => - sub_case1 t1 n2 - | Eop (Oaddimm n2) (t2:::Enil), Eop (Oaddimm n1) (t1:::Enil) => - sub_case2 n1 t1 n2 t2 - | Eop (Oaddimm n2) (t2:::Enil), t1 => - sub_case4 t1 n2 t2 - | e2, e1 => - sub_match_aux e1 e2 - end. - -Definition sub (e1: expr) (e2: expr) := - match sub_match e1 e2 with - | sub_case1 t1 n2 => - addimm (Int.neg n2) t1 - | sub_case2 n1 t1 n2 t2 => - addimm (Int.sub n1 n2) (Eop Osub (t1:::t2:::Enil)) - | sub_case3 n1 t1 t2 => - addimm n1 (Eop Osub (t1:::t2:::Enil)) - | sub_case4 t1 n2 t2 => - addimm (Int.neg n2) (Eop Osub (t1:::t2:::Enil)) - | sub_default e1 e2 => - Eop Osub (e1:::e2:::Enil) - end. - -(** ** Rotates and immediate shifts *) - -(* -Definition rolm (e1: expr) := - match e1 with - | Eop (Ointconst n1) Enil => - Eop (Ointconst(Int.and (Int.rol n1 amount2) mask2)) Enil - | Eop (Orolm amount1 mask1) (t1:::Enil) => - let amount := Int.and (Int.add amount1 amount2) Ox1Fl in - let mask := Int.and (Int.rol mask1 amount2) mask2 in - if Int.is_rlw_mask mask - then Eop (Orolm amount mask) (t1:::Enil) - else Eop (Orolm amount2 mask2) (e1:::Enil) - | _ => Eop (Orolm amount2 mask2) (e1:::Enil) - end -*) - -Inductive rolm_cases: forall (e1: expr), Set := - | rolm_case1: - forall (n1: int), - rolm_cases (Eop (Ointconst n1) Enil) - | rolm_case2: - forall (amount1: int) (mask1: int) (t1: expr), - rolm_cases (Eop (Orolm amount1 mask1) (t1:::Enil)) - | rolm_default: - forall (e1: expr), - rolm_cases e1. - -Definition rolm_match (e1: expr) := - match e1 as z1 return rolm_cases z1 with - | Eop (Ointconst n1) Enil => - rolm_case1 n1 - | Eop (Orolm amount1 mask1) (t1:::Enil) => - rolm_case2 amount1 mask1 t1 - | e1 => - rolm_default e1 - end. - -Definition rolm (e1: expr) (amount2 mask2: int) := - match rolm_match e1 with - | rolm_case1 n1 => - Eop (Ointconst(Int.and (Int.rol n1 amount2) mask2)) Enil - | rolm_case2 amount1 mask1 t1 => - let amount := Int.and (Int.add amount1 amount2) (Int.repr 31) in - let mask := Int.and (Int.rol mask1 amount2) mask2 in - if Int.is_rlw_mask mask - then Eop (Orolm amount mask) (t1:::Enil) - else Eop (Orolm amount2 mask2) (e1:::Enil) - | rolm_default e1 => - Eop (Orolm amount2 mask2) (e1:::Enil) - end. - -Definition shlimm (e1: expr) (n2: int) := - if Int.eq n2 Int.zero then - e1 - else if Int.ltu n2 (Int.repr 32) then - rolm e1 n2 (Int.shl Int.mone n2) - else - Eop Oshl (e1:::Eop (Ointconst n2) Enil:::Enil). - -Definition shruimm (e1: expr) (n2: int) := - if Int.eq n2 Int.zero then - e1 - else if Int.ltu n2 (Int.repr 32) then - rolm e1 (Int.sub (Int.repr 32) n2) (Int.shru Int.mone n2) - else - Eop Oshru (e1:::Eop (Ointconst n2) Enil:::Enil). - -(** ** Integer multiply *) - -Definition mulimm_base (n1: int) (e2: expr) := - match Int.one_bits n1 with - | i :: nil => - shlimm e2 i - | i :: j :: nil => - Elet e2 - (Eop Oadd (shlimm (Eletvar 0) i ::: - shlimm (Eletvar 0) j ::: Enil)) - | _ => - Eop (Omulimm n1) (e2:::Enil) - end. - -(* -Definition mulimm (n1: int) (e2: expr) := - if Int.eq n1 Int.zero then - Elet e2 (Eop (Ointconst Int.zero) Enil) - else if Int.eq n1 Int.one then - e2 - else match e2 with - | Eop (Ointconst n2) Enil => Eop (Ointconst(intmul n1 n2)) Enil - | Eop (Oaddimm n2) (t2:::Enil) => addimm (intmul n1 n2) (mulimm_base n1 t2) - | _ => mulimm_base n1 e2 - end. -*) - -Inductive mulimm_cases: forall (e2: expr), Set := - | mulimm_case1: - forall (n2: int), - mulimm_cases (Eop (Ointconst n2) Enil) - | mulimm_case2: - forall (n2: int) (t2: expr), - mulimm_cases (Eop (Oaddimm n2) (t2:::Enil)) - | mulimm_default: - forall (e2: expr), - mulimm_cases e2. - -Definition mulimm_match (e2: expr) := - match e2 as z1 return mulimm_cases z1 with - | Eop (Ointconst n2) Enil => - mulimm_case1 n2 - | Eop (Oaddimm n2) (t2:::Enil) => - mulimm_case2 n2 t2 - | e2 => - mulimm_default e2 - end. - -Definition mulimm (n1: int) (e2: expr) := - if Int.eq n1 Int.zero then - Elet e2 (Eop (Ointconst Int.zero) Enil) - else if Int.eq n1 Int.one then - e2 - else match mulimm_match e2 with - | mulimm_case1 n2 => - Eop (Ointconst(Int.mul n1 n2)) Enil - | mulimm_case2 n2 t2 => - addimm (Int.mul n1 n2) (mulimm_base n1 t2) - | mulimm_default e2 => - mulimm_base n1 e2 - end. - -(* -Definition mul (e1: expr) (e2: expr) := - match e1, e2 with - | Eop (Ointconst n1) Enil, t2 => mulimm n1 t2 - | t1, Eop (Ointconst n2) Enil => mulimm n2 t1 - | _, _ => Eop Omul (e1:::e2:::Enil) - end. -*) - -Inductive mul_cases: forall (e1: expr) (e2: expr), Set := - | mul_case1: - forall (n1: int) (t2: expr), - mul_cases (Eop (Ointconst n1) Enil) (t2) - | mul_case2: - forall (t1: expr) (n2: int), - mul_cases (t1) (Eop (Ointconst n2) Enil) - | mul_default: - forall (e1: expr) (e2: expr), - mul_cases e1 e2. - -Definition mul_match_aux (e1: expr) (e2: expr) := - match e2 as z2 return mul_cases e1 z2 with - | Eop (Ointconst n2) Enil => - mul_case2 e1 n2 - | e2 => - mul_default e1 e2 - end. - -Definition mul_match (e1: expr) (e2: expr) := - match e1 as z1 return mul_cases z1 e2 with - | Eop (Ointconst n1) Enil => - mul_case1 n1 e2 - | e1 => - mul_match_aux e1 e2 - end. - -Definition mul (e1: expr) (e2: expr) := - match mul_match e1 e2 with - | mul_case1 n1 t2 => - mulimm n1 t2 - | mul_case2 t1 n2 => - mulimm n2 t1 - | mul_default e1 e2 => - Eop Omul (e1:::e2:::Enil) - end. - -(** ** Integer division and modulus *) - -Definition divs (e1: expr) (e2: expr) := Eop Odiv (e1:::e2:::Enil). - -Definition mod_aux (divop: operation) (e1 e2: expr) := - Elet e1 - (Elet (lift e2) - (Eop Osub (Eletvar 1 ::: - Eop Omul (Eop divop (Eletvar 1 ::: Eletvar 0 ::: Enil) ::: - Eletvar 0 ::: - Enil) ::: - Enil))). - -Definition mods := mod_aux Odiv. - -Inductive divu_cases: forall (e2: expr), Set := - | divu_case1: - forall (n2: int), - divu_cases (Eop (Ointconst n2) Enil) - | divu_default: - forall (e2: expr), - divu_cases e2. - -Definition divu_match (e2: expr) := - match e2 as z1 return divu_cases z1 with - | Eop (Ointconst n2) Enil => - divu_case1 n2 - | e2 => - divu_default e2 - end. - -Definition divu (e1: expr) (e2: expr) := - match divu_match e2 with - | divu_case1 n2 => - match Int.is_power2 n2 with - | Some l2 => shruimm e1 l2 - | None => Eop Odivu (e1:::e2:::Enil) - end - | divu_default e2 => - Eop Odivu (e1:::e2:::Enil) - end. - -Definition modu (e1: expr) (e2: expr) := - match divu_match e2 with - | divu_case1 n2 => - match Int.is_power2 n2 with - | Some l2 => rolm e1 Int.zero (Int.sub n2 Int.one) - | None => mod_aux Odivu e1 e2 - end - | divu_default e2 => - mod_aux Odivu e1 e2 - end. - -(** ** Bitwise and, or, xor *) - -Definition andimm (n1: int) (e2: expr) := - if Int.is_rlw_mask n1 - then rolm e2 Int.zero n1 - else Eop (Oandimm n1) (e2:::Enil). - -Definition and (e1: expr) (e2: expr) := - match mul_match e1 e2 with - | mul_case1 n1 t2 => - andimm n1 t2 - | mul_case2 t1 n2 => - andimm n2 t1 - | mul_default e1 e2 => - Eop Oand (e1:::e2:::Enil) - end. - -Definition same_expr_pure (e1 e2: expr) := - match e1, e2 with - | Evar v1, Evar v2 => if ident_eq v1 v2 then true else false - | _, _ => false - end. - -Inductive or_cases: forall (e1: expr) (e2: expr), Set := - | or_case1: - forall (amount1: int) (mask1: int) (t1: expr) - (amount2: int) (mask2: int) (t2: expr), - or_cases (Eop (Orolm amount1 mask1) (t1:::Enil)) - (Eop (Orolm amount2 mask2) (t2:::Enil)) - | or_default: - forall (e1: expr) (e2: expr), - or_cases e1 e2. - -Definition or_match (e1: expr) (e2: expr) := - match e1 as z1, e2 as z2 return or_cases z1 z2 with - | Eop (Orolm amount1 mask1) (t1:::Enil), - Eop (Orolm amount2 mask2) (t2:::Enil) => - or_case1 amount1 mask1 t1 amount2 mask2 t2 - | e1, e2 => - or_default e1 e2 - end. - -Definition or (e1: expr) (e2: expr) := - match or_match e1 e2 with - | or_case1 amount1 mask1 t1 amount2 mask2 t2 => - if Int.eq amount1 amount2 - && Int.is_rlw_mask (Int.or mask1 mask2) - && same_expr_pure t1 t2 - then Eop (Orolm amount1 (Int.or mask1 mask2)) (t1:::Enil) - else Eop Oor (e1:::e2:::Enil) - | or_default e1 e2 => - Eop Oor (e1:::e2:::Enil) - end. - -Definition xor (e1 e2: expr) := Eop Oxor (e1:::e2:::Enil). - -(** ** General shifts *) - -Inductive shift_cases: forall (e1: expr), Set := - | shift_case1: - forall (n2: int), - shift_cases (Eop (Ointconst n2) Enil) - | shift_default: - forall (e1: expr), - shift_cases e1. - -Definition shift_match (e1: expr) := - match e1 as z1 return shift_cases z1 with - | Eop (Ointconst n2) Enil => - shift_case1 n2 - | e1 => - shift_default e1 - end. - -Definition shl (e1: expr) (e2: expr) := - match shift_match e2 with - | shift_case1 n2 => - shlimm e1 n2 - | shift_default e2 => - Eop Oshl (e1:::e2:::Enil) - end. - -Definition shr (e1 e2: expr) := - Eop Oshr (e1:::e2:::Enil). - -Definition shru (e1: expr) (e2: expr) := - match shift_match e2 with - | shift_case1 n2 => - shruimm e1 n2 - | shift_default e2 => - Eop Oshru (e1:::e2:::Enil) - end. - -(** ** Floating-point arithmetic *) - -(* -Definition addf (e1: expr) (e2: expr) := - match e1, e2 with - | Eop Omulf (t1:::t2:::Enil), t3 => Eop Omuladdf (t1:::t2:::t3:::Enil) - | t1, Eop Omulf (t2:::t3:::Enil) => Elet t1 (Eop Omuladdf (t2:::t3:::Rvar 0:::Enil)) - | _, _ => Eop Oaddf (e1:::e2:::Enil) - end. -*) - -Inductive addf_cases: forall (e1: expr) (e2: expr), Set := - | addf_case1: - forall (t1: expr) (t2: expr) (t3: expr), - addf_cases (Eop Omulf (t1:::t2:::Enil)) (t3) - | addf_case2: - forall (t1: expr) (t2: expr) (t3: expr), - addf_cases (t1) (Eop Omulf (t2:::t3:::Enil)) - | addf_default: - forall (e1: expr) (e2: expr), - addf_cases e1 e2. - -Definition addf_match_aux (e1: expr) (e2: expr) := - match e2 as z2 return addf_cases e1 z2 with - | Eop Omulf (t2:::t3:::Enil) => - addf_case2 e1 t2 t3 - | e2 => - addf_default e1 e2 - end. - -Definition addf_match (e1: expr) (e2: expr) := - match e1 as z1 return addf_cases z1 e2 with - | Eop Omulf (t1:::t2:::Enil) => - addf_case1 t1 t2 e2 - | e1 => - addf_match_aux e1 e2 - end. - -Definition addf (e1: expr) (e2: expr) := - match addf_match e1 e2 with - | addf_case1 t1 t2 t3 => - Eop Omuladdf (t1:::t2:::t3:::Enil) - | addf_case2 t1 t2 t3 => - Elet t1 (Eop Omuladdf (lift t2:::lift t3:::Eletvar 0:::Enil)) - | addf_default e1 e2 => - Eop Oaddf (e1:::e2:::Enil) - end. - -(* -Definition subf (e1: expr) (e2: expr) := - match e1, e2 with - | Eop Omulfloat (t1:::t2:::Enil), t3 => Eop Omulsubf (t1:::t2:::t3:::Enil) - | _, _ => Eop Osubf (e1:::e2:::Enil) - end. -*) - -Inductive subf_cases: forall (e1: expr) (e2: expr), Set := - | subf_case1: - forall (t1: expr) (t2: expr) (t3: expr), - subf_cases (Eop Omulf (t1:::t2:::Enil)) (t3) - | subf_default: - forall (e1: expr) (e2: expr), - subf_cases e1 e2. - -Definition subf_match (e1: expr) (e2: expr) := - match e1 as z1 return subf_cases z1 e2 with - | Eop Omulf (t1:::t2:::Enil) => - subf_case1 t1 t2 e2 - | e1 => - subf_default e1 e2 - end. - -Definition subf (e1: expr) (e2: expr) := - match subf_match e1 e2 with - | subf_case1 t1 t2 t3 => - Eop Omulsubf (t1:::t2:::t3:::Enil) - | subf_default e1 e2 => - Eop Osubf (e1:::e2:::Enil) - end. - -Definition mulf (e1 e2: expr) := Eop Omulf (e1:::e2:::Enil). -Definition divf (e1 e2: expr) := Eop Odivf (e1:::e2:::Enil). - -(** ** Truncations and sign extensions *) - -Inductive cast8signed_cases: forall (e1: expr), Set := - | cast8signed_case1: - forall (e2: expr), - cast8signed_cases (Eop Ocast8signed (e2 ::: Enil)) - | cast8signed_default: - forall (e1: expr), - cast8signed_cases e1. - -Definition cast8signed_match (e1: expr) := - match e1 as z1 return cast8signed_cases z1 with - | Eop Ocast8signed (e2 ::: Enil) => - cast8signed_case1 e2 - | e1 => - cast8signed_default e1 - end. - -Definition cast8signed (e: expr) := - match cast8signed_match e with - | cast8signed_case1 e1 => e - | cast8signed_default e1 => Eop Ocast8signed (e1 ::: Enil) - end. - -Inductive cast8unsigned_cases: forall (e1: expr), Set := - | cast8unsigned_case1: - forall (e2: expr), - cast8unsigned_cases (Eop Ocast8unsigned (e2 ::: Enil)) - | cast8unsigned_default: - forall (e1: expr), - cast8unsigned_cases e1. - -Definition cast8unsigned_match (e1: expr) := - match e1 as z1 return cast8unsigned_cases z1 with - | Eop Ocast8unsigned (e2 ::: Enil) => - cast8unsigned_case1 e2 - | e1 => - cast8unsigned_default e1 - end. - -Definition cast8unsigned (e: expr) := - match cast8unsigned_match e with - | cast8unsigned_case1 e1 => e - | cast8unsigned_default e1 => Eop Ocast8unsigned (e1 ::: Enil) - end. - -Inductive cast16signed_cases: forall (e1: expr), Set := - | cast16signed_case1: - forall (e2: expr), - cast16signed_cases (Eop Ocast16signed (e2 ::: Enil)) - | cast16signed_default: - forall (e1: expr), - cast16signed_cases e1. - -Definition cast16signed_match (e1: expr) := - match e1 as z1 return cast16signed_cases z1 with - | Eop Ocast16signed (e2 ::: Enil) => - cast16signed_case1 e2 - | e1 => - cast16signed_default e1 - end. - -Definition cast16signed (e: expr) := - match cast16signed_match e with - | cast16signed_case1 e1 => e - | cast16signed_default e1 => Eop Ocast16signed (e1 ::: Enil) - end. - -Inductive cast16unsigned_cases: forall (e1: expr), Set := - | cast16unsigned_case1: - forall (e2: expr), - cast16unsigned_cases (Eop Ocast16unsigned (e2 ::: Enil)) - | cast16unsigned_default: - forall (e1: expr), - cast16unsigned_cases e1. - -Definition cast16unsigned_match (e1: expr) := - match e1 as z1 return cast16unsigned_cases z1 with - | Eop Ocast16unsigned (e2 ::: Enil) => - cast16unsigned_case1 e2 - | e1 => - cast16unsigned_default e1 - end. - -Definition cast16unsigned (e: expr) := - match cast16unsigned_match e with - | cast16unsigned_case1 e1 => e - | cast16unsigned_default e1 => Eop Ocast16unsigned (e1 ::: Enil) - end. - -Inductive singleoffloat_cases: forall (e1: expr), Set := - | singleoffloat_case1: - forall (e2: expr), - singleoffloat_cases (Eop Osingleoffloat (e2 ::: Enil)) - | singleoffloat_default: - forall (e1: expr), - singleoffloat_cases e1. - -Definition singleoffloat_match (e1: expr) := - match e1 as z1 return singleoffloat_cases z1 with - | Eop Osingleoffloat (e2 ::: Enil) => - singleoffloat_case1 e2 - | e1 => - singleoffloat_default e1 - end. - -Definition singleoffloat (e: expr) := - match singleoffloat_match e with - | singleoffloat_case1 e1 => e - | singleoffloat_default e1 => Eop Osingleoffloat (e1 ::: Enil) - end. - -(** ** Comparisons and conditional expressions *) - -Definition cmp (c: comparison) (e1 e2: expr) := - Eop (Ocmp (Ccomp c)) (e1:::e2:::Enil). -Definition cmpu (c: comparison) (e1 e2: expr) := - Eop (Ocmp (Ccompu c)) (e1:::e2:::Enil). -Definition cmpf (c: comparison) (e1 e2: expr) := - Eop (Ocmp (Ccompf c)) (e1:::e2:::Enil). - -Fixpoint condexpr_of_expr (e: expr) : condexpr := - match e with - | Eop (Ointconst n) Enil => - if Int.eq n Int.zero then CEfalse else CEtrue - | Eop (Ocmp c) el => CEcond c el - | Econdition e1 e2 e3 => - CEcondition e1 (condexpr_of_expr e2) (condexpr_of_expr e3) - | e => CEcond (Ccompuimm Cne Int.zero) (e:::Enil) - end. - -Definition conditionalexpr (e1 e2 e3: expr) : expr := - Econdition (condexpr_of_expr e1) e2 e3. - -(** ** Recognition of addressing modes for load and store operations *) - -(* -Definition addressing (e: expr) := - match e with - | Eop (Oaddrsymbol s n) Enil => (Aglobal s n, Enil) - | Eop (Oaddrstack n) Enil => (Ainstack n, Enil) - | Eop Oadd (Eop (Oaddrsymbol s n) Enil) e2 => (Abased(s, n), e2:::Enil) - | Eop (Oaddimm n) (e1:::Enil) => (Aindexed n, e1:::Enil) - | Eop Oadd (e1:::e2:::Enil) => (Aindexed2, e1:::e2:::Enil) - | _ => (Aindexed Int.zero, e:::Enil) - end. -*) - -Inductive addressing_cases: forall (e: expr), Set := - | addressing_case1: - forall (s: ident) (n: int), - addressing_cases (Eop (Oaddrsymbol s n) Enil) - | addressing_case2: - forall (n: int), - addressing_cases (Eop (Oaddrstack n) Enil) - | addressing_case3: - forall (s: ident) (n: int) (e2: expr), - addressing_cases - (Eop Oadd (Eop (Oaddrsymbol s n) Enil:::e2:::Enil)) - | addressing_case4: - forall (n: int) (e1: expr), - addressing_cases (Eop (Oaddimm n) (e1:::Enil)) - | addressing_case5: - forall (e1: expr) (e2: expr), - addressing_cases (Eop Oadd (e1:::e2:::Enil)) - | addressing_default: - forall (e: expr), - addressing_cases e. - -Definition addressing_match (e: expr) := - match e as z1 return addressing_cases z1 with - | Eop (Oaddrsymbol s n) Enil => - addressing_case1 s n - | Eop (Oaddrstack n) Enil => - addressing_case2 n - | Eop Oadd (Eop (Oaddrsymbol s n) Enil:::e2:::Enil) => - addressing_case3 s n e2 - | Eop (Oaddimm n) (e1:::Enil) => - addressing_case4 n e1 - | Eop Oadd (e1:::e2:::Enil) => - addressing_case5 e1 e2 - | e => - addressing_default e - end. - -Definition addressing (e: expr) := - match addressing_match e with - | addressing_case1 s n => - (Aglobal s n, Enil) - | addressing_case2 n => - (Ainstack n, Enil) - | addressing_case3 s n e2 => - (Abased s n, e2:::Enil) - | addressing_case4 n e1 => - (Aindexed n, e1:::Enil) - | addressing_case5 e1 e2 => - (Aindexed2, e1:::e2:::Enil) - | addressing_default e => - (Aindexed Int.zero, e:::Enil) - end. - -Definition load (chunk: memory_chunk) (e1: expr) := - match addressing e1 with - | (mode, args) => Eload chunk mode args - end. - -Definition store (chunk: memory_chunk) (e1 e2: expr) := - match addressing e1 with - | (mode, args) => Estore chunk mode args e2 - end. - -(** ** If-then-else statement *) - -Definition ifthenelse (e: expr) (ifso ifnot: stmt) : stmt := - Sifthenelse (condexpr_of_expr e) ifso ifnot. diff --git a/backend/Cmconstrproof.v b/backend/Cmconstrproof.v deleted file mode 100644 index 35b3d8a0..00000000 --- a/backend/Cmconstrproof.v +++ /dev/null @@ -1,1207 +0,0 @@ -(** Correctness of the Cminor smart constructors. This file states - evaluation rules for the smart constructors, for instance that [add - a b] evaluates to [Vint(Int.add i j)] if [a] evaluates to [Vint i] - and [b] to [Vint j]. It then proves that these rules are - admissible, that is, satisfied for all possible choices of [a] and - [b]. The Cminor producer can then use these evaluation rules - (theorems) to reason about the execution of terms produced by the - smart constructors. -*) - -Require Import Coqlib. -Require Import Compare_dec. -Require Import Maps. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import Mem. -Require Import Events. -Require Import Op. -Require Import Globalenvs. -Require Import Cminor. -Require Import Cmconstr. - -Section CMCONSTR. - -Variable ge: Cminor.genv. - -(** * Lifting of let-bound variables *) - -Inductive insert_lenv: letenv -> nat -> val -> letenv -> Prop := - | insert_lenv_0: - forall le v, - insert_lenv le O v (v :: le) - | insert_lenv_S: - forall le p w le' v, - insert_lenv le p w le' -> - insert_lenv (v :: le) (S p) w (v :: le'). - -Lemma insert_lenv_lookup1: - forall le p w le', - insert_lenv le p w le' -> - forall n v, - nth_error le n = Some v -> (p > n)%nat -> - nth_error le' n = Some v. -Proof. - induction 1; intros. - omegaContradiction. - destruct n; simpl; simpl in H0. auto. - apply IHinsert_lenv. auto. omega. -Qed. - -Lemma insert_lenv_lookup2: - forall le p w le', - insert_lenv le p w le' -> - forall n v, - nth_error le n = Some v -> (p <= n)%nat -> - nth_error le' (S n) = Some v. -Proof. - induction 1; intros. - simpl. assumption. - simpl. destruct n. omegaContradiction. - apply IHinsert_lenv. exact H0. omega. -Qed. - -Scheme eval_expr_ind_3 := Minimality for eval_expr Sort Prop - with eval_condexpr_ind_3 := Minimality for eval_condexpr Sort Prop - with eval_exprlist_ind_3 := Minimality for eval_exprlist Sort Prop. - -Hint Resolve eval_Evar eval_Eop eval_Eload eval_Estore - eval_Ecall eval_Econdition eval_Ealloc - eval_Elet eval_Eletvar - eval_CEtrue eval_CEfalse eval_CEcond - eval_CEcondition eval_Enil eval_Econs: evalexpr. - -Lemma eval_list_one: - forall sp le e m1 a t m2 v, - eval_expr ge sp le e m1 a t m2 v -> - eval_exprlist ge sp le e m1 (a ::: Enil) t m2 (v :: nil). -Proof. - intros. econstructor. eauto. constructor. traceEq. -Qed. - -Lemma eval_list_two: - forall sp le e m1 a1 t1 m2 v1 a2 t2 m3 v2 t, - eval_expr ge sp le e m1 a1 t1 m2 v1 -> - eval_expr ge sp le e m2 a2 t2 m3 v2 -> - t = t1 ** t2 -> - eval_exprlist ge sp le e m1 (a1 ::: a2 ::: Enil) t m3 (v1 :: v2 :: nil). -Proof. - intros. econstructor. eauto. econstructor. eauto. constructor. - reflexivity. traceEq. -Qed. - -Lemma eval_list_three: - forall sp le e m1 a1 t1 m2 v1 a2 t2 m3 v2 a3 t3 m4 v3 t, - eval_expr ge sp le e m1 a1 t1 m2 v1 -> - eval_expr ge sp le e m2 a2 t2 m3 v2 -> - eval_expr ge sp le e m3 a3 t3 m4 v3 -> - t = t1 ** t2 ** t3 -> - eval_exprlist ge sp le e m1 (a1 ::: a2 ::: a3 ::: Enil) t m4 (v1 :: v2 :: v3 :: nil). -Proof. - intros. econstructor. eauto. econstructor. eauto. econstructor. eauto. constructor. - reflexivity. reflexivity. traceEq. -Qed. - -Hint Resolve eval_list_one eval_list_two eval_list_three: evalexpr. - -Lemma eval_lift_expr: - forall w sp le e m1 a t m2 v, - eval_expr ge sp le e m1 a t m2 v -> - forall p le', insert_lenv le p w le' -> - eval_expr ge sp le' e m1 (lift_expr p a) t m2 v. -Proof. - intros w. - apply (eval_expr_ind_3 ge - (fun sp le e m1 a t m2 v => - forall p le', insert_lenv le p w le' -> - eval_expr ge sp le' e m1 (lift_expr p a) t m2 v) - (fun sp le e m1 a t m2 vb => - forall p le', insert_lenv le p w le' -> - eval_condexpr ge sp le' e m1 (lift_condexpr p a) t m2 vb) - (fun sp le e m1 al t m2 vl => - forall p le', insert_lenv le p w le' -> - eval_exprlist ge sp le' e m1 (lift_exprlist p al) t m2 vl)); - simpl; intros; eauto with evalexpr. - - destruct v1; eapply eval_Econdition; - eauto with evalexpr; simpl; eauto with evalexpr. - - eapply eval_Elet. eauto. apply H2. apply insert_lenv_S; auto. auto. - - case (le_gt_dec p n); intro. - apply eval_Eletvar. eapply insert_lenv_lookup2; eauto. - apply eval_Eletvar. eapply insert_lenv_lookup1; eauto. - - destruct vb1; eapply eval_CEcondition; - eauto with evalexpr; simpl; eauto with evalexpr. -Qed. - -Lemma eval_lift: - forall sp le e m1 a t m2 v w, - eval_expr ge sp le e m1 a t m2 v -> - eval_expr ge sp (w::le) e m1 (lift a) t m2 v. -Proof. - intros. unfold lift. eapply eval_lift_expr. - eexact H. apply insert_lenv_0. -Qed. -Hint Resolve eval_lift: evalexpr. - -(** * Useful lemmas and tactics *) - -Ltac EvalOp := eapply eval_Eop; eauto with evalexpr. - -Ltac TrivialOp cstr := - unfold cstr; intros; EvalOp. - -(** The following are trivial lemmas and custom tactics that help - perform backward (inversion) and forward reasoning over the evaluation - of operator applications. *) - -Lemma inv_eval_Eop_0: - forall sp le e m1 op t m2 v, - eval_expr ge sp le e m1 (Eop op Enil) t m2 v -> - t = E0 /\ m2 = m1 /\ eval_operation ge sp op nil = Some v. -Proof. - intros. inversion H. inversion H6. - intuition. congruence. -Qed. - -Lemma inv_eval_Eop_1: - forall sp le e m1 op t a1 m2 v, - eval_expr ge sp le e m1 (Eop op (a1 ::: Enil)) t m2 v -> - exists v1, - eval_expr ge sp le e m1 a1 t m2 v1 /\ - eval_operation ge sp op (v1 :: nil) = Some v. -Proof. - intros. - inversion H. inversion H6. inversion H18. - subst. exists v1; intuition. rewrite E0_right. auto. -Qed. - -Lemma inv_eval_Eop_2: - forall sp le e m1 op a1 a2 t3 m3 v, - eval_expr ge sp le e m1 (Eop op (a1 ::: a2 ::: Enil)) t3 m3 v -> - exists t1, exists t2, exists m2, exists v1, exists v2, - eval_expr ge sp le e m1 a1 t1 m2 v1 /\ - eval_expr ge sp le e m2 a2 t2 m3 v2 /\ - t3 = t1 ** t2 /\ - eval_operation ge sp op (v1 :: v2 :: nil) = Some v. -Proof. - intros. - inversion H. subst. inversion H6. subst. inversion H8. subst. - inversion H11. subst. - exists t1; exists t0; exists m0; exists v0; exists v1. - intuition. traceEq. -Qed. - -Ltac SimplEval := - match goal with - | [ |- (eval_expr _ ?sp ?le ?e ?m1 (Eop ?op Enil) ?t ?m2 ?v) -> _] => - intro XX1; - generalize (inv_eval_Eop_0 sp le e m1 op t m2 v XX1); - clear XX1; - intros [XX1 [XX2 XX3]]; - subst t m2; simpl in XX3; - try (simplify_eq XX3; clear XX3; - let EQ := fresh "EQ" in (intro EQ; rewrite EQ)) - | [ |- (eval_expr _ ?sp ?le ?e ?m1 (Eop ?op (?a1 ::: Enil)) ?t ?m2 ?v) -> _] => - intro XX1; - generalize (inv_eval_Eop_1 sp le e m1 op t a1 m2 v XX1); - clear XX1; - let v1 := fresh "v" in let EV := fresh "EV" in - let EQ := fresh "EQ" in - (intros [v1 [EV EQ]]; simpl in EQ) - | [ |- (eval_expr _ ?sp ?le ?e ?m1 (Eop ?op (?a1 ::: ?a2 ::: Enil)) ?t ?m2 ?v) -> _] => - intro XX1; - generalize (inv_eval_Eop_2 sp le e m1 op a1 a2 t m2 v XX1); - clear XX1; - let t1 := fresh "t" in let t2 := fresh "t" in - let m := fresh "m" in - let v1 := fresh "v" in let v2 := fresh "v" in - let EV1 := fresh "EV" in let EV2 := fresh "EV" in - let EQ := fresh "EQ" in let TR := fresh "TR" in - (intros [t1 [t2 [m [v1 [v2 [EV1 [EV2 [TR EQ]]]]]]]]; simpl in EQ) - | _ => idtac - end. - -Ltac InvEval H := - generalize H; SimplEval; clear H. - -(** ** Admissible evaluation rules for the smart constructors *) - -(** All proofs follow a common pattern: -- Reasoning by case over the result of the classification functions - (such as [add_match] for integer addition), gathering additional - information on the shape of the argument expressions in the non-default - cases. -- Inversion of the evaluations of the arguments, exploiting the additional - information thus gathered. -- Equational reasoning over the arithmetic operations performed, - using the lemmas from the [Int] and [Float] modules. -- Construction of an evaluation derivation for the expression returned - by the smart constructor. -*) - -Theorem eval_negint: - forall sp le e m1 a t m2 x, - eval_expr ge sp le e m1 a t m2 (Vint x) -> - eval_expr ge sp le e m1 (negint a) t m2 (Vint (Int.neg x)). -Proof. - TrivialOp negint. -Qed. - -Theorem eval_negfloat: - forall sp le e m1 a t m2 x, - eval_expr ge sp le e m1 a t m2 (Vfloat x) -> - eval_expr ge sp le e m1 (negfloat a) t m2 (Vfloat (Float.neg x)). -Proof. - TrivialOp negfloat. -Qed. - -Theorem eval_absfloat: - forall sp le e m1 a t m2 x, - eval_expr ge sp le e m1 a t m2 (Vfloat x) -> - eval_expr ge sp le e m1 (absfloat a) t m2 (Vfloat (Float.abs x)). -Proof. - TrivialOp absfloat. -Qed. - -Theorem eval_intoffloat: - forall sp le e m1 a t m2 x, - eval_expr ge sp le e m1 a t m2 (Vfloat x) -> - eval_expr ge sp le e m1 (intoffloat a) t m2 (Vint (Float.intoffloat x)). -Proof. - TrivialOp intoffloat. -Qed. - -Theorem eval_floatofint: - forall sp le e m1 a t m2 x, - eval_expr ge sp le e m1 a t m2 (Vint x) -> - eval_expr ge sp le e m1 (floatofint a) t m2 (Vfloat (Float.floatofint x)). -Proof. - TrivialOp floatofint. -Qed. - -Theorem eval_floatofintu: - forall sp le e m1 a t m2 x, - eval_expr ge sp le e m1 a t m2 (Vint x) -> - eval_expr ge sp le e m1 (floatofintu a) t m2 (Vfloat (Float.floatofintu x)). -Proof. - TrivialOp floatofintu. -Qed. - -Theorem eval_notint: - forall sp le e m1 a t m2 x, - eval_expr ge sp le e m1 a t m2 (Vint x) -> - eval_expr ge sp le e m1 (notint a) t m2 (Vint (Int.not x)). -Proof. - unfold notint; intros until x; case (notint_match a); intros. - InvEval H. FuncInv. EvalOp. simpl. congruence. - InvEval H. FuncInv. EvalOp. simpl. congruence. - InvEval H. FuncInv. EvalOp. simpl. congruence. - eapply eval_Elet. eexact H. - eapply eval_Eop. - eapply eval_Econs. apply eval_Eletvar. simpl. reflexivity. - eapply eval_Econs. apply eval_Eletvar. simpl. reflexivity. - apply eval_Enil. reflexivity. reflexivity. - simpl. rewrite Int.or_idem. auto. traceEq. -Qed. - -Lemma eval_notbool_base: - forall sp le e m1 a t m2 v b, - eval_expr ge sp le e m1 a t m2 v -> - Val.bool_of_val v b -> - eval_expr ge sp le e m1 (notbool_base a) t m2 (Val.of_bool (negb b)). -Proof. - TrivialOp notbool_base. simpl. - inversion H0. - rewrite Int.eq_false; auto. - rewrite Int.eq_true; auto. - reflexivity. -Qed. - -Hint Resolve Val.bool_of_true_val Val.bool_of_false_val - Val.bool_of_true_val_inv Val.bool_of_false_val_inv: valboolof. - -Theorem eval_notbool: - forall a sp le e m1 t m2 v b, - eval_expr ge sp le e m1 a t m2 v -> - Val.bool_of_val v b -> - eval_expr ge sp le e m1 (notbool a) t m2 (Val.of_bool (negb b)). -Proof. - assert (N1: forall v b, Val.is_false v -> Val.bool_of_val v b -> Val.is_true (Val.of_bool (negb b))). - intros. inversion H0; simpl; auto; subst v; simpl in H. - congruence. apply Int.one_not_zero. contradiction. - assert (N2: forall v b, Val.is_true v -> Val.bool_of_val v b -> Val.is_false (Val.of_bool (negb b))). - intros. inversion H0; simpl; auto; subst v; simpl in H. - congruence. - - induction a; simpl; intros; try (eapply eval_notbool_base; eauto). - destruct o; try (eapply eval_notbool_base; eauto). - - destruct e. InvEval H. injection XX3; clear XX3; intro; subst v. - inversion H0. rewrite Int.eq_false; auto. - simpl; eauto with evalexpr. - rewrite Int.eq_true; simpl; eauto with evalexpr. - eapply eval_notbool_base; eauto. - - inversion H. subst. - simpl in H11. eapply eval_Eop; eauto. - simpl. caseEq (eval_condition c vl); intros. - rewrite H1 in H11. - assert (b0 = b). - destruct b0; inversion H11; subst v; inversion H0; auto. - subst b0. rewrite (Op.eval_negate_condition _ _ H1). - destruct b; reflexivity. - rewrite H1 in H11; discriminate. - - inversion H; eauto 10 with evalexpr valboolof. - inversion H; eauto 10 with evalexpr valboolof. - - inversion H. subst. eapply eval_Econdition with (t2 := t8). eexact H34. - destruct v4; eauto. auto. -Qed. - -Theorem eval_addimm: - forall sp le e m1 n a t m2 x, - eval_expr ge sp le e m1 a t m2 (Vint x) -> - eval_expr ge sp le e m1 (addimm n a) t m2 (Vint (Int.add x n)). -Proof. - unfold addimm; intros until x. - generalize (Int.eq_spec n Int.zero). case (Int.eq n Int.zero); intro. - subst n. rewrite Int.add_zero. auto. - case (addimm_match a); intros. - InvEval H0. EvalOp. simpl. rewrite Int.add_commut. auto. - InvEval H0. destruct (Genv.find_symbol ge s); discriminate. - InvEval H0. - destruct sp; simpl in XX3; discriminate. - InvEval H0. FuncInv. EvalOp. simpl. subst x. - rewrite Int.add_assoc. decEq; decEq; decEq. apply Int.add_commut. - EvalOp. -Qed. - -Theorem eval_addimm_ptr: - forall sp le e m1 n t a m2 b ofs, - eval_expr ge sp le e m1 a t m2 (Vptr b ofs) -> - eval_expr ge sp le e m1 (addimm n a) t m2 (Vptr b (Int.add ofs n)). -Proof. - unfold addimm; intros until ofs. - generalize (Int.eq_spec n Int.zero). case (Int.eq n Int.zero); intro. - subst n. rewrite Int.add_zero. auto. - case (addimm_match a); intros. - InvEval H0. - InvEval H0. EvalOp. simpl. - destruct (Genv.find_symbol ge s). - rewrite Int.add_commut. congruence. - discriminate. - InvEval H0. destruct sp; simpl in XX3; try discriminate. - inversion XX3. EvalOp. simpl. decEq. decEq. - rewrite Int.add_assoc. decEq. apply Int.add_commut. - InvEval H0. FuncInv. subst b0; subst ofs. EvalOp. simpl. - rewrite (Int.add_commut n m). rewrite Int.add_assoc. auto. - EvalOp. -Qed. - -Theorem eval_add: - forall sp le e m1 a t1 m2 x b t2 m3 y, - eval_expr ge sp le e m1 a t1 m2 (Vint x) -> - eval_expr ge sp le e m2 b t2 m3 (Vint y) -> - eval_expr ge sp le e m1 (add a b) (t1**t2) m3 (Vint (Int.add x y)). -Proof. - intros until y. unfold add; case (add_match a b); intros. - InvEval H. rewrite Int.add_commut. apply eval_addimm. - rewrite E0_left; assumption. - InvEval H. FuncInv. InvEval H0. FuncInv. - replace (Int.add x y) with (Int.add (Int.add i i0) (Int.add n1 n2)). - apply eval_addimm. EvalOp. - subst x; subst y. - repeat rewrite Int.add_assoc. decEq. apply Int.add_permut. - InvEval H. FuncInv. - replace (Int.add x y) with (Int.add (Int.add i y) n1). - apply eval_addimm. EvalOp. - subst x. repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. - InvEval H0. FuncInv. - apply eval_addimm. rewrite E0_right. auto. - InvEval H0. FuncInv. - replace (Int.add x y) with (Int.add (Int.add x i) n2). - apply eval_addimm. EvalOp. - subst y. rewrite Int.add_assoc. auto. - EvalOp. -Qed. - -Theorem eval_add_ptr: - forall sp le e m1 a t1 m2 p x b t2 m3 y, - eval_expr ge sp le e m1 a t1 m2 (Vptr p x) -> - eval_expr ge sp le e m2 b t2 m3 (Vint y) -> - eval_expr ge sp le e m1 (add a b) (t1**t2) m3 (Vptr p (Int.add x y)). -Proof. - intros until y. unfold add; case (add_match a b); intros. - InvEval H. - InvEval H. FuncInv. InvEval H0. FuncInv. - replace (Int.add x y) with (Int.add (Int.add i i0) (Int.add n1 n2)). - apply eval_addimm_ptr. subst b0. EvalOp. - subst x; subst y. - repeat rewrite Int.add_assoc. decEq. apply Int.add_permut. - InvEval H. FuncInv. - replace (Int.add x y) with (Int.add (Int.add i y) n1). - apply eval_addimm_ptr. subst b0. EvalOp. - subst x. repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. - InvEval H0. apply eval_addimm_ptr. rewrite E0_right. auto. - InvEval H0. FuncInv. - replace (Int.add x y) with (Int.add (Int.add x i) n2). - apply eval_addimm_ptr. EvalOp. - subst y. rewrite Int.add_assoc. auto. - EvalOp. -Qed. - -Theorem eval_add_ptr_2: - forall sp le e m1 a t1 m2 p x b t2 m3 y, - eval_expr ge sp le e m1 a t1 m2 (Vint x) -> - eval_expr ge sp le e m2 b t2 m3 (Vptr p y) -> - eval_expr ge sp le e m1 (add a b) (t1**t2) m3 (Vptr p (Int.add y x)). -Proof. - intros until y. unfold add; case (add_match a b); intros. - InvEval H. - apply eval_addimm_ptr. rewrite E0_left. auto. - InvEval H. FuncInv. InvEval H0. FuncInv. - replace (Int.add y x) with (Int.add (Int.add i0 i) (Int.add n1 n2)). - apply eval_addimm_ptr. subst b0. EvalOp. - subst x; subst y. - repeat rewrite Int.add_assoc. decEq. - rewrite (Int.add_commut n1 n2). apply Int.add_permut. - InvEval H. FuncInv. - replace (Int.add y x) with (Int.add (Int.add y i) n1). - apply eval_addimm_ptr. EvalOp. - subst x. repeat rewrite Int.add_assoc. auto. - InvEval H0. - InvEval H0. FuncInv. - replace (Int.add y x) with (Int.add (Int.add i x) n2). - apply eval_addimm_ptr. EvalOp. subst b0; reflexivity. - subst y. repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. - EvalOp. -Qed. - -Theorem eval_sub: - forall sp le e m1 a t1 m2 x b t2 m3 y, - eval_expr ge sp le e m1 a t1 m2 (Vint x) -> - eval_expr ge sp le e m2 b t2 m3 (Vint y) -> - eval_expr ge sp le e m1 (sub a b) (t1**t2) m3 (Vint (Int.sub x y)). -Proof. - intros until y. - unfold sub; case (sub_match a b); intros. - InvEval H0. rewrite Int.sub_add_opp. - apply eval_addimm. rewrite E0_right. assumption. - InvEval H. FuncInv. InvEval H0. FuncInv. - replace (Int.sub x y) with (Int.add (Int.sub i i0) (Int.sub n1 n2)). - apply eval_addimm. EvalOp. - subst x; subst y. - repeat rewrite Int.sub_add_opp. - repeat rewrite Int.add_assoc. decEq. - rewrite Int.add_permut. decEq. symmetry. apply Int.neg_add_distr. - InvEval H. FuncInv. - replace (Int.sub x y) with (Int.add (Int.sub i y) n1). - apply eval_addimm. EvalOp. - subst x. rewrite Int.sub_add_l. auto. - InvEval H0. FuncInv. - replace (Int.sub x y) with (Int.add (Int.sub x i) (Int.neg n2)). - apply eval_addimm. EvalOp. - subst y. rewrite (Int.add_commut i n2). symmetry. apply Int.sub_add_r. - EvalOp. -Qed. - -Theorem eval_sub_ptr_int: - forall sp le e m1 a t1 m2 p x b t2 m3 y, - eval_expr ge sp le e m1 a t1 m2 (Vptr p x) -> - eval_expr ge sp le e m2 b t2 m3 (Vint y) -> - eval_expr ge sp le e m1 (sub a b) (t1**t2) m3 (Vptr p (Int.sub x y)). -Proof. - intros until y. - unfold sub; case (sub_match a b); intros. - InvEval H0. rewrite Int.sub_add_opp. - apply eval_addimm_ptr. rewrite E0_right. assumption. - InvEval H. FuncInv. InvEval H0. FuncInv. - subst b0. - replace (Int.sub x y) with (Int.add (Int.sub i i0) (Int.sub n1 n2)). - apply eval_addimm_ptr. EvalOp. - subst x; subst y. - repeat rewrite Int.sub_add_opp. - repeat rewrite Int.add_assoc. decEq. - rewrite Int.add_permut. decEq. symmetry. apply Int.neg_add_distr. - InvEval H. FuncInv. subst b0. - replace (Int.sub x y) with (Int.add (Int.sub i y) n1). - apply eval_addimm_ptr. EvalOp. - subst x. rewrite Int.sub_add_l. auto. - InvEval H0. FuncInv. - replace (Int.sub x y) with (Int.add (Int.sub x i) (Int.neg n2)). - apply eval_addimm_ptr. EvalOp. - subst y. rewrite (Int.add_commut i n2). symmetry. apply Int.sub_add_r. - EvalOp. -Qed. - -Theorem eval_sub_ptr_ptr: - forall sp le e m1 a t1 m2 p x b t2 m3 y, - eval_expr ge sp le e m1 a t1 m2 (Vptr p x) -> - eval_expr ge sp le e m2 b t2 m3 (Vptr p y) -> - eval_expr ge sp le e m1 (sub a b) (t1**t2) m3 (Vint (Int.sub x y)). -Proof. - intros until y. - unfold sub; case (sub_match a b); intros. - InvEval H0. - InvEval H. FuncInv. InvEval H0. FuncInv. - replace (Int.sub x y) with (Int.add (Int.sub i i0) (Int.sub n1 n2)). - apply eval_addimm. EvalOp. - simpl; unfold eq_block. subst b0; subst b1; rewrite zeq_true. auto. - subst x; subst y. - repeat rewrite Int.sub_add_opp. - repeat rewrite Int.add_assoc. decEq. - rewrite Int.add_permut. decEq. symmetry. apply Int.neg_add_distr. - InvEval H. FuncInv. subst b0. - replace (Int.sub x y) with (Int.add (Int.sub i y) n1). - apply eval_addimm. EvalOp. - simpl. unfold eq_block. rewrite zeq_true. auto. - subst x. rewrite Int.sub_add_l. auto. - InvEval H0. FuncInv. subst b0. - replace (Int.sub x y) with (Int.add (Int.sub x i) (Int.neg n2)). - apply eval_addimm. EvalOp. - simpl. unfold eq_block. rewrite zeq_true. auto. - subst y. rewrite (Int.add_commut i n2). symmetry. apply Int.sub_add_r. - EvalOp. simpl. unfold eq_block. rewrite zeq_true. auto. -Qed. - -Lemma eval_rolm: - forall sp le e m1 a amount mask t m2 x, - eval_expr ge sp le e m1 a t m2 (Vint x) -> - eval_expr ge sp le e m1 (rolm a amount mask) t m2 (Vint (Int.rolm x amount mask)). -Proof. - intros until x. unfold rolm; case (rolm_match a); intros. - InvEval H. eauto with evalexpr. - case (Int.is_rlw_mask (Int.and (Int.rol mask1 amount) mask)). - InvEval H. FuncInv. EvalOp. simpl. subst x. - decEq. decEq. - replace (Int.and (Int.add amount1 amount) (Int.repr 31)) - with (Int.modu (Int.add amount1 amount) (Int.repr 32)). - symmetry. apply Int.rolm_rolm. - change (Int.repr 31) with (Int.sub (Int.repr 32) Int.one). - apply Int.modu_and with (Int.repr 5). reflexivity. - EvalOp. - EvalOp. -Qed. - -Theorem eval_shlimm: - forall sp le e m1 a n t m2 x, - eval_expr ge sp le e m1 a t m2 (Vint x) -> - Int.ltu n (Int.repr 32) = true -> - eval_expr ge sp le e m1 (shlimm a n) t m2 (Vint (Int.shl x n)). -Proof. - intros. unfold shlimm. - generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intro. - subst n. rewrite Int.shl_zero. auto. - rewrite H0. - replace (Int.shl x n) with (Int.rolm x n (Int.shl Int.mone n)). - apply eval_rolm. auto. symmetry. apply Int.shl_rolm. exact H0. -Qed. - -Theorem eval_shruimm: - forall sp le e m1 a n t m2 x, - eval_expr ge sp le e m1 a t m2 (Vint x) -> - Int.ltu n (Int.repr 32) = true -> - eval_expr ge sp le e m1 (shruimm a n) t m2 (Vint (Int.shru x n)). -Proof. - intros. unfold shruimm. - generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intro. - subst n. rewrite Int.shru_zero. auto. - rewrite H0. - replace (Int.shru x n) with (Int.rolm x (Int.sub (Int.repr 32) n) (Int.shru Int.mone n)). - apply eval_rolm. auto. symmetry. apply Int.shru_rolm. exact H0. -Qed. - -Lemma eval_mulimm_base: - forall sp le e m1 a t n m2 x, - eval_expr ge sp le e m1 a t m2 (Vint x) -> - eval_expr ge sp le e m1 (mulimm_base n a) t m2 (Vint (Int.mul x n)). -Proof. - intros; unfold mulimm_base. - generalize (Int.one_bits_decomp n). - generalize (Int.one_bits_range n). - change (Z_of_nat wordsize) with 32. - destruct (Int.one_bits n). - intros. EvalOp. - destruct l. - intros. rewrite H1. simpl. - rewrite Int.add_zero. rewrite <- Int.shl_mul. - apply eval_shlimm. auto. auto with coqlib. - destruct l. - intros. apply eval_Elet with t m2 (Vint x) E0. auto. - rewrite H1. simpl. rewrite Int.add_zero. - rewrite Int.mul_add_distr_r. - rewrite <- Int.shl_mul. - rewrite <- Int.shl_mul. - EvalOp. eapply eval_Econs. - apply eval_shlimm. apply eval_Eletvar. simpl. reflexivity. - auto with coqlib. - eapply eval_Econs. - apply eval_shlimm. apply eval_Eletvar. simpl. reflexivity. - auto with coqlib. - auto with evalexpr. - reflexivity. traceEq. reflexivity. traceEq. - intros. EvalOp. -Qed. - -Theorem eval_mulimm: - forall sp le e m1 a n t m2 x, - eval_expr ge sp le e m1 a t m2 (Vint x) -> - eval_expr ge sp le e m1 (mulimm n a) t m2 (Vint (Int.mul x n)). -Proof. - intros until x; unfold mulimm. - generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intro. - subst n. rewrite Int.mul_zero. - intro. eapply eval_Elet; eauto with evalexpr. traceEq. - generalize (Int.eq_spec n Int.one); case (Int.eq n Int.one); intro. - subst n. rewrite Int.mul_one. auto. - case (mulimm_match a); intros. - InvEval H1. EvalOp. rewrite Int.mul_commut. reflexivity. - InvEval H1. FuncInv. - replace (Int.mul x n) with (Int.add (Int.mul i n) (Int.mul n n2)). - apply eval_addimm. apply eval_mulimm_base. auto. - subst x. rewrite Int.mul_add_distr_l. decEq. apply Int.mul_commut. - apply eval_mulimm_base. assumption. -Qed. - -Theorem eval_mul: - forall sp le e m1 a t1 m2 x b t2 m3 y, - eval_expr ge sp le e m1 a t1 m2 (Vint x) -> - eval_expr ge sp le e m2 b t2 m3 (Vint y) -> - eval_expr ge sp le e m1 (mul a b) (t1**t2) m3 (Vint (Int.mul x y)). -Proof. - intros until y. - unfold mul; case (mul_match a b); intros. - InvEval H. rewrite Int.mul_commut. apply eval_mulimm. - rewrite E0_left; auto. - InvEval H0. rewrite E0_right. apply eval_mulimm. auto. - EvalOp. -Qed. - -Theorem eval_divs: - forall sp le e m1 a t1 m2 x b t2 m3 y, - eval_expr ge sp le e m1 a t1 m2 (Vint x) -> - eval_expr ge sp le e m2 b t2 m3 (Vint y) -> - y <> Int.zero -> - eval_expr ge sp le e m1 (divs a b) (t1**t2) m3 (Vint (Int.divs x y)). -Proof. - TrivialOp divs. simpl. - predSpec Int.eq Int.eq_spec y Int.zero. contradiction. auto. -Qed. - -Lemma eval_mod_aux: - forall divop semdivop, - (forall sp x y, - y <> Int.zero -> - eval_operation ge sp divop (Vint x :: Vint y :: nil) = - Some (Vint (semdivop x y))) -> - forall sp le e m1 a t1 m2 x b t2 m3 y, - eval_expr ge sp le e m1 a t1 m2 (Vint x) -> - eval_expr ge sp le e m2 b t2 m3 (Vint y) -> - y <> Int.zero -> - eval_expr ge sp le e m1 (mod_aux divop a b) (t1**t2) m3 - (Vint (Int.sub x (Int.mul (semdivop x y) y))). -Proof. - intros; unfold mod_aux. - eapply eval_Elet. eexact H0. eapply eval_Elet. - apply eval_lift. eexact H1. - eapply eval_Eop. eapply eval_Econs. - eapply eval_Eletvar. simpl; reflexivity. - eapply eval_Econs. eapply eval_Eop. - eapply eval_Econs. eapply eval_Eop. - eapply eval_Econs. apply eval_Eletvar. simpl; reflexivity. - eapply eval_Econs. apply eval_Eletvar. simpl; reflexivity. - apply eval_Enil. reflexivity. reflexivity. - apply H. assumption. - eapply eval_Econs. apply eval_Eletvar. simpl; reflexivity. - apply eval_Enil. reflexivity. reflexivity. - simpl; reflexivity. apply eval_Enil. - reflexivity. reflexivity. reflexivity. - reflexivity. traceEq. -Qed. - -Theorem eval_mods: - forall sp le e m1 a t1 m2 x b t2 m3 y, - eval_expr ge sp le e m1 a t1 m2 (Vint x) -> - eval_expr ge sp le e m2 b t2 m3 (Vint y) -> - y <> Int.zero -> - eval_expr ge sp le e m1 (mods a b) (t1**t2) m3 (Vint (Int.mods x y)). -Proof. - intros; unfold mods. - rewrite Int.mods_divs. - eapply eval_mod_aux; eauto. - intros. simpl. predSpec Int.eq Int.eq_spec y0 Int.zero. - contradiction. auto. -Qed. - -Lemma eval_divu_base: - forall sp le e m1 a t1 m2 x b t2 m3 y, - eval_expr ge sp le e m1 a t1 m2 (Vint x) -> - eval_expr ge sp le e m2 b t2 m3 (Vint y) -> - y <> Int.zero -> - eval_expr ge sp le e m1 (Eop Odivu (a ::: b ::: Enil)) (t1**t2) m3 (Vint (Int.divu x y)). -Proof. - intros. EvalOp. simpl. - predSpec Int.eq Int.eq_spec y Int.zero. contradiction. auto. -Qed. - -Theorem eval_divu: - forall sp le e m1 a t1 m2 x b t2 m3 y, - eval_expr ge sp le e m1 a t1 m2 (Vint x) -> - eval_expr ge sp le e m2 b t2 m3 (Vint y) -> - y <> Int.zero -> - eval_expr ge sp le e m1 (divu a b) (t1**t2) m3 (Vint (Int.divu x y)). -Proof. - intros until y. - unfold divu; case (divu_match b); intros. - InvEval H0. caseEq (Int.is_power2 y). - intros. rewrite (Int.divu_pow2 x y i H0). - apply eval_shruimm. rewrite E0_right. auto. - apply Int.is_power2_range with y. auto. - intros. subst n2. eapply eval_divu_base. eexact H. EvalOp. auto. - eapply eval_divu_base; eauto. -Qed. - -Theorem eval_modu: - forall sp le e m1 a t1 m2 x b t2 m3 y, - eval_expr ge sp le e m1 a t1 m2 (Vint x) -> - eval_expr ge sp le e m2 b t2 m3 (Vint y) -> - y <> Int.zero -> - eval_expr ge sp le e m1 (modu a b) (t1**t2) m3 (Vint (Int.modu x y)). -Proof. - intros until y; unfold modu; case (divu_match b); intros. - InvEval H0. caseEq (Int.is_power2 y). - intros. rewrite (Int.modu_and x y i H0). - rewrite <- Int.rolm_zero. apply eval_rolm. rewrite E0_right; auto. - intro. rewrite Int.modu_divu. eapply eval_mod_aux. - intros. simpl. predSpec Int.eq Int.eq_spec y0 Int.zero. - contradiction. auto. - eexact H. EvalOp. auto. auto. - rewrite Int.modu_divu. eapply eval_mod_aux. - intros. simpl. predSpec Int.eq Int.eq_spec y0 Int.zero. - contradiction. auto. - eexact H. eexact H0. auto. auto. -Qed. - -Theorem eval_andimm: - forall sp le e m1 n a t m2 x, - eval_expr ge sp le e m1 a t m2 (Vint x) -> - eval_expr ge sp le e m1 (andimm n a) t m2 (Vint (Int.and x n)). -Proof. - intros. unfold andimm. case (Int.is_rlw_mask n). - rewrite <- Int.rolm_zero. apply eval_rolm; auto. - EvalOp. -Qed. - -Theorem eval_and: - forall sp le e m1 a t1 m2 x b t2 m3 y, - eval_expr ge sp le e m1 a t1 m2 (Vint x) -> - eval_expr ge sp le e m2 b t2 m3 (Vint y) -> - eval_expr ge sp le e m1 (and a b) (t1**t2) m3 (Vint (Int.and x y)). -Proof. - intros until y; unfold and; case (mul_match a b); intros. - InvEval H. rewrite Int.and_commut. - rewrite E0_left; apply eval_andimm; auto. - InvEval H0. rewrite E0_right; apply eval_andimm; auto. - EvalOp. -Qed. - -Remark eval_same_expr_pure: - forall a1 a2 sp le e m1 t1 m2 v1 t2 m3 v2, - same_expr_pure a1 a2 = true -> - eval_expr ge sp le e m1 a1 t1 m2 v1 -> - eval_expr ge sp le e m2 a2 t2 m3 v2 -> - t1 = E0 /\ t2 = E0 /\ a2 = a1 /\ v2 = v1 /\ m2 = m1. -Proof. - intros until v2. - destruct a1; simpl; try (intros; discriminate). - destruct a2; simpl; try (intros; discriminate). - case (ident_eq i i0); intros. - subst i0. inversion H0. inversion H1. - assert (v2 = v1). congruence. tauto. - discriminate. -Qed. - -Lemma eval_or: - forall sp le e m1 a t1 m2 x b t2 m3 y, - eval_expr ge sp le e m1 a t1 m2 (Vint x) -> - eval_expr ge sp le e m2 b t2 m3 (Vint y) -> - eval_expr ge sp le e m1 (or a b) (t1**t2) m3 (Vint (Int.or x y)). -Proof. - intros until y; unfold or; case (or_match a b); intros. - generalize (Int.eq_spec amount1 amount2); case (Int.eq amount1 amount2); intro. - case (Int.is_rlw_mask (Int.or mask1 mask2)). - caseEq (same_expr_pure t0 t3); intro. - simpl. InvEval H. FuncInv. InvEval H0. FuncInv. - generalize (eval_same_expr_pure _ _ _ _ _ _ _ _ _ _ _ _ H2 EV EV0). - intros [EQ1 [EQ2 [EQ3 [EQ4 EQ5]]]]. - injection EQ4; intro EQ7. subst. - EvalOp. simpl. rewrite Int.or_rolm. auto. - simpl. EvalOp. - simpl. EvalOp. - simpl. EvalOp. - EvalOp. -Qed. - -Theorem eval_xor: - forall sp le e m1 a t1 m2 x b t2 m3 y, - eval_expr ge sp le e m1 a t1 m2 (Vint x) -> - eval_expr ge sp le e m2 b t2 m3 (Vint y) -> - eval_expr ge sp le e m1 (xor a b) (t1**t2) m3 (Vint (Int.xor x y)). -Proof. TrivialOp xor. Qed. - -Theorem eval_shl: - forall sp le e m1 a t1 m2 x b t2 m3 y, - eval_expr ge sp le e m1 a t1 m2 (Vint x) -> - eval_expr ge sp le e m2 b t2 m3 (Vint y) -> - Int.ltu y (Int.repr 32) = true -> - eval_expr ge sp le e m1 (shl a b) (t1**t2) m3 (Vint (Int.shl x y)). -Proof. - intros until y; unfold shl; case (shift_match b); intros. - InvEval H0. rewrite E0_right. apply eval_shlimm; auto. - EvalOp. simpl. rewrite H1. auto. -Qed. - -Theorem eval_shr: - forall sp le e m1 a t1 m2 x b t2 m3 y, - eval_expr ge sp le e m1 a t1 m2 (Vint x) -> - eval_expr ge sp le e m2 b t2 m3 (Vint y) -> - Int.ltu y (Int.repr 32) = true -> - eval_expr ge sp le e m1 (shr a b) (t1**t2) m3 (Vint (Int.shr x y)). -Proof. - TrivialOp shr. simpl. rewrite H1. auto. -Qed. - -Theorem eval_shru: - forall sp le e m1 a t1 m2 x b t2 m3 y, - eval_expr ge sp le e m1 a t1 m2 (Vint x) -> - eval_expr ge sp le e m2 b t2 m3 (Vint y) -> - Int.ltu y (Int.repr 32) = true -> - eval_expr ge sp le e m1 (shru a b) (t1**t2) m3 (Vint (Int.shru x y)). -Proof. - intros until y; unfold shru; case (shift_match b); intros. - InvEval H0. rewrite E0_right; apply eval_shruimm; auto. - EvalOp. simpl. rewrite H1. auto. -Qed. - -Theorem eval_addf: - forall sp le e m1 a t1 m2 x b t2 m3 y, - eval_expr ge sp le e m1 a t1 m2 (Vfloat x) -> - eval_expr ge sp le e m2 b t2 m3 (Vfloat y) -> - eval_expr ge sp le e m1 (addf a b) (t1**t2) m3 (Vfloat (Float.add x y)). -Proof. - intros until y; unfold addf; case (addf_match a b); intros. - InvEval H. FuncInv. EvalOp. - econstructor; eauto. econstructor; eauto. econstructor; eauto. constructor. - traceEq. simpl. subst x. reflexivity. - InvEval H0. FuncInv. eapply eval_Elet. eexact H. EvalOp. - econstructor; eauto with evalexpr. - econstructor; eauto with evalexpr. - econstructor. apply eval_Eletvar. simpl; reflexivity. - constructor. reflexivity. traceEq. - subst y. rewrite Float.addf_commut. reflexivity. auto. - EvalOp. -Qed. - -Theorem eval_subf: - forall sp le e m1 a t1 m2 x b t2 m3 y, - eval_expr ge sp le e m1 a t1 m2 (Vfloat x) -> - eval_expr ge sp le e m2 b t2 m3 (Vfloat y) -> - eval_expr ge sp le e m1 (subf a b) (t1**t2) m3 (Vfloat (Float.sub x y)). -Proof. - intros until y; unfold subf; case (subf_match a b); intros. - InvEval H. FuncInv. EvalOp. - econstructor; eauto. econstructor; eauto. econstructor; eauto. constructor. - traceEq. subst x. reflexivity. - EvalOp. -Qed. - -Theorem eval_mulf: - forall sp le e m1 a t1 m2 x b t2 m3 y, - eval_expr ge sp le e m1 a t1 m2 (Vfloat x) -> - eval_expr ge sp le e m2 b t2 m3 (Vfloat y) -> - eval_expr ge sp le e m1 (mulf a b) (t1**t2) m3 (Vfloat (Float.mul x y)). -Proof. TrivialOp mulf. Qed. - -Theorem eval_divf: - forall sp le e m1 a t1 m2 x b t2 m3 y, - eval_expr ge sp le e m1 a t1 m2 (Vfloat x) -> - eval_expr ge sp le e m2 b t2 m3 (Vfloat y) -> - eval_expr ge sp le e m1 (divf a b) (t1**t2) m3 (Vfloat (Float.div x y)). -Proof. TrivialOp divf. Qed. - -Theorem eval_cast8signed: - forall sp le e m1 a t m2 v, - eval_expr ge sp le e m1 a t m2 v -> - eval_expr ge sp le e m1 (cast8signed a) t m2 (Val.cast8signed v). -Proof. - intros until v; unfold cast8signed; case (cast8signed_match a); intros. - replace (Val.cast8signed v) with v. auto. - InvEval H. inversion EQ. destruct v0; simpl; auto. rewrite Int.cast8_signed_idem. reflexivity. - EvalOp. -Qed. - -Theorem eval_cast8unsigned: - forall sp le e m1 a t m2 v, - eval_expr ge sp le e m1 a t m2 v -> - eval_expr ge sp le e m1 (cast8unsigned a) t m2 (Val.cast8unsigned v). -Proof. - intros until v; unfold cast8unsigned; case (cast8unsigned_match a); intros. - replace (Val.cast8unsigned v) with v. auto. - InvEval H. inversion EQ. destruct v0; simpl; auto. rewrite Int.cast8_unsigned_idem. reflexivity. - EvalOp. -Qed. - -Theorem eval_cast16signed: - forall sp le e m1 a t m2 v, - eval_expr ge sp le e m1 a t m2 v -> - eval_expr ge sp le e m1 (cast16signed a) t m2 (Val.cast16signed v). -Proof. - intros until v; unfold cast16signed; case (cast16signed_match a); intros. - replace (Val.cast16signed v) with v. auto. - InvEval H. inversion EQ. destruct v0; simpl; auto. rewrite Int.cast16_signed_idem. reflexivity. - EvalOp. -Qed. - -Theorem eval_cast16unsigned: - forall sp le e m1 a t m2 v, - eval_expr ge sp le e m1 a t m2 v -> - eval_expr ge sp le e m1 (cast16unsigned a) t m2 (Val.cast16unsigned v). -Proof. - intros until v; unfold cast16unsigned; case (cast16unsigned_match a); intros. - replace (Val.cast16unsigned v) with v. auto. - InvEval H. inversion EQ. destruct v0; simpl; auto. rewrite Int.cast16_unsigned_idem. reflexivity. - EvalOp. -Qed. - -Theorem eval_singleoffloat: - forall sp le e m1 a t m2 v, - eval_expr ge sp le e m1 a t m2 v -> - eval_expr ge sp le e m1 (singleoffloat a) t m2 (Val.singleoffloat v). -Proof. - intros until v; unfold singleoffloat; case (singleoffloat_match a); intros. - replace (Val.singleoffloat v) with v. auto. - InvEval H. inversion EQ. destruct v0; simpl; auto. rewrite Float.singleoffloat_idem. reflexivity. - EvalOp. -Qed. - -Theorem eval_cmp: - forall sp le c e m1 a t1 m2 x b t2 m3 y, - eval_expr ge sp le e m1 a t1 m2 (Vint x) -> - eval_expr ge sp le e m2 b t2 m3 (Vint y) -> - eval_expr ge sp le e m1 (cmp c a b) (t1**t2) m3 (Val.of_bool (Int.cmp c x y)). -Proof. - TrivialOp cmp. - simpl. case (Int.cmp c x y); auto. -Qed. - -Theorem eval_cmp_null_r: - forall sp le c e m1 a t1 m2 p x b t2 m3 v, - eval_expr ge sp le e m1 a t1 m2 (Vptr p x) -> - eval_expr ge sp le e m2 b t2 m3 (Vint Int.zero) -> - (c = Ceq /\ v = Vfalse) \/ (c = Cne /\ v = Vtrue) -> - eval_expr ge sp le e m1 (cmp c a b) (t1**t2) m3 v. -Proof. - TrivialOp cmp. - simpl. elim H1; intros [EQ1 EQ2]; subst c; subst v; reflexivity. -Qed. - -Theorem eval_cmp_null_l: - forall sp le c e m1 a t1 m2 p x b t2 m3 v, - eval_expr ge sp le e m1 a t1 m2 (Vint Int.zero) -> - eval_expr ge sp le e m2 b t2 m3 (Vptr p x) -> - (c = Ceq /\ v = Vfalse) \/ (c = Cne /\ v = Vtrue) -> - eval_expr ge sp le e m1 (cmp c a b) (t1**t2) m3 v. -Proof. - TrivialOp cmp. - simpl. elim H1; intros [EQ1 EQ2]; subst c; subst v; reflexivity. -Qed. - -Theorem eval_cmp_ptr: - forall sp le c e m1 a t1 m2 p x b t2 m3 y, - eval_expr ge sp le e m1 a t1 m2 (Vptr p x) -> - eval_expr ge sp le e m2 b t2 m3 (Vptr p y) -> - eval_expr ge sp le e m1 (cmp c a b) (t1**t2) m3 (Val.of_bool (Int.cmp c x y)). -Proof. - TrivialOp cmp. - simpl. unfold eq_block. rewrite zeq_true. - case (Int.cmp c x y); auto. -Qed. - -Theorem eval_cmpu: - forall sp le c e m1 a t1 m2 x b t2 m3 y, - eval_expr ge sp le e m1 a t1 m2 (Vint x) -> - eval_expr ge sp le e m2 b t2 m3 (Vint y) -> - eval_expr ge sp le e m1 (cmpu c a b) (t1**t2) m3 (Val.of_bool (Int.cmpu c x y)). -Proof. - TrivialOp cmpu. - simpl. case (Int.cmpu c x y); auto. -Qed. - -Theorem eval_cmpf: - forall sp le c e m1 a t1 m2 x b t2 m3 y, - eval_expr ge sp le e m1 a t1 m2 (Vfloat x) -> - eval_expr ge sp le e m2 b t2 m3 (Vfloat y) -> - eval_expr ge sp le e m1 (cmpf c a b) (t1**t2) m3 (Val.of_bool (Float.cmp c x y)). -Proof. - TrivialOp cmpf. - simpl. case (Float.cmp c x y); auto. -Qed. - -Lemma eval_base_condition_of_expr: - forall sp le a e m1 t m2 v (b: bool), - eval_expr ge sp le e m1 a t m2 v -> - Val.bool_of_val v b -> - eval_condexpr ge sp le e m1 - (CEcond (Ccompuimm Cne Int.zero) (a ::: Enil)) - t m2 b. -Proof. - intros. - eapply eval_CEcond. eauto with evalexpr. - inversion H0; simpl. rewrite Int.eq_false; auto. auto. auto. -Qed. - -Lemma eval_condition_of_expr: - forall a sp le e m1 t m2 v (b: bool), - eval_expr ge sp le e m1 a t m2 v -> - Val.bool_of_val v b -> - eval_condexpr ge sp le e m1 (condexpr_of_expr a) t m2 b. -Proof. - induction a; simpl; intros; - try (eapply eval_base_condition_of_expr; eauto; fail). - destruct o; try (eapply eval_base_condition_of_expr; eauto; fail). - - destruct e. InvEval H. inversion XX3; subst v. - inversion H0. - rewrite Int.eq_false; auto. constructor. - subst i; rewrite Int.eq_true. constructor. - eapply eval_base_condition_of_expr; eauto. - - inversion H. subst. eapply eval_CEcond; eauto. simpl in H11. - destruct (eval_condition c vl); try discriminate. - destruct b0; inversion H11; subst; inversion H0; congruence. - - inversion H. subst. - destruct v1; eauto with evalexpr. -Qed. - -Theorem eval_conditionalexpr_true: - forall sp le e m1 a1 t1 m2 v1 t2 a2 m3 v2 a3, - eval_expr ge sp le e m1 a1 t1 m2 v1 -> - Val.is_true v1 -> - eval_expr ge sp le e m2 a2 t2 m3 v2 -> - eval_expr ge sp le e m1 (conditionalexpr a1 a2 a3) (t1**t2) m3 v2. -Proof. - intros; unfold conditionalexpr. - apply eval_Econdition with t1 m2 true t2; auto. - eapply eval_condition_of_expr; eauto with valboolof. -Qed. - -Theorem eval_conditionalexpr_false: - forall sp le e m1 a1 t1 m2 v1 a2 t2 m3 v2 a3, - eval_expr ge sp le e m1 a1 t1 m2 v1 -> - Val.is_false v1 -> - eval_expr ge sp le e m2 a3 t2 m3 v2 -> - eval_expr ge sp le e m1 (conditionalexpr a1 a2 a3) (t1**t2) m3 v2. -Proof. - intros; unfold conditionalexpr. - apply eval_Econdition with t1 m2 false t2; auto. - eapply eval_condition_of_expr; eauto with valboolof. -Qed. - -Lemma eval_addressing: - forall sp le e m1 a t m2 v b ofs, - eval_expr ge sp le e m1 a t m2 v -> - v = Vptr b ofs -> - match addressing a with (mode, args) => - exists vl, - eval_exprlist ge sp le e m1 args t m2 vl /\ - eval_addressing ge sp mode vl = Some v - end. -Proof. - intros until v. unfold addressing; case (addressing_match a); intros. - InvEval H. exists (@nil val). split. eauto with evalexpr. - simpl. auto. - InvEval H. exists (@nil val). split. eauto with evalexpr. - simpl. auto. - InvEval H. InvEval EV. rewrite E0_left in TR. subst t1. FuncInv. - congruence. - destruct (Genv.find_symbol ge s); congruence. - exists (Vint i0 :: nil). split. eauto with evalexpr. - simpl. subst v. destruct (Genv.find_symbol ge s). congruence. - discriminate. - InvEval H. FuncInv. - congruence. - exists (Vptr b0 i :: nil). split. eauto with evalexpr. - simpl. congruence. - InvEval H. FuncInv. - congruence. - exists (Vint i :: Vptr b0 i0 :: nil). - split. eauto with evalexpr. simpl. - rewrite Int.add_commut. congruence. - exists (Vptr b0 i :: Vint i0 :: nil). - split. eauto with evalexpr. simpl. congruence. - exists (v :: nil). split. eauto with evalexpr. - subst v. simpl. rewrite Int.add_zero. auto. -Qed. - -Theorem eval_load: - forall sp le e m1 a t m2 v chunk v', - eval_expr ge sp le e m1 a t m2 v -> - Mem.loadv chunk m2 v = Some v' -> - eval_expr ge sp le e m1 (load chunk a) t m2 v'. -Proof. - intros. generalize H0; destruct v; simpl; intro; try discriminate. - unfold load. - generalize (eval_addressing _ _ _ _ _ _ _ _ _ _ H (refl_equal _)). - destruct (addressing a). intros [vl [EV EQ]]. - eapply eval_Eload; eauto. -Qed. - -Theorem eval_store: - forall sp le e m1 a1 t1 m2 v1 a2 t2 m3 v2 chunk m4, - eval_expr ge sp le e m1 a1 t1 m2 v1 -> - eval_expr ge sp le e m2 a2 t2 m3 v2 -> - Mem.storev chunk m3 v1 v2 = Some m4 -> - eval_expr ge sp le e m1 (store chunk a1 a2) (t1**t2) m4 v2. -Proof. - intros. generalize H1; destruct v1; simpl; intro; try discriminate. - unfold store. - generalize (eval_addressing _ _ _ _ _ _ _ _ _ _ H (refl_equal _)). - destruct (addressing a1). intros [vl [EV EQ]]. - eapply eval_Estore; eauto. -Qed. - -Theorem exec_ifthenelse_true: - forall sp e m1 a t1 m2 v ifso ifnot t2 e3 m3 out, - eval_expr ge sp nil e m1 a t1 m2 v -> - Val.is_true v -> - exec_stmt ge sp e m2 ifso t2 e3 m3 out -> - exec_stmt ge sp e m1 (ifthenelse a ifso ifnot) (t1**t2) e3 m3 out. -Proof. - intros. unfold ifthenelse. - apply exec_Sifthenelse with t1 m2 true t2. - eapply eval_condition_of_expr; eauto with valboolof. - auto. auto. -Qed. - -Theorem exec_ifthenelse_false: - forall sp e m1 a t1 m2 v ifso ifnot t2 e3 m3 out, - eval_expr ge sp nil e m1 a t1 m2 v -> - Val.is_false v -> - exec_stmt ge sp e m2 ifnot t2 e3 m3 out -> - exec_stmt ge sp e m1 (ifthenelse a ifso ifnot) (t1**t2) e3 m3 out. -Proof. - intros. unfold ifthenelse. - apply exec_Sifthenelse with t1 m2 false t2. - eapply eval_condition_of_expr; eauto with valboolof. - auto. auto. -Qed. - -End CMCONSTR. - diff --git a/backend/Cminor.v b/backend/Cminor.v index 9ed5e19d..2b9945ac 100644 --- a/backend/Cminor.v +++ b/backend/Cminor.v @@ -8,41 +8,79 @@ Require Import Floats. Require Import Events. Require Import Values. Require Import Mem. -Require Import Op. Require Import Globalenvs. +Require Import Switch. (** * Abstract syntax *) (** Cminor is a low-level imperative language structured in expressions, - statements, functions and programs. Expressions include - reading local variables, reading and writing store locations, - arithmetic operations, function calls, and conditional expressions - (similar to [e1 ? e2 : e3] in C). The [Elet] and [Eletvar] constructs - enable sharing the computations of subexpressions. De Bruijn notation - is used: [Eletvar n] refers to the value bound by then [n+1]-th enclosing - [Elet] construct. - - A variant [condexpr] of [expr] is used to represent expressions - which are evaluated for their boolean value only and not their exact value. -*) + statements, functions and programs. We first define the constants + and operators that occur within expressions. *) + +Inductive constant : Set := + | Ointconst: int -> constant (**r integer constant *) + | Ofloatconst: float -> constant (**r floating-point constant *) + | Oaddrsymbol: ident -> int -> constant (**r address of the symbol plus the offset *) + | Oaddrstack: int -> constant. (**r stack pointer plus the given offset *) + +Inductive unary_operation : Set := + | Ocast8unsigned: unary_operation (**r 8-bit zero extension *) + | Ocast8signed: unary_operation (**r 8-bit sign extension *) + | Ocast16unsigned: unary_operation (**r 16-bit zero extension *) + | Ocast16signed: unary_operation (**r 16-bit sign extension *) + | Onegint: unary_operation (**r integer opposite *) + | Onotbool: unary_operation (**r boolean negation *) + | Onotint: unary_operation (**r bitwise complement *) + | Onegf: unary_operation (**r float opposite *) + | Oabsf: unary_operation (**r float absolute value *) + | Osingleoffloat: unary_operation (**r float truncation *) + | Ointoffloat: unary_operation (**r integer to float *) + | Ofloatofint: unary_operation (**r float to signed integer *) + | Ofloatofintu: unary_operation. (**r float to unsigned integer *) + +Inductive binary_operation : Set := + | Oadd: binary_operation (**r integer addition *) + | Osub: binary_operation (**r integer subtraction *) + | Omul: binary_operation (**r integer multiplication *) + | Odiv: binary_operation (**r integer signed division *) + | Odivu: binary_operation (**r integer unsigned division *) + | Omod: binary_operation (**r integer signed modulus *) + | Omodu: binary_operation (**r integer unsigned modulus *) + | Oand: binary_operation (**r bitwise ``and'' *) + | Oor: binary_operation (**r bitwise ``or'' *) + | Oxor: binary_operation (**r bitwise ``xor'' *) + | Oshl: binary_operation (**r left shift *) + | Oshr: binary_operation (**r right signed shift *) + | Oshru: binary_operation (**r right unsigned shift *) + | Oaddf: binary_operation (**r float addition *) + | Osubf: binary_operation (**r float subtraction *) + | Omulf: binary_operation (**r float multiplication *) + | Odivf: binary_operation (**r float division *) + | Ocmp: comparison -> binary_operation (**r integer signed comparison *) + | Ocmpu: comparison -> binary_operation (**r integer unsigned comparison *) + | Ocmpf: comparison -> binary_operation. (**r float comparison *) + +(** Expressions include reading local variables, constants and + arithmetic operations, reading and writing store locations, + function calls, and conditional expressions + (similar to [e1 ? e2 : e3] in C). + The [Elet] and [Eletvar] constructs enable sharing the computations + of subexpressions. De Bruijn notation is used: [Eletvar n] refers + to the value bound by then [n+1]-th enclosing [Elet] construct. *) Inductive expr : Set := | Evar : ident -> expr - | Eop : operation -> exprlist -> expr - | Eload : memory_chunk -> addressing -> exprlist -> expr - | Estore : memory_chunk -> addressing -> exprlist -> expr -> expr + | Econst : constant -> expr + | Eunop : unary_operation -> expr -> expr + | Ebinop : binary_operation -> expr -> expr -> expr + | Eload : memory_chunk -> expr -> expr + | Estore : memory_chunk -> expr -> expr -> expr | Ecall : signature -> expr -> exprlist -> expr - | Econdition : condexpr -> expr -> expr -> expr + | Econdition : expr -> expr -> expr -> expr | Elet : expr -> expr -> expr | Eletvar : nat -> expr | Ealloc : expr -> expr -with condexpr : Set := - | CEtrue: condexpr - | CEfalse: condexpr - | CEcond: condition -> exprlist -> condexpr - | CEcondition : condexpr -> condexpr -> condexpr -> condexpr - with exprlist : Set := | Enil: exprlist | Econs: expr -> exprlist -> exprlist. @@ -57,12 +95,13 @@ Inductive stmt : Set := | Sexpr: expr -> stmt | Sassign : ident -> expr -> stmt | Sseq: stmt -> stmt -> stmt - | Sifthenelse: condexpr -> stmt -> stmt -> stmt + | Sifthenelse: expr -> stmt -> stmt -> stmt | Sloop: stmt -> stmt | Sblock: stmt -> stmt | Sexit: nat -> stmt | Sswitch: expr -> list (int * nat) -> nat -> stmt - | Sreturn: option expr -> stmt. + | Sreturn: option expr -> stmt + | Stailcall: signature -> expr -> exprlist -> stmt. (** Functions are composed of a signature, a list of parameter names, a list of local variables, and a statement representing @@ -97,30 +136,31 @@ Definition funsig (fd: fundef) := Inductive outcome: Set := | Out_normal: outcome (**r continue in sequence *) | Out_exit: nat -> outcome (**r terminate [n+1] enclosing blocks *) - | Out_return: option val -> outcome. (**r return immediately to caller *) - -Definition outcome_result_value - (out: outcome) (ot: option typ) (v: val) : Prop := - match out, ot with - | Out_normal, None => v = Vundef - | Out_return None, None => v = Vundef - | Out_return (Some v'), Some ty => v = v' - | _, _ => False - end. + | Out_return: option val -> outcome (**r return immediately to caller *) + | Out_tailcall_return: val -> outcome. (**r already returned to caller via a tailcall *) Definition outcome_block (out: outcome) : outcome := match out with - | Out_normal => Out_normal | Out_exit O => Out_normal | Out_exit (S n) => Out_exit n - | Out_return optv => Out_return optv + | out => out + end. + +Definition outcome_result_value + (out: outcome) (retsig: option typ) (vres: val) : Prop := + match out, retsig with + | Out_normal, None => vres = Vundef + | Out_return None, None => vres = Vundef + | Out_return (Some v), Some ty => vres = v + | Out_tailcall_return v, _ => vres = v + | _, _ => False end. -Fixpoint switch_target (n: int) (dfl: nat) (cases: list (int * nat)) - {struct cases} : nat := - match cases with - | nil => dfl - | (n1, lbl1) :: rem => if Int.eq n n1 then lbl1 else switch_target n dfl rem +Definition outcome_free_mem + (out: outcome) (m: mem) (sp: block) : mem := + match out with + | Out_tailcall_return _ => m + | _ => Mem.free m sp end. (** Three kinds of evaluation environments are involved: @@ -154,10 +194,105 @@ Section RELSEM. Variable ge: genv. -(** Evaluation of an expression: [eval_expr ge sp le e m a m' v] +(** Evaluation of constants and operator applications. + [None] is returned when the computation is undefined, e.g. + if arguments are of the wrong types, or in case of an integer division + by zero. *) + +Definition eval_constant (sp: val) (cst: constant) : option val := + match cst with + | Ointconst n => Some (Vint n) + | Ofloatconst n => Some (Vfloat n) + | Oaddrsymbol s ofs => + match Genv.find_symbol ge s with + | None => None + | Some b => Some (Vptr b ofs) + end + | Oaddrstack ofs => + match sp with + | Vptr b n => Some (Vptr b (Int.add n ofs)) + | _ => None + end + end. + +Definition eval_unop (op: unary_operation) (arg: val) : option val := + match op, arg with + | Ocast8unsigned, _ => Some (Val.cast8unsigned arg) + | Ocast8signed, _ => Some (Val.cast8signed arg) + | Ocast16unsigned, _ => Some (Val.cast16unsigned arg) + | Ocast16signed, _ => Some (Val.cast16signed arg) + | Onegint, Vint n1 => Some (Vint (Int.neg n1)) + | Onotbool, Vint n1 => Some (Val.of_bool (Int.eq n1 Int.zero)) + | Onotbool, Vptr b1 n1 => Some Vfalse + | Onotint, Vint n1 => Some (Vint (Int.not n1)) + | Onegf, Vfloat f1 => Some (Vfloat (Float.neg f1)) + | Oabsf, Vfloat f1 => Some (Vfloat (Float.abs f1)) + | Osingleoffloat, _ => Some (Val.singleoffloat arg) + | Ointoffloat, Vfloat f1 => Some (Vint (Float.intoffloat f1)) + | Ofloatofint, Vint n1 => Some (Vfloat (Float.floatofint n1)) + | Ofloatofintu, Vint n1 => Some (Vfloat (Float.floatofintu n1)) + | _, _ => None + end. + +Definition eval_compare_null (c: comparison) (n: int) : option val := + if Int.eq n Int.zero + then match c with Ceq => Some Vfalse | Cne => Some Vtrue | _ => None end + else None. + +Definition eval_binop + (op: binary_operation) (arg1 arg2: val) (m: mem): option val := + match op, arg1, arg2 with + | Oadd, Vint n1, Vint n2 => Some (Vint (Int.add n1 n2)) + | Oadd, Vint n1, Vptr b2 n2 => Some (Vptr b2 (Int.add n2 n1)) + | Oadd, Vptr b1 n1, Vint n2 => Some (Vptr b1 (Int.add n1 n2)) + | Osub, Vint n1, Vint n2 => Some (Vint (Int.sub n1 n2)) + | Osub, Vptr b1 n1, Vint n2 => Some (Vptr b1 (Int.sub n1 n2)) + | Osub, Vptr b1 n1, Vptr b2 n2 => + if eq_block b1 b2 then Some (Vint (Int.sub n1 n2)) else None + | Omul, Vint n1, Vint n2 => Some (Vint (Int.mul n1 n2)) + | Odiv, Vint n1, Vint n2 => + if Int.eq n2 Int.zero then None else Some (Vint (Int.divs n1 n2)) + | Odivu, Vint n1, Vint n2 => + if Int.eq n2 Int.zero then None else Some (Vint (Int.divu n1 n2)) + | Omod, Vint n1, Vint n2 => + if Int.eq n2 Int.zero then None else Some (Vint (Int.mods n1 n2)) + | Omodu, Vint n1, Vint n2 => + if Int.eq n2 Int.zero then None else Some (Vint (Int.modu n1 n2)) + | Oand, Vint n1, Vint n2 => Some (Vint (Int.and n1 n2)) + | Oor, Vint n1, Vint n2 => Some (Vint (Int.or n1 n2)) + | Oxor, Vint n1, Vint n2 => Some (Vint (Int.xor n1 n2)) + | Oshl, Vint n1, Vint n2 => + if Int.ltu n2 (Int.repr 32) then Some (Vint (Int.shl n1 n2)) else None + | Oshr, Vint n1, Vint n2 => + if Int.ltu n2 (Int.repr 32) then Some (Vint (Int.shr n1 n2)) else None + | Oshru, Vint n1, Vint n2 => + if Int.ltu n2 (Int.repr 32) then Some (Vint (Int.shru n1 n2)) else None + | Oaddf, Vfloat f1, Vfloat f2 => Some (Vfloat (Float.add f1 f2)) + | Osubf, Vfloat f1, Vfloat f2 => Some (Vfloat (Float.sub f1 f2)) + | Omulf, Vfloat f1, Vfloat f2 => Some (Vfloat (Float.mul f1 f2)) + | Odivf, Vfloat f1, Vfloat f2 => Some (Vfloat (Float.div f1 f2)) + | Ocmp c, Vint n1, Vint n2 => + Some (Val.of_bool(Int.cmp c n1 n2)) + | Ocmp c, Vptr b1 n1, Vptr b2 n2 => + if valid_pointer m b1 (Int.signed n1) + && valid_pointer m b2 (Int.signed n2) then + if eq_block b1 b2 then Some(Val.of_bool(Int.cmp c n1 n2)) else None + else + None + | Ocmp c, Vptr b1 n1, Vint n2 => eval_compare_null c n2 + | Ocmp c, Vint n1, Vptr b2 n2 => eval_compare_null c n1 + | Ocmpu c, Vint n1, Vint n2 => + Some (Val.of_bool(Int.cmpu c n1 n2)) + | Ocmpf c, Vfloat f1, Vfloat f2 => + Some (Val.of_bool (Float.cmp c f1 f2)) + | _, _, _ => None + end. + +(** Evaluation of an expression: [eval_expr ge sp le e m a t m' v] states that expression [a], in initial local environment [e] and memory state [m], evaluates to value [v]. [m'] is the final memory state, reflecting memory stores possibly performed by [a]. + [t] is the trace of I/O events generated during the evaluation. Expressions do not assign variables, therefore the local environment [e] is unchanged. [ge] and [le] are the global environment and let environment respectively, and are unchanged during evaluation. [sp] @@ -172,25 +307,34 @@ Inductive eval_expr: forall sp le e m id v, PTree.get id e = Some v -> eval_expr sp le e m (Evar id) E0 m v - | eval_Eop: - forall sp le e m op al t m1 vl v, - eval_exprlist sp le e m al t m1 vl -> - eval_operation ge sp op vl = Some v -> - eval_expr sp le e m (Eop op al) t m1 v + | eval_Econst: + forall sp le e m cst v, + eval_constant sp cst = Some v -> + eval_expr sp le e m (Econst cst) E0 m v + | eval_Eunop: + forall sp le e m op a t m1 v1 v, + eval_expr sp le e m a t m1 v1 -> + eval_unop op v1 = Some v -> + eval_expr sp le e m (Eunop op a) t m1 v + | eval_Ebinop: + forall sp le e m op a1 a2 t1 m1 v1 t2 m2 v2 t v, + eval_expr sp le e m a1 t1 m1 v1 -> + eval_expr sp le e m1 a2 t2 m2 v2 -> + eval_binop op v1 v2 m2 = Some v -> + t = t1 ** t2 -> + eval_expr sp le e m (Ebinop op a1 a2) t m2 v | eval_Eload: - forall sp le e m chunk addr al t m1 v vl a, - eval_exprlist sp le e m al t m1 vl -> - eval_addressing ge sp addr vl = Some a -> - Mem.loadv chunk m1 a = Some v -> - eval_expr sp le e m (Eload chunk addr al) t m1 v + forall sp le e m chunk a t m1 v1 v, + eval_expr sp le e m a t m1 v1 -> + Mem.loadv chunk m1 v1 = Some v -> + eval_expr sp le e m (Eload chunk a) t m1 v | eval_Estore: - forall sp le e m chunk addr al b t t1 m1 vl t2 m2 m3 v a, - eval_exprlist sp le e m al t1 m1 vl -> - eval_expr sp le e m1 b t2 m2 v -> - eval_addressing ge sp addr vl = Some a -> - Mem.storev chunk m2 a v = Some m3 -> + forall sp le e m chunk a1 a2 t t1 m1 v1 t2 m2 v2 m3, + eval_expr sp le e m a1 t1 m1 v1 -> + eval_expr sp le e m1 a2 t2 m2 v2 -> + Mem.storev chunk m2 v1 v2 = Some m3 -> t = t1 ** t2 -> - eval_expr sp le e m (Estore chunk addr al b) t m3 v + eval_expr sp le e m (Estore chunk a1 a2) t m3 v2 | eval_Ecall: forall sp le e m sig a bl t t1 m1 t2 m2 t3 m3 vf vargs vres f, eval_expr sp le e m a t1 m1 vf -> @@ -201,11 +345,12 @@ Inductive eval_expr: t = t1 ** t2 ** t3 -> eval_expr sp le e m (Ecall sig a bl) t m3 vres | eval_Econdition: - forall sp le e m a b c t t1 m1 v1 t2 m2 v2, - eval_condexpr sp le e m a t1 m1 v1 -> - eval_expr sp le e m1 (if v1 then b else c) t2 m2 v2 -> + forall sp le e m a1 a2 a3 t t1 m1 v1 b1 t2 m2 v2, + eval_expr sp le e m a1 t1 m1 v1 -> + Val.bool_of_val v1 b1 -> + eval_expr sp le e m1 (if b1 then a2 else a3) t2 m2 v2 -> t = t1 ** t2 -> - eval_expr sp le e m (Econdition a b c) t m2 v2 + eval_expr sp le e m (Econdition a1 a2 a3) t m2 v2 | eval_Elet: forall sp le e m a b t t1 m1 v1 t2 m2 v2, eval_expr sp le e m a t1 m1 v1 -> @@ -222,33 +367,6 @@ Inductive eval_expr: Mem.alloc m1 0 (Int.signed n) = (m2, b) -> eval_expr sp le e m (Ealloc a) t m2 (Vptr b Int.zero) -(** Evaluation of a condition expression: - [eval_condexpr ge sp le e m a m' b] - states that condition expression [a] evaluates to the boolean value [b]. - The other parameters are as in [eval_expr]. -*) - -with eval_condexpr: - val -> letenv -> env -> - mem -> condexpr -> trace -> mem -> bool -> Prop := - | eval_CEtrue: - forall sp le e m, - eval_condexpr sp le e m CEtrue E0 m true - | eval_CEfalse: - forall sp le e m, - eval_condexpr sp le e m CEfalse E0 m false - | eval_CEcond: - forall sp le e m cond al t1 m1 vl b, - eval_exprlist sp le e m al t1 m1 vl -> - eval_condition cond vl = Some b -> - eval_condexpr sp le e m (CEcond cond al) t1 m1 b - | eval_CEcondition: - forall sp le e m a b c t t1 m1 vb1 t2 m2 vb2, - eval_condexpr sp le e m a t1 m1 vb1 -> - eval_condexpr sp le e m1 (if vb1 then b else c) t2 m2 vb2 -> - t = t1 ** t2 -> - eval_condexpr sp le e m (CEcondition a b c) t m2 vb2 - (** Evaluation of a list of expressions: [eval_exprlist ge sp le al m a m' vl] states that the list [al] of expressions evaluate @@ -272,6 +390,7 @@ with eval_exprlist: (** Evaluation of a function invocation: [eval_funcall ge m f args m' res] means that the function [f], applied to the arguments [args] in memory state [m], returns the value [res] in modified memory state [m']. + [t] is the trace of observable events generated during the invocation. *) with eval_funcall: @@ -283,7 +402,7 @@ with eval_funcall: set_locals f.(fn_vars) (set_params vargs f.(fn_params)) = e -> exec_stmt (Vptr sp Int.zero) e m1 f.(fn_body) t e2 m2 out -> outcome_result_value out f.(fn_sig).(sig_res) vres -> - eval_funcall m (Internal f) vargs t (Mem.free m2 sp) vres + eval_funcall m (Internal f) vargs t (outcome_free_mem out m2 sp) vres | eval_funcall_external: forall ef m args t res, event_match ef args t res -> @@ -291,7 +410,10 @@ with eval_funcall: (** Execution of a statement: [exec_stmt ge sp e m s e' m' out] means that statement [s] executes with outcome [out]. - The other parameters are as in [eval_expr]. *) + [e] is the initial environment and [m] is the initial memory state. + [e'] is the final environment, reflecting variable assignments performed + by [s]. [m'] is the final memory state, reflecting memory stores + performed by [s]. The other parameters are as in [eval_expr]. *) with exec_stmt: val -> @@ -309,9 +431,10 @@ with exec_stmt: eval_expr sp nil e m a t m1 v -> exec_stmt sp e m (Sassign id a) t (PTree.set id v e) m1 Out_normal | exec_Sifthenelse: - forall sp e m a s1 s2 t t1 m1 v1 t2 e2 m2 out, - eval_condexpr sp nil e m a t1 m1 v1 -> - exec_stmt sp e m1 (if v1 then s1 else s2) t2 e2 m2 out -> + forall sp e m a s1 s2 t t1 m1 v1 b1 t2 e2 m2 out, + eval_expr sp nil e m a t1 m1 v1 -> + Val.bool_of_val v1 b1 -> + exec_stmt sp e m1 (if b1 then s1 else s2) t2 e2 m2 out -> t = t1 ** t2 -> exec_stmt sp e m (Sifthenelse a s1 s2) t e2 m2 out | exec_Sseq_continue: @@ -354,13 +477,29 @@ with exec_stmt: | exec_Sreturn_some: forall sp e m a t m1 v, eval_expr sp nil e m a t m1 v -> - exec_stmt sp e m (Sreturn (Some a)) t e m1 (Out_return (Some v)). + exec_stmt sp e m (Sreturn (Some a)) t e m1 (Out_return (Some v)) + | exec_Stailcall: + forall sp e m sig a bl t t1 m1 t2 m2 t3 m3 vf vargs vres f, + eval_expr (Vptr sp Int.zero) nil e m a t1 m1 vf -> + eval_exprlist (Vptr sp Int.zero) nil e m1 bl t2 m2 vargs -> + Genv.find_funct ge vf = Some f -> + funsig f = sig -> + eval_funcall (Mem.free m2 sp) f vargs t3 m3 vres -> + t = t1 ** t2 ** t3 -> + exec_stmt (Vptr sp Int.zero) e m (Stailcall sig a bl) t e m3 (Out_tailcall_return vres). + +Scheme eval_expr_ind4 := Minimality for eval_expr Sort Prop + with eval_exprlist_ind4 := Minimality for eval_exprlist Sort Prop + with eval_funcall_ind4 := Minimality for eval_funcall Sort Prop + with exec_stmt_ind4 := Minimality for exec_stmt Sort Prop. End RELSEM. -(** Execution of a whole program: [exec_program p r] +(** Execution of a whole program: [exec_program p t r] holds if the application of [p]'s main function to no arguments - in the initial memory state for [p] eventually returns value [r]. *) + in the initial memory state for [p] performs the input/output + operations described in the trace [t], and eventually returns value [r]. +*) Definition exec_program (p: program) (t: trace) (r: val) : Prop := let ge := Genv.globalenv p in diff --git a/backend/CminorSel.v b/backend/CminorSel.v new file mode 100644 index 00000000..331105ea --- /dev/null +++ b/backend/CminorSel.v @@ -0,0 +1,296 @@ +(** The Cminor language after instruction selection. *) + +Require Import Coqlib. +Require Import Maps. +Require Import AST. +Require Import Integers. +Require Import Floats. +Require Import Events. +Require Import Values. +Require Import Mem. +Require Import Cminor. +Require Import Op. +Require Import Globalenvs. +Require Import Switch. + +(** * Abstract syntax *) + +(** CminorSel programs share the general structure of Cminor programs: + functions, statements and expressions. However, CminorSel uses + machine-dependent operations, addressing modes and conditions, + as defined in module [Op] and used in lower-level intermediate + languages ([RTL] and below). Moreover, a variant [condexpr] of [expr] + is used to represent expressions which are evaluated for their + boolean value only and not their exact value. +*) + +Inductive expr : Set := + | Evar : ident -> expr + | Eop : operation -> exprlist -> expr + | Eload : memory_chunk -> addressing -> exprlist -> expr + | Estore : memory_chunk -> addressing -> exprlist -> expr -> expr + | Ecall : signature -> expr -> exprlist -> expr + | Econdition : condexpr -> expr -> expr -> expr + | Elet : expr -> expr -> expr + | Eletvar : nat -> expr + | Ealloc : expr -> expr + +with condexpr : Set := + | CEtrue: condexpr + | CEfalse: condexpr + | CEcond: condition -> exprlist -> condexpr + | CEcondition : condexpr -> condexpr -> condexpr -> condexpr + +with exprlist : Set := + | Enil: exprlist + | Econs: expr -> exprlist -> exprlist. + +(** Statements are as in Cminor, except that the condition of an + if/then/else conditional is a [condexpr]. *) + +Inductive stmt : Set := + | Sskip: stmt + | Sexpr: expr -> stmt + | Sassign : ident -> expr -> stmt + | Sseq: stmt -> stmt -> stmt + | Sifthenelse: condexpr -> stmt -> stmt -> stmt + | Sloop: stmt -> stmt + | Sblock: stmt -> stmt + | Sexit: nat -> stmt + | Sswitch: expr -> list (int * nat) -> nat -> stmt + | Sreturn: option expr -> stmt + | Stailcall: signature -> expr -> exprlist -> stmt. + +Record function : Set := mkfunction { + fn_sig: signature; + fn_params: list ident; + fn_vars: list ident; + fn_stackspace: Z; + fn_body: stmt +}. + +Definition fundef := AST.fundef function. +Definition program := AST.program fundef unit. + +Definition funsig (fd: fundef) := + match fd with + | Internal f => f.(fn_sig) + | External ef => ef.(ef_sig) + end. + +(** * Operational semantics *) + +(** Three kinds of evaluation environments are involved: +- [genv]: global environments, define symbols and functions; +- [env]: local environments, map local variables to values; +- [lenv]: let environments, map de Bruijn indices to values. +*) + +Definition genv := Genv.t fundef. + +Section RELSEM. + +Variable ge: genv. + +(** The evaluation predicates have the same general shape as those + of Cminor. Refer to the description of Cminor semantics for + the meaning of the parameters of the predicates. + One additional predicate is introduced: + [eval_condexpr ge sp le e m a t m' b], meaning that the conditional + expression [a] evaluates to the boolean [b]. *) + +Inductive eval_expr: + val -> letenv -> env -> + mem -> expr -> trace -> mem -> val -> Prop := + | eval_Evar: + forall sp le e m id v, + PTree.get id e = Some v -> + eval_expr sp le e m (Evar id) E0 m v + | eval_Eop: + forall sp le e m op al t m1 vl v, + eval_exprlist sp le e m al t m1 vl -> + eval_operation ge sp op vl m1 = Some v -> + eval_expr sp le e m (Eop op al) t m1 v + | eval_Eload: + forall sp le e m chunk addr al t m1 v vl a, + eval_exprlist sp le e m al t m1 vl -> + eval_addressing ge sp addr vl = Some a -> + Mem.loadv chunk m1 a = Some v -> + eval_expr sp le e m (Eload chunk addr al) t m1 v + | eval_Estore: + forall sp le e m chunk addr al b t t1 m1 vl t2 m2 m3 v a, + eval_exprlist sp le e m al t1 m1 vl -> + eval_expr sp le e m1 b t2 m2 v -> + eval_addressing ge sp addr vl = Some a -> + Mem.storev chunk m2 a v = Some m3 -> + t = t1 ** t2 -> + eval_expr sp le e m (Estore chunk addr al b) t m3 v + | eval_Ecall: + forall sp le e m sig a bl t t1 m1 t2 m2 t3 m3 vf vargs vres f, + eval_expr sp le e m a t1 m1 vf -> + eval_exprlist sp le e m1 bl t2 m2 vargs -> + Genv.find_funct ge vf = Some f -> + funsig f = sig -> + eval_funcall m2 f vargs t3 m3 vres -> + t = t1 ** t2 ** t3 -> + eval_expr sp le e m (Ecall sig a bl) t m3 vres + | eval_Econdition: + forall sp le e m a b c t t1 m1 v1 t2 m2 v2, + eval_condexpr sp le e m a t1 m1 v1 -> + eval_expr sp le e m1 (if v1 then b else c) t2 m2 v2 -> + t = t1 ** t2 -> + eval_expr sp le e m (Econdition a b c) t m2 v2 + | eval_Elet: + forall sp le e m a b t t1 m1 v1 t2 m2 v2, + eval_expr sp le e m a t1 m1 v1 -> + eval_expr sp (v1::le) e m1 b t2 m2 v2 -> + t = t1 ** t2 -> + eval_expr sp le e m (Elet a b) t m2 v2 + | eval_Eletvar: + forall sp le e m n v, + nth_error le n = Some v -> + eval_expr sp le e m (Eletvar n) E0 m v + | eval_Ealloc: + forall sp le e m a t m1 n m2 b, + eval_expr sp le e m a t m1 (Vint n) -> + Mem.alloc m1 0 (Int.signed n) = (m2, b) -> + eval_expr sp le e m (Ealloc a) t m2 (Vptr b Int.zero) + +with eval_condexpr: + val -> letenv -> env -> + mem -> condexpr -> trace -> mem -> bool -> Prop := + | eval_CEtrue: + forall sp le e m, + eval_condexpr sp le e m CEtrue E0 m true + | eval_CEfalse: + forall sp le e m, + eval_condexpr sp le e m CEfalse E0 m false + | eval_CEcond: + forall sp le e m cond al t1 m1 vl b, + eval_exprlist sp le e m al t1 m1 vl -> + eval_condition cond vl m1 = Some b -> + eval_condexpr sp le e m (CEcond cond al) t1 m1 b + | eval_CEcondition: + forall sp le e m a b c t t1 m1 vb1 t2 m2 vb2, + eval_condexpr sp le e m a t1 m1 vb1 -> + eval_condexpr sp le e m1 (if vb1 then b else c) t2 m2 vb2 -> + t = t1 ** t2 -> + eval_condexpr sp le e m (CEcondition a b c) t m2 vb2 + +with eval_exprlist: + val -> letenv -> env -> + mem -> exprlist -> trace -> mem -> list val -> Prop := + | eval_Enil: + forall sp le e m, + eval_exprlist sp le e m Enil E0 m nil + | eval_Econs: + forall sp le e m a bl t t1 m1 v t2 m2 vl, + eval_expr sp le e m a t1 m1 v -> + eval_exprlist sp le e m1 bl t2 m2 vl -> + t = t1 ** t2 -> + eval_exprlist sp le e m (Econs a bl) t m2 (v :: vl) + +with eval_funcall: + mem -> fundef -> list val -> trace -> + mem -> val -> Prop := + | eval_funcall_internal: + forall m f vargs m1 sp e t e2 m2 out vres, + Mem.alloc m 0 f.(fn_stackspace) = (m1, sp) -> + set_locals f.(fn_vars) (set_params vargs f.(fn_params)) = e -> + exec_stmt (Vptr sp Int.zero) e m1 f.(fn_body) t e2 m2 out -> + outcome_result_value out f.(fn_sig).(sig_res) vres -> + eval_funcall m (Internal f) vargs t (outcome_free_mem out m2 sp) vres + | eval_funcall_external: + forall ef m args t res, + event_match ef args t res -> + eval_funcall m (External ef) args t m res + +with exec_stmt: + val -> + env -> mem -> stmt -> trace -> + env -> mem -> outcome -> Prop := + | exec_Sskip: + forall sp e m, + exec_stmt sp e m Sskip E0 e m Out_normal + | exec_Sexpr: + forall sp e m a t m1 v, + eval_expr sp nil e m a t m1 v -> + exec_stmt sp e m (Sexpr a) t e m1 Out_normal + | exec_Sassign: + forall sp e m id a t m1 v, + eval_expr sp nil e m a t m1 v -> + exec_stmt sp e m (Sassign id a) t (PTree.set id v e) m1 Out_normal + | exec_Sifthenelse: + forall sp e m a s1 s2 t t1 m1 v1 t2 e2 m2 out, + eval_condexpr sp nil e m a t1 m1 v1 -> + exec_stmt sp e m1 (if v1 then s1 else s2) t2 e2 m2 out -> + t = t1 ** t2 -> + exec_stmt sp e m (Sifthenelse a s1 s2) t e2 m2 out + | exec_Sseq_continue: + forall sp e m t s1 t1 e1 m1 s2 t2 e2 m2 out, + exec_stmt sp e m s1 t1 e1 m1 Out_normal -> + exec_stmt sp e1 m1 s2 t2 e2 m2 out -> + t = t1 ** t2 -> + exec_stmt sp e m (Sseq s1 s2) t e2 m2 out + | exec_Sseq_stop: + forall sp e m t s1 s2 e1 m1 out, + exec_stmt sp e m s1 t e1 m1 out -> + out <> Out_normal -> + exec_stmt sp e m (Sseq s1 s2) t e1 m1 out + | exec_Sloop_loop: + forall sp e m s t t1 e1 m1 t2 e2 m2 out, + exec_stmt sp e m s t1 e1 m1 Out_normal -> + exec_stmt sp e1 m1 (Sloop s) t2 e2 m2 out -> + t = t1 ** t2 -> + exec_stmt sp e m (Sloop s) t e2 m2 out + | exec_Sloop_stop: + forall sp e m t s e1 m1 out, + exec_stmt sp e m s t e1 m1 out -> + out <> Out_normal -> + exec_stmt sp e m (Sloop s) t e1 m1 out + | exec_Sblock: + forall sp e m s t e1 m1 out, + exec_stmt sp e m s t e1 m1 out -> + exec_stmt sp e m (Sblock s) t e1 m1 (outcome_block out) + | exec_Sexit: + forall sp e m n, + exec_stmt sp e m (Sexit n) E0 e m (Out_exit n) + | exec_Sswitch: + forall sp e m a cases default t1 m1 n, + eval_expr sp nil e m a t1 m1 (Vint n) -> + exec_stmt sp e m (Sswitch a cases default) + t1 e m1 (Out_exit (switch_target n default cases)) + | exec_Sreturn_none: + forall sp e m, + exec_stmt sp e m (Sreturn None) E0 e m (Out_return None) + | exec_Sreturn_some: + forall sp e m a t m1 v, + eval_expr sp nil e m a t m1 v -> + exec_stmt sp e m (Sreturn (Some a)) t e m1 (Out_return (Some v)) + | exec_Stailcall: + forall sp e m sig a bl t t1 m1 t2 m2 t3 m3 vf vargs vres f, + eval_expr (Vptr sp Int.zero) nil e m a t1 m1 vf -> + eval_exprlist (Vptr sp Int.zero) nil e m1 bl t2 m2 vargs -> + Genv.find_funct ge vf = Some f -> + funsig f = sig -> + eval_funcall (Mem.free m2 sp) f vargs t3 m3 vres -> + t = t1 ** t2 ** t3 -> + exec_stmt (Vptr sp Int.zero) e m (Stailcall sig a bl) t e m3 (Out_tailcall_return vres). + +Scheme eval_expr_ind5 := Minimality for eval_expr Sort Prop + with eval_condexpr_ind5 := Minimality for eval_condexpr Sort Prop + with eval_exprlist_ind5 := Minimality for eval_exprlist Sort Prop + with eval_funcall_ind5 := Minimality for eval_funcall Sort Prop + with exec_stmt_ind5 := Minimality for exec_stmt Sort Prop. + +End RELSEM. + +Definition exec_program (p: program) (t: trace) (r: val) : Prop := + let ge := Genv.globalenv p in + let m0 := Genv.init_mem p in + exists b, exists f, exists m, + Genv.find_symbol ge p.(prog_main) = Some b /\ + Genv.find_funct_ptr ge b = Some f /\ + funsig f = mksignature nil (Some Tint) /\ + eval_funcall ge m0 f nil t m r. + diff --git a/backend/Coloring.v b/backend/Coloring.v index 0b8a4ccc..57f7d594 100644 --- a/backend/Coloring.v +++ b/backend/Coloring.v @@ -150,6 +150,8 @@ Definition add_edges_instr (add_interf_op res live (add_interf_call (Regset.remove res live) destroyed_at_call_regs g))) + | Itailcall sig ros args => + add_prefs_call args (loc_arguments sig) g | Ialloc arg res s => add_pref_mreg arg loc_alloc_argument (add_pref_mreg res loc_alloc_result diff --git a/backend/Coloringproof.v b/backend/Coloringproof.v index f3801d07..ce24030d 100644 --- a/backend/Coloringproof.v +++ b/backend/Coloringproof.v @@ -325,6 +325,7 @@ Proof. eapply graph_incl_trans; [idtac|apply add_pref_mreg_incl]. eapply graph_incl_trans; [idtac|apply add_interf_op_incl]. apply add_interf_call_incl. + apply add_prefs_call_incl. eapply graph_incl_trans; [idtac|apply add_pref_mreg_incl]. eapply graph_incl_trans; [idtac|apply add_pref_mreg_incl]. eapply graph_incl_trans; [idtac|apply add_interf_op_incl]. diff --git a/backend/Constprop.v b/backend/Constprop.v index d34c6eed..fecfb19f 100644 --- a/backend/Constprop.v +++ b/backend/Constprop.v @@ -632,6 +632,8 @@ Definition transfer (f: function) (pc: node) (before: D.t) := before | Icall sig ros args res s => D.set res Unknown before + | Itailcall sig ros args => + before | Ialloc arg res s => D.set res Unknown before | Icond cond args ifso ifnot => @@ -649,9 +651,12 @@ Definition transfer (f: function) (pc: node) (before: D.t) := Module DS := Dataflow_Solver(D)(NodeSetForward). -Definition analyze (f: RTL.function): option (PMap.t D.t) := - DS.fixpoint (successors f) f.(fn_nextpc) (transfer f) - ((f.(fn_entrypoint), D.top) :: nil). +Definition analyze (f: RTL.function): PMap.t D.t := + match DS.fixpoint (successors f) f.(fn_nextpc) (transfer f) + ((f.(fn_entrypoint), D.top) :: nil) with + | None => PMap.init D.top + | Some res => res + end. (** * Code transformation *) @@ -986,6 +991,16 @@ End STRENGTH_REDUCTION. and similarly for the addressing modes of load and store instructions. Other instructions are unchanged. *) +Definition transf_ros (approx: D.t) (ros: reg + ident) : reg + ident := + match ros with + | inl r => + match D.get r approx with + | S symb ofs => if Int.eq ofs Int.zero then inr _ symb else ros + | _ => ros + end + | inr s => ros + end. + Definition transf_instr (approx: D.t) (instr: instruction) := match instr with | Iop op args res s => @@ -1007,16 +1022,9 @@ Definition transf_instr (approx: D.t) (instr: instruction) := let (addr', args') := addr_strength_reduction approx addr args in Istore chunk addr' args' src s | Icall sig ros args res s => - let ros' := - match ros with - | inl r => - match D.get r approx with - | S symb ofs => if Int.eq ofs Int.zero then inr _ symb else ros - | _ => ros - end - | inr s => ros - end in - Icall sig ros' args res s + Icall sig (transf_ros approx ros) args res s + | Itailcall sig ros args => + Itailcall sig (transf_ros approx ros) args | Ialloc arg res s => Ialloc arg res s | Icond cond args s1 s2 => @@ -1048,20 +1056,18 @@ Proof. Qed. Definition transf_function (f: function) : function := - match analyze f with - | None => f - | Some approxs => - mkfunction - f.(fn_sig) - f.(fn_params) - f.(fn_stacksize) - (transf_code approxs f.(fn_code)) - f.(fn_entrypoint) - f.(fn_nextpc) - (transf_code_wf f approxs f.(fn_code_wf)) - end. + let approxs := analyze f in + mkfunction + f.(fn_sig) + f.(fn_params) + f.(fn_stacksize) + (transf_code approxs f.(fn_code)) + f.(fn_entrypoint) + f.(fn_nextpc) + (transf_code_wf f approxs f.(fn_code_wf)). -Definition transf_fundef := AST.transf_fundef transf_function. +Definition transf_fundef (fd: fundef) : fundef := + AST.transf_fundef transf_function fd. Definition transf_program (p: program) : program := transform_program transf_fundef p. diff --git a/backend/Constpropproof.v b/backend/Constpropproof.v index ee241873..dfa828bf 100644 --- a/backend/Constpropproof.v +++ b/backend/Constpropproof.v @@ -9,6 +9,7 @@ Require Import Values. Require Import Events. Require Import Mem. Require Import Globalenvs. +Require Import Smallstep. Require Import Op. Require Import Registers. Require Import RTL. @@ -41,6 +42,13 @@ Definition val_match_approx (a: approx) (v: val) : Prop := Definition regs_match_approx (a: D.t) (rs: regset) : Prop := forall r, val_match_approx (D.get r a) rs#r. +Lemma regs_match_approx_top: + forall rs, regs_match_approx D.top rs. +Proof. + intros. red; intros. simpl. rewrite PTree.gempty. + unfold Approx.top, val_match_approx. auto. +Qed. + Lemma val_match_approx_increasing: forall a1 a2 v, Approx.ge a1 a2 -> val_match_approx a2 v -> val_match_approx a1 v. @@ -123,10 +131,10 @@ Ltac InvVLMA := approximations returned by [eval_static_operation]. *) Lemma eval_static_condition_correct: - forall cond al vl b, + forall cond al vl m b, val_list_match_approx al vl -> eval_static_condition cond al = Some b -> - eval_condition cond vl = Some b. + eval_condition cond vl m = Some b. Proof. intros until b. unfold eval_static_condition. @@ -135,9 +143,9 @@ Proof. Qed. Lemma eval_static_operation_correct: - forall op sp al vl v, + forall op sp al vl m v, val_list_match_approx al vl -> - eval_operation ge sp op vl = Some v -> + eval_operation ge sp op vl m = Some v -> val_match_approx (eval_static_operation op al) v. Proof. intros until v. @@ -183,7 +191,7 @@ Proof. rewrite <- H3. replace v0 with (Vfloat n1). reflexivity. congruence. caseEq (eval_static_condition c vl0). - intros. generalize (eval_static_condition_correct _ _ _ _ H H1). + intros. generalize (eval_static_condition_correct _ _ _ m _ H H1). intro. rewrite H2 in H0. destruct b; injection H0; intro; subst v; simpl; auto. intros; simpl; auto. @@ -194,80 +202,40 @@ Proof. auto. Qed. -(** The correctness of the transfer function follows: if the register - state before a transition matches the static approximations at that - program point, the register state after that transition matches - the static approximation returned by the transfer function. *) - -Lemma transfer_correct: - forall f c sp pc rs m t pc' rs' m' ra, - exec_instr ge c sp pc rs m t pc' rs' m' -> - c = f.(fn_code) -> - regs_match_approx ra rs -> - regs_match_approx (transfer f pc ra) rs'. -Proof. - induction 1; intros; subst c; unfold transfer; rewrite H; auto. - (* Iop *) - apply regs_match_approx_update. - apply eval_static_operation_correct with sp rs##args. - eapply approx_regs_val_list. auto. auto. auto. - (* Iload *) - apply regs_match_approx_update; auto. simpl; auto. - (* Icall *) - apply regs_match_approx_update; auto. simpl; auto. - (* Ialloc *) - apply regs_match_approx_update; auto. simpl; auto. -Qed. - (** The correctness of the static analysis follows from the results above and the fact that the result of the static analysis is a solution of the forward dataflow inequations. *) Lemma analyze_correct_1: - forall f approxs, - analyze f = Some approxs -> - forall c sp pc rs m t pc' rs' m', - exec_instr ge c sp pc rs m t pc' rs' m' -> - c = f.(fn_code) -> - regs_match_approx approxs!!pc rs -> - regs_match_approx approxs!!pc' rs'. + forall f pc rs pc', + In pc' (successors f pc) -> + regs_match_approx (transfer f pc (analyze f)!!pc) rs -> + regs_match_approx (analyze f)!!pc' rs. Proof. - intros. + intros until pc'. unfold analyze. + caseEq (DS.fixpoint (successors f) (fn_nextpc f) (transfer f) + ((fn_entrypoint f, D.top) :: nil)). + intros approxs; intros. apply regs_match_approx_increasing with (transfer f pc approxs!!pc). - eapply DS.fixpoint_solution. - unfold analyze in H. eexact H. + eapply DS.fixpoint_solution; eauto. elim (fn_code_wf f pc); intro. auto. - generalize (exec_instr_present _ _ _ _ _ _ _ _ _ _ H0). - rewrite H1. intro. contradiction. - eapply successors_correct. rewrite <- H1. eauto. - eapply transfer_correct; eauto. -Qed. - -Lemma analyze_correct_2: - forall f approxs, - analyze f = Some approxs -> - forall c sp pc rs m t pc' rs' m', - exec_instrs ge c sp pc rs m t pc' rs' m' -> - c = f.(fn_code) -> - regs_match_approx approxs!!pc rs -> - regs_match_approx approxs!!pc' rs'. -Proof. - intros f approxs ANL. induction 1. + unfold successors in H0; rewrite H2 in H0; simpl; contradiction. auto. - intros. eapply analyze_correct_1; eauto. - eauto. + intros. rewrite PMap.gi. apply regs_match_approx_top. Qed. Lemma analyze_correct_3: - forall f approxs rs, - analyze f = Some approxs -> - regs_match_approx approxs!!(f.(fn_entrypoint)) rs. + forall f rs, + regs_match_approx (analyze f)!!(f.(fn_entrypoint)) rs. Proof. - intros. + intros. unfold analyze. + caseEq (DS.fixpoint (successors f) (fn_nextpc f) (transfer f) + ((fn_entrypoint f, D.top) :: nil)). + intros approxs; intros. apply regs_match_approx_increasing with D.top. - eapply DS.fixpoint_entry. unfold analyze in H; eexact H. - auto with coqlib. - red; intros. rewrite D.get_top. simpl; auto. + eapply DS.fixpoint_entry; eauto. auto with coqlib. + apply regs_match_approx_top. + intros. rewrite PMap.gi. apply regs_match_approx_top. Qed. (** * Correctness of strength reduction *) @@ -296,9 +264,9 @@ Proof. Qed. Lemma cond_strength_reduction_correct: - forall cond args, + forall cond args m, let (cond', args') := cond_strength_reduction approx cond args in - eval_condition cond' rs##args' = eval_condition cond rs##args. + eval_condition cond' rs##args' m = eval_condition cond rs##args m. Proof. intros. unfold cond_strength_reduction. case (cond_strength_reduction_match cond args); intros. @@ -312,7 +280,6 @@ Proof. caseEq (intval approx r1); intros. simpl. rewrite (intval_correct _ _ H). destruct (rs#r2); auto. rewrite Int.swap_cmpu. auto. - destruct c; reflexivity. caseEq (intval approx r2); intros. simpl. rewrite (intval_correct _ _ H0). auto. auto. @@ -320,10 +287,10 @@ Proof. Qed. Lemma make_addimm_correct: - forall n r v, + forall n r m v, let (op, args) := make_addimm n r in - eval_operation ge sp Oadd (rs#r :: Vint n :: nil) = Some v -> - eval_operation ge sp op rs##args = Some v. + eval_operation ge sp Oadd (rs#r :: Vint n :: nil) m = Some v -> + eval_operation ge sp op rs##args m = Some v. Proof. intros; unfold make_addimm. generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. @@ -333,10 +300,10 @@ Proof. Qed. Lemma make_shlimm_correct: - forall n r v, + forall n r m v, let (op, args) := make_shlimm n r in - eval_operation ge sp Oshl (rs#r :: Vint n :: nil) = Some v -> - eval_operation ge sp op rs##args = Some v. + eval_operation ge sp Oshl (rs#r :: Vint n :: nil) m = Some v -> + eval_operation ge sp op rs##args m = Some v. Proof. intros; unfold make_shlimm. generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. @@ -347,10 +314,10 @@ Proof. Qed. Lemma make_shrimm_correct: - forall n r v, + forall n r m v, let (op, args) := make_shrimm n r in - eval_operation ge sp Oshr (rs#r :: Vint n :: nil) = Some v -> - eval_operation ge sp op rs##args = Some v. + eval_operation ge sp Oshr (rs#r :: Vint n :: nil) m = Some v -> + eval_operation ge sp op rs##args m = Some v. Proof. intros; unfold make_shrimm. generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. @@ -359,10 +326,10 @@ Proof. Qed. Lemma make_shruimm_correct: - forall n r v, + forall n r m v, let (op, args) := make_shruimm n r in - eval_operation ge sp Oshru (rs#r :: Vint n :: nil) = Some v -> - eval_operation ge sp op rs##args = Some v. + eval_operation ge sp Oshru (rs#r :: Vint n :: nil) m = Some v -> + eval_operation ge sp op rs##args m = Some v. Proof. intros; unfold make_shruimm. generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. @@ -373,10 +340,10 @@ Proof. Qed. Lemma make_mulimm_correct: - forall n r v, + forall n r m v, let (op, args) := make_mulimm n r in - eval_operation ge sp Omul (rs#r :: Vint n :: nil) = Some v -> - eval_operation ge sp op rs##args = Some v. + eval_operation ge sp Omul (rs#r :: Vint n :: nil) m = Some v -> + eval_operation ge sp op rs##args m = Some v. Proof. intros; unfold make_mulimm. generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. @@ -384,8 +351,8 @@ Proof. generalize (Int.eq_spec n Int.one); case (Int.eq n Int.one); intros. subst n. simpl in H1. simpl. FuncInv. rewrite Int.mul_one in H0. congruence. caseEq (Int.is_power2 n); intros. - replace (eval_operation ge sp Omul (rs # r :: Vint n :: nil)) - with (eval_operation ge sp Oshl (rs # r :: Vint i :: nil)). + replace (eval_operation ge sp Omul (rs # r :: Vint n :: nil) m) + with (eval_operation ge sp Oshl (rs # r :: Vint i :: nil) m). apply make_shlimm_correct. simpl. generalize (Int.is_power2_range _ _ H1). change (Z_of_nat wordsize) with 32. intro. rewrite H2. @@ -394,10 +361,10 @@ Proof. Qed. Lemma make_andimm_correct: - forall n r v, + forall n r m v, let (op, args) := make_andimm n r in - eval_operation ge sp Oand (rs#r :: Vint n :: nil) = Some v -> - eval_operation ge sp op rs##args = Some v. + eval_operation ge sp Oand (rs#r :: Vint n :: nil) m = Some v -> + eval_operation ge sp op rs##args m = Some v. Proof. intros; unfold make_andimm. generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. @@ -408,10 +375,10 @@ Proof. Qed. Lemma make_orimm_correct: - forall n r v, + forall n r m v, let (op, args) := make_orimm n r in - eval_operation ge sp Oor (rs#r :: Vint n :: nil) = Some v -> - eval_operation ge sp op rs##args = Some v. + eval_operation ge sp Oor (rs#r :: Vint n :: nil) m = Some v -> + eval_operation ge sp op rs##args m = Some v. Proof. intros; unfold make_orimm. generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. @@ -422,10 +389,10 @@ Proof. Qed. Lemma make_xorimm_correct: - forall n r v, + forall n r m v, let (op, args) := make_xorimm n r in - eval_operation ge sp Oxor (rs#r :: Vint n :: nil) = Some v -> - eval_operation ge sp op rs##args = Some v. + eval_operation ge sp Oxor (rs#r :: Vint n :: nil) m = Some v -> + eval_operation ge sp op rs##args m = Some v. Proof. intros; unfold make_xorimm. generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intros. @@ -434,18 +401,18 @@ Proof. Qed. Lemma op_strength_reduction_correct: - forall op args v, + forall op args m v, let (op', args') := op_strength_reduction approx op args in - eval_operation ge sp op rs##args = Some v -> - eval_operation ge sp op' rs##args' = Some v. + eval_operation ge sp op rs##args m = Some v -> + eval_operation ge sp op' rs##args' m = Some v. Proof. intros; unfold op_strength_reduction; case (op_strength_reduction_match op args); intros; simpl List.map. (* Oadd *) caseEq (intval approx r1); intros. rewrite (intval_correct _ _ H). - replace (eval_operation ge sp Oadd (Vint i :: rs # r2 :: nil)) - with (eval_operation ge sp Oadd (rs # r2 :: Vint i :: nil)). + replace (eval_operation ge sp Oadd (Vint i :: rs # r2 :: nil) m) + with (eval_operation ge sp Oadd (rs # r2 :: Vint i :: nil) m). apply make_addimm_correct. simpl. destruct rs#r2; auto. rewrite Int.add_commut; auto. caseEq (intval approx r2); intros. @@ -456,16 +423,16 @@ Proof. rewrite (intval_correct _ _ H) in H0. assumption. caseEq (intval approx r2); intros. rewrite (intval_correct _ _ H0). - replace (eval_operation ge sp Osub (rs # r1 :: Vint i :: nil)) - with (eval_operation ge sp Oadd (rs # r1 :: Vint (Int.neg i) :: nil)). + replace (eval_operation ge sp Osub (rs # r1 :: Vint i :: nil) m) + with (eval_operation ge sp Oadd (rs # r1 :: Vint (Int.neg i) :: nil) m). apply make_addimm_correct. simpl. destruct rs#r1; auto; rewrite Int.sub_add_opp; auto. assumption. (* Omul *) caseEq (intval approx r1); intros. rewrite (intval_correct _ _ H). - replace (eval_operation ge sp Omul (Vint i :: rs # r2 :: nil)) - with (eval_operation ge sp Omul (rs # r2 :: Vint i :: nil)). + replace (eval_operation ge sp Omul (Vint i :: rs # r2 :: nil) m) + with (eval_operation ge sp Omul (rs # r2 :: Vint i :: nil) m). apply make_mulimm_correct. simpl. destruct rs#r2; auto. rewrite Int.mul_commut; auto. caseEq (intval approx r2); intros. @@ -485,8 +452,8 @@ Proof. caseEq (intval approx r2); intros. caseEq (Int.is_power2 i); intros. rewrite (intval_correct _ _ H). - replace (eval_operation ge sp Odivu (rs # r1 :: Vint i :: nil)) - with (eval_operation ge sp Oshru (rs # r1 :: Vint i0 :: nil)). + replace (eval_operation ge sp Odivu (rs # r1 :: Vint i :: nil) m) + with (eval_operation ge sp Oshru (rs # r1 :: Vint i0 :: nil) m). apply make_shruimm_correct. simpl. destruct rs#r1; auto. change 32 with (Z_of_nat wordsize). @@ -499,8 +466,8 @@ Proof. (* Oand *) caseEq (intval approx r1); intros. rewrite (intval_correct _ _ H). - replace (eval_operation ge sp Oand (Vint i :: rs # r2 :: nil)) - with (eval_operation ge sp Oand (rs # r2 :: Vint i :: nil)). + replace (eval_operation ge sp Oand (Vint i :: rs # r2 :: nil) m) + with (eval_operation ge sp Oand (rs # r2 :: Vint i :: nil) m). apply make_andimm_correct. simpl. destruct rs#r2; auto. rewrite Int.and_commut; auto. caseEq (intval approx r2); intros. @@ -509,8 +476,8 @@ Proof. (* Oor *) caseEq (intval approx r1); intros. rewrite (intval_correct _ _ H). - replace (eval_operation ge sp Oor (Vint i :: rs # r2 :: nil)) - with (eval_operation ge sp Oor (rs # r2 :: Vint i :: nil)). + replace (eval_operation ge sp Oor (Vint i :: rs # r2 :: nil) m) + with (eval_operation ge sp Oor (rs # r2 :: Vint i :: nil) m). apply make_orimm_correct. simpl. destruct rs#r2; auto. rewrite Int.or_commut; auto. caseEq (intval approx r2); intros. @@ -519,8 +486,8 @@ Proof. (* Oxor *) caseEq (intval approx r1); intros. rewrite (intval_correct _ _ H). - replace (eval_operation ge sp Oxor (Vint i :: rs # r2 :: nil)) - with (eval_operation ge sp Oxor (rs # r2 :: Vint i :: nil)). + replace (eval_operation ge sp Oxor (Vint i :: rs # r2 :: nil) m) + with (eval_operation ge sp Oxor (rs # r2 :: Vint i :: nil) m). apply make_xorimm_correct. simpl. destruct rs#r2; auto. rewrite Int.xor_commut; auto. caseEq (intval approx r2); intros. @@ -647,261 +614,329 @@ 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). +Proof. + intros; unfold ge, tge, tprog, transf_program. + apply Genv.find_symbol_transf. +Qed. Lemma functions_translated: - forall (v: val) (f: RTL.fundef), + forall (v: val) (f: 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. + intros. + exact (Genv.find_funct_transf transf_fundef H). +Qed. Lemma function_ptr_translated: - forall (v: block) (f: RTL.fundef), - 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). + 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. -Lemma sig_translated: - forall (f: RTL.fundef), +Lemma sig_function_translated: + forall f, funsig (transf_fundef f) = funsig f. Proof. - intro. case f; intros; simpl. - unfold transf_function. case (analyze f0); intros; reflexivity. - reflexivity. + intros. destruct f; reflexivity. +Qed. + +Lemma transf_ros_correct: + forall ros rs f approx, + regs_match_approx ge approx rs -> + find_function ge ros rs = Some f -> + find_function tge (transf_ros approx ros) rs = Some (transf_fundef f). +Proof. + intros until approx; intro MATCH. + destruct ros; simpl. + intro. + exploit functions_translated; eauto. intro FIND. + caseEq (D.get r approx); intros; auto. + generalize (Int.eq_spec i0 Int.zero); case (Int.eq i0 Int.zero); intros; auto. + generalize (MATCH r). rewrite H0. intros [b [A B]]. + rewrite <- symbols_preserved in A. + rewrite B in FIND. rewrite H1 in FIND. + rewrite Genv.find_funct_find_funct_ptr in FIND. + simpl. rewrite A. auto. + rewrite symbols_preserved. destruct (Genv.find_symbol ge i). + intro. apply function_ptr_translated. auto. + congruence. Qed. (** The proof of semantic preservation is a simulation argument based on diagrams of the following form: << - pc, rs, m ------------------- pc, rs, m - | | - | | - v v - pc', rs', m' ---------------- pc', rs', m' + st1 --------------- st2 + | | + t| |t + | | + v v + st1'--------------- st2' >> The left vertical arrow represents a transition in the - original RTL code. The top horizontal bar expresses that the values - of registers [rs] match their compile-time approximations at point [pc]. + original RTL code. The top horizontal bar is the [match_states] + invariant between the initial state [st1] in the original RTL code + and an initial state [st2] in the transformed code. + This invariant expresses that all code fragments appearing in [st2] + are obtained by [transf_code] transformation of the corresponding + fragments in [st1]. Moreover, the values of registers in [st1] + must match their compile-time approximations at the current program + point. These two parts of the diagram are the hypotheses. In conclusions, we want to prove the other two parts: the right vertical arrow, which is a transition in the transformed RTL code, and the bottom - horizontal bar, which means that [rs'] matches the compile-time - approximations at [pc']. - - To help express those diagrams, we define the following propositions - parameterized by the transition in the original RTL code (left arrow) - and summarizing the three other arrows of the diagram. *) - -Definition exec_instr_prop - (c: code) (sp: val) - (pc: node) (rs: regset) (m: mem) (t: trace) - (pc': node) (rs': regset) (m': mem) : Prop := - exec_instr tge c sp pc rs m t pc' rs' m' /\ - forall f approxs - (CF: c = f.(RTL.fn_code)) - (ANL: analyze f = Some approxs) - (MATCH: regs_match_approx ge approxs!!pc rs), - exec_instr tge (transf_code approxs c) sp pc rs m t pc' rs' m'. - -Definition exec_instrs_prop - (c: code) (sp: val) - (pc: node) (rs: regset) (m: mem) (t: trace) - (pc': node) (rs': regset) (m': mem) : Prop := - exec_instrs tge c sp pc rs m t pc' rs' m' /\ - forall f approxs - (CF: c = f.(RTL.fn_code)) - (ANL: analyze f = Some approxs) - (MATCH: regs_match_approx ge approxs!!pc rs), - exec_instrs tge (transf_code approxs c) sp pc rs m t pc' rs' m'. - -Definition exec_function_prop - (f: RTL.fundef) (args: list val) (m: mem) (t: trace) - (res: val) (m': mem) : Prop := - exec_function tge (transf_fundef f) args m t res m'. + horizontal bar, which means that the [match_state] predicate holds + between the final states [st1'] and [st2']. *) + +Inductive match_stackframes: stackframe -> stackframe -> Prop := + match_stackframe_intro: + forall res c sp pc rs f, + c = f.(RTL.fn_code) -> + (forall v, regs_match_approx ge (analyze f)!!pc (rs#res <- v)) -> + match_stackframes + (Stackframe res c sp pc rs) + (Stackframe res (transf_code (analyze f) c) sp pc rs). + +Inductive match_states: state -> state -> Prop := + | match_states_intro: + forall s c sp pc rs m f s' + (CF: c = f.(RTL.fn_code)) + (MATCH: regs_match_approx ge (analyze f)!!pc rs) + (STACKS: list_forall2 match_stackframes s s'), + match_states (State s c sp pc rs m) + (State s' (transf_code (analyze f) c) sp pc rs m) + | match_states_call: + forall s f args m s', + list_forall2 match_stackframes s s' -> + match_states (Callstate s f args m) + (Callstate s' (transf_fundef f) args m) + | match_states_return: + forall s s' v m, + list_forall2 match_stackframes s s' -> + match_states (Returnstate s v m) + (Returnstate s' v m). Ltac TransfInstr := match goal with - | H1: (PTree.get ?pc ?c = Some ?instr), - H2: (analyze ?f = Some ?approxs) |- _ => - cut ((transf_code approxs c)!pc = Some(transf_instr approxs!!pc instr)); + | H1: (PTree.get ?pc ?c = Some ?instr), f: function |- _ => + cut ((transf_code (analyze f) c)!pc = Some(transf_instr (analyze f)!!pc instr)); [ simpl | unfold transf_code; rewrite PTree.gmap; unfold option_map; rewrite H1; reflexivity ] end. -(** The predicates above serve as induction hypotheses in the proof of - simulation, which proceeds by induction over the - evaluation derivation of the original code. *) +(** The proof of simulation proceeds by case analysis on the transition + taken in the source code. *) -Lemma transf_funct_correct: - forall f args m t res m', - exec_function ge f args m t res m' -> - exec_function_prop f args m t res m'. +Lemma transf_step_correct: + forall s1 t s2, + step ge s1 t s2 -> + forall s1' (MS: match_states s1 s1'), + exists s2', step tge s1' t s2' /\ match_states s2 s2'. Proof. - apply (exec_function_ind_3 ge - exec_instr_prop exec_instrs_prop exec_function_prop); - intros; red. + induction 1; intros; inv MS. + (* Inop *) - split; [idtac| intros; TransfInstr]. - apply exec_Inop; auto. - intros; apply exec_Inop; auto. + exists (State s' (transf_code (analyze f) (fn_code f)) sp pc' rs m); split. + TransfInstr; intro. eapply exec_Inop; eauto. + econstructor; eauto. + eapply analyze_correct_1 with (pc := pc); eauto. + unfold successors; rewrite H; auto with coqlib. + unfold transfer; rewrite H. auto. + (* Iop *) - split; [idtac| intros; TransfInstr]. - apply exec_Iop with op args. auto. - rewrite (eval_operation_preserved symbols_preserved). auto. - caseEq (op_strength_reduction approxs!!pc op args); + exists (State s' (transf_code (analyze f) (fn_code f)) sp pc' (rs#res <- v) m); split. + TransfInstr. caseEq (op_strength_reduction (analyze f)!!pc op args); intros op' args' OSR. - assert (eval_operation tge sp op' rs##args' = Some v). + assert (eval_operation tge sp op' rs##args' m = Some v). rewrite (eval_operation_preserved symbols_preserved). - generalize (op_strength_reduction_correct ge approxs!!pc sp rs - MATCH op args v). + generalize (op_strength_reduction_correct ge (analyze f)!!pc sp rs + MATCH op args m v). rewrite OSR; simpl. auto. generalize (eval_static_operation_correct ge op sp - (approx_regs args approxs!!pc) rs##args v + (approx_regs args (analyze f)!!pc) rs##args m v (approx_regs_val_list _ _ _ args MATCH) H0). - case (eval_static_operation op (approx_regs args approxs!!pc)); intros; - simpl in H1; + case (eval_static_operation op (approx_regs args (analyze f)!!pc)); intros; + simpl in H2; eapply exec_Iop; eauto; simpl. - simpl in H2; congruence. - simpl in H2; congruence. + congruence. + congruence. elim H2; intros b [A B]. rewrite symbols_preserved. rewrite A; rewrite B; auto. + econstructor; eauto. + eapply analyze_correct_1 with (pc := pc); eauto. + unfold successors; rewrite H; auto with coqlib. + unfold transfer; rewrite H. + apply regs_match_approx_update; auto. + eapply eval_static_operation_correct; eauto. + apply approx_regs_val_list; auto. + (* Iload *) - split; [idtac| intros; TransfInstr]. - eapply exec_Iload; eauto. - rewrite (eval_addressing_preserved symbols_preserved). auto. - caseEq (addr_strength_reduction approxs!!pc addr args); + caseEq (addr_strength_reduction (analyze f)!!pc addr args); intros addr' args' ASR. assert (eval_addressing tge sp addr' rs##args' = Some a). rewrite (eval_addressing_preserved symbols_preserved). - generalize (addr_strength_reduction_correct ge approxs!!pc sp rs + generalize (addr_strength_reduction_correct ge (analyze f)!!pc sp rs MATCH addr args). rewrite ASR; simpl. congruence. - intro. eapply exec_Iload; eauto. + TransfInstr. rewrite ASR. intro. + exists (State s' (transf_code (analyze f) (fn_code f)) sp pc' (rs#dst <- v) m); split. + eapply exec_Iload; eauto. + econstructor; eauto. + apply analyze_correct_1 with pc; auto. + unfold successors; rewrite H; auto with coqlib. + unfold transfer; rewrite H. + apply regs_match_approx_update; auto. simpl; auto. + (* Istore *) - split; [idtac| intros; TransfInstr]. - eapply exec_Istore; eauto. - rewrite (eval_addressing_preserved symbols_preserved). auto. - caseEq (addr_strength_reduction approxs!!pc addr args); + caseEq (addr_strength_reduction (analyze f)!!pc addr args); intros addr' args' ASR. assert (eval_addressing tge sp addr' rs##args' = Some a). rewrite (eval_addressing_preserved symbols_preserved). - generalize (addr_strength_reduction_correct ge approxs!!pc sp rs + generalize (addr_strength_reduction_correct ge (analyze f)!!pc sp rs MATCH addr args). - rewrite ASR; simpl. congruence. - intro. eapply exec_Istore; eauto. + rewrite ASR; simpl. congruence. + TransfInstr. rewrite ASR. intro. + exists (State s' (transf_code (analyze f) (fn_code f)) sp pc' rs m'); split. + eapply exec_Istore; eauto. + econstructor; eauto. + apply analyze_correct_1 with pc; auto. + unfold successors; rewrite H; auto with coqlib. + unfold transfer; rewrite H. auto. + (* Icall *) - assert (find_function tge ros rs = Some (transf_fundef f)). - generalize H0; unfold find_function; destruct ros. - apply functions_translated. - rewrite symbols_preserved. destruct (Genv.find_symbol ge i). - apply function_ptr_translated. congruence. - assert (funsig (transf_fundef f) = sig). - generalize (sig_translated f). congruence. - split; [idtac| intros; TransfInstr]. - eapply exec_Icall; eauto. - set (ros' := - match ros with - | inl r => - match D.get r approxs !! pc with - | Novalue => ros - | Unknown => ros - | I _ => ros - | F _ => ros - | S symb ofs => if Int.eq ofs Int.zero then inr reg symb else ros - end - | inr _ => ros - end). - intros; eapply exec_Icall; eauto. - unfold ros'; destruct ros; auto. - caseEq (D.get r approxs!!pc); intros; auto. - generalize (Int.eq_spec i0 Int.zero); case (Int.eq i0 Int.zero); intros; auto. - generalize (MATCH r). rewrite H7. intros [b [A B]]. - rewrite <- symbols_preserved in A. - generalize H4. simpl. rewrite A. rewrite B. subst i0. - rewrite Genv.find_funct_find_funct_ptr. auto. + exploit transf_ros_correct; eauto. intro FIND'. + TransfInstr; intro. + econstructor; split. + eapply exec_Icall; eauto. apply sig_function_translated; auto. + constructor; auto. constructor; auto. + econstructor; eauto. + intros. apply analyze_correct_1 with pc; auto. + unfold successors; rewrite H; auto with coqlib. + unfold transfer; rewrite H. + apply regs_match_approx_update; auto. simpl. auto. + + (* Itailcall *) + exploit transf_ros_correct; eauto. intros FIND'. + TransfInstr; intro. + econstructor; split. + eapply exec_Itailcall; eauto. apply sig_function_translated; auto. + constructor; auto. (* Ialloc *) - split; [idtac|intros; TransfInstr]. - eapply exec_Ialloc; eauto. - intros. eapply exec_Ialloc; eauto. + TransfInstr; intro. + exists (State s' (transf_code (analyze f) (fn_code f)) sp pc' (rs#res <- (Vptr b Int.zero)) m'); split. + eapply exec_Ialloc; eauto. + econstructor; eauto. + apply analyze_correct_1 with pc; auto. + unfold successors; rewrite H; auto with coqlib. + unfold transfer; rewrite H. + apply regs_match_approx_update; auto. simpl; auto. (* Icond, true *) - split; [idtac| intros; TransfInstr]. - eapply exec_Icond_true; eauto. - caseEq (cond_strength_reduction approxs!!pc cond args); + exists (State s' (transf_code (analyze f) (fn_code f)) sp ifso rs m); split. + caseEq (cond_strength_reduction (analyze f)!!pc cond args); intros cond' args' CSR. - assert (eval_condition cond' rs##args' = Some true). + assert (eval_condition cond' rs##args' m = Some true). generalize (cond_strength_reduction_correct - ge approxs!!pc rs MATCH cond args). + ge (analyze f)!!pc rs MATCH cond args m). rewrite CSR. intro. congruence. - caseEq (eval_static_condition cond (approx_regs args approxs!!pc)). + TransfInstr. rewrite CSR. + caseEq (eval_static_condition cond (approx_regs args (analyze f)!!pc)). intros b ESC. - generalize (eval_static_condition_correct ge cond _ _ _ + generalize (eval_static_condition_correct ge cond _ _ m _ (approx_regs_val_list _ _ _ args MATCH) ESC); intro. replace b with true. intro; eapply exec_Inop; eauto. congruence. - intros. eapply exec_Icond_true; eauto. + intros. eapply exec_Icond_true; eauto. + econstructor; eauto. + apply analyze_correct_1 with pc; auto. + unfold successors; rewrite H; auto with coqlib. + unfold transfer; rewrite H; auto. (* Icond, false *) - split; [idtac| intros; TransfInstr]. - eapply exec_Icond_false; eauto. - caseEq (cond_strength_reduction approxs!!pc cond args); + exists (State s' (transf_code (analyze f) (fn_code f)) sp ifnot rs m); split. + caseEq (cond_strength_reduction (analyze f)!!pc cond args); intros cond' args' CSR. - assert (eval_condition cond' rs##args' = Some false). + assert (eval_condition cond' rs##args' m = Some false). generalize (cond_strength_reduction_correct - ge approxs!!pc rs MATCH cond args). + ge (analyze f)!!pc rs MATCH cond args m). rewrite CSR. intro. congruence. - caseEq (eval_static_condition cond (approx_regs args approxs!!pc)). + TransfInstr. rewrite CSR. + caseEq (eval_static_condition cond (approx_regs args (analyze f)!!pc)). intros b ESC. - generalize (eval_static_condition_correct ge cond _ _ _ + generalize (eval_static_condition_correct ge cond _ _ m _ (approx_regs_val_list _ _ _ args MATCH) ESC); intro. replace b with false. intro; eapply exec_Inop; eauto. congruence. - intros. eapply exec_Icond_false; eauto. - - (* refl *) - split. apply exec_refl. intros. apply exec_refl. - (* one *) - elim H0; intros. - split. apply exec_one; auto. - intros. apply exec_one. eapply H2; eauto. - (* trans *) - elim H0; intros. elim H2; intros. - split. - apply exec_trans with t1 pc2 rs2 m2 t2; auto. - intros; apply exec_trans with t1 pc2 rs2 m2 t2. - eapply H5; eauto. eapply H7; eauto. - eapply analyze_correct_2; eauto. auto. + intros. eapply exec_Icond_false; eauto. + econstructor; eauto. + apply analyze_correct_1 with pc; auto. + unfold successors; rewrite H; auto with coqlib. + unfold transfer; rewrite H; auto. + + (* Ireturn *) + exists (Returnstate s' (regmap_optget or Vundef rs) (free m stk)); split. + eapply exec_Ireturn; eauto. TransfInstr; auto. + constructor; auto. (* internal function *) - elim H1; intros. - simpl. unfold transf_function. - caseEq (analyze f). - intros approxs ANL. - eapply exec_funct_internal; simpl; eauto. - eapply H5. reflexivity. auto. + simpl. unfold transf_function. + econstructor; split. + eapply exec_function_internal; simpl; eauto. + simpl. econstructor; eauto. apply analyze_correct_3; auto. - TransfInstr; auto. - intros. eapply exec_funct_internal; eauto. + (* external function *) - unfold transf_function; simpl. apply exec_funct_external; auto. + simpl. econstructor; split. + eapply exec_function_external; eauto. + constructor; auto. + + (* return *) + inv H3. inv H1. + econstructor; split. + eapply exec_return; eauto. + econstructor; eauto. +Qed. + +Lemma transf_initial_states: + forall st1, initial_state prog st1 -> + exists st2, initial_state tprog st2 /\ match_states st1 st2. +Proof. + intros. inversion H. + exploit function_ptr_translated; eauto. intro FIND. + exists (Callstate nil (transf_fundef f) nil (Genv.init_mem tprog)); split. + econstructor; eauto. + replace (prog_main tprog) with (prog_main prog). + rewrite symbols_preserved. eauto. + reflexivity. + rewrite <- H2. apply sig_function_translated. + replace (Genv.init_mem tprog) with (Genv.init_mem prog). + constructor. constructor. auto. + symmetry. unfold tprog, transf_program. apply Genv.init_mem_transf. +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 H4. constructor. Qed. (** The preservation of the observable behavior of the program then - follows. *) + follows, using the generic preservation theorem + [Smallstep.simulation_step_preservation]. *) Theorem transf_program_correct: - forall (t: trace) (r: val), - exec_program prog t r -> exec_program tprog t r. + forall (beh: program_behavior), + exec_program prog beh -> exec_program tprog beh. Proof. - intros t r [b [f [m [SYMB [FIND [SIG EXEC]]]]]]. - red. exists b. exists (transf_fundef f). exists m. - split. change (prog_main tprog) with (prog_main prog). - rewrite symbols_preserved. auto. - split. apply function_ptr_translated; auto. - split. generalize (sig_translated f). congruence. - apply transf_funct_correct. - unfold tprog, transf_program. rewrite Genv.init_mem_transf. - exact EXEC. + unfold exec_program; intros. + eapply simulation_step_preservation; eauto. + eexact transf_initial_states. + eexact transf_final_states. + exact transf_step_correct. Qed. End PRESERVATION. diff --git a/backend/Conventions.v b/backend/Conventions.v index d621e7c0..9d005b34 100644 --- a/backend/Conventions.v +++ b/backend/Conventions.v @@ -247,6 +247,31 @@ Proof. apply temporaries_not_acceptable. auto. Qed. +Lemma loc_acceptable_noteq_diff: + forall l1 l2, + loc_acceptable l1 -> l1 <> l2 -> Loc.diff l1 l2. +Proof. + unfold loc_acceptable, Loc.diff; destruct l1; destruct l2; + try (destruct s); try (destruct s0); intros; auto; try congruence. + case (zeq z z0); intro. + compare t t0; intro. + subst z0; subst t0; tauto. + tauto. tauto. + contradiction. contradiction. +Qed. + +Lemma loc_acceptable_notin_notin: + forall r ll, + loc_acceptable r -> + ~(In r ll) -> Loc.notin r ll. +Proof. + induction ll; simpl; intros. + auto. + split. apply loc_acceptable_noteq_diff. assumption. + apply sym_not_equal. tauto. + apply IHll. assumption. tauto. +Qed. + (** * Function calling conventions *) (** The functions in this section determine the locations (machine registers @@ -292,9 +317,20 @@ Proof. reflexivity. Qed. -(** The result location is a caller-save register. *) +(** The result location is acceptable. *) Lemma loc_result_acceptable: + forall sig, loc_acceptable (R (loc_result sig)). +Proof. + intros. unfold loc_acceptable. red. + unfold loc_result. destruct (sig_res sig). + destruct t; simpl; NotOrEq. + simpl; NotOrEq. +Qed. + +(** The result location is a caller-save register. *) + +Lemma loc_result_caller_save: forall (s: signature), In (R (loc_result s)) destroyed_at_call. Proof. intros; unfold loc_result. @@ -309,7 +345,7 @@ Lemma loc_result_not_callee_save: forall (s: signature), ~(In (loc_result s) int_callee_save_regs \/ In (loc_result s) float_callee_save_regs). Proof. - intros. generalize (loc_result_acceptable s). + intros. generalize (loc_result_caller_save s). generalize (int_callee_save_not_destroyed (loc_result s)). generalize (float_callee_save_not_destroyed (loc_result s)). tauto. @@ -340,16 +376,18 @@ Fixpoint loc_arguments_rec | nil => nil | Tint :: tys => match iregl with - | nil => S (Outgoing ofs Tint) - | ireg :: _ => R ireg - end :: - loc_arguments_rec tys (list_drop1 iregl) fregl (ofs + 1) + | nil => + S (Outgoing ofs Tint) :: loc_arguments_rec tys nil fregl (ofs + 1) + | ireg :: iregs => + R ireg :: loc_arguments_rec tys iregs fregl ofs + end | Tfloat :: tys => match fregl with - | nil => S (Outgoing ofs Tfloat) - | freg :: _ => R freg - end :: - loc_arguments_rec tys (list_drop2 iregl) (list_drop1 fregl) (ofs + 2) + | nil => + S (Outgoing ofs Tfloat) :: loc_arguments_rec tys iregl nil (ofs + 2) + | freg :: fregs => + R freg :: loc_arguments_rec tys (list_drop2 iregl) fregs ofs + end end. Definition int_param_regs := @@ -361,28 +399,45 @@ Definition float_param_regs := when calling a function with signature [s]. *) Definition loc_arguments (s: signature) : list loc := - loc_arguments_rec s.(sig_args) int_param_regs float_param_regs 6. + loc_arguments_rec s.(sig_args) int_param_regs float_param_regs 14. (** [size_arguments s] returns the number of [Outgoing] slots used to call a function with signature [s]. *) -Fixpoint size_arguments_rec (tyl: list typ) : Z := +Fixpoint size_arguments_rec + (tyl: list typ) (iregl: list mreg) (fregl: list mreg) + (ofs: Z) {struct tyl} : Z := match tyl with - | nil => 6 - | Tint :: tys => 1 + size_arguments_rec tys - | Tfloat :: tys => 2 + size_arguments_rec tys + | nil => ofs + | Tint :: tys => + match iregl with + | nil => size_arguments_rec tys nil fregl (ofs + 1) + | ireg :: iregs => size_arguments_rec tys iregs fregl ofs + end + | Tfloat :: tys => + match fregl with + | nil => size_arguments_rec tys iregl nil (ofs + 2) + | freg :: fregs => size_arguments_rec tys (list_drop2 iregl) fregs ofs + end end. Definition size_arguments (s: signature) : Z := - size_arguments_rec s.(sig_args). + size_arguments_rec s.(sig_args) int_param_regs float_param_regs 14. + +(** A tail-call is possible for a signature if the corresponding + arguments are all passed in registers. *) + +Definition tailcall_possible (s: signature) : Prop := + forall l, In l (loc_arguments s) -> + match l with R _ => True | S _ => False end. (** Argument locations are either non-temporary registers or [Outgoing] - stack slots at offset 6 or more. *) + stack slots at offset 14 or more. *) Definition loc_argument_acceptable (l: loc) : Prop := match l with | R r => ~(In l temporaries) - | S (Outgoing ofs ty) => ofs >= 6 + | S (Outgoing ofs ty) => ofs >= 14 | _ => False end. @@ -397,16 +452,18 @@ Remark loc_arguments_rec_charact: Proof. induction tyl; simpl loc_arguments_rec; intros. elim H. - destruct a; elim H; intros. - destruct iregl; subst l. omega. left; auto with coqlib. - generalize (IHtyl _ _ _ _ H0). - destruct l. intros [A|B]. left; apply list_drop1_incl; auto. tauto. - destruct s; try contradiction. omega. - destruct fregl; subst l. omega. right; auto with coqlib. - generalize (IHtyl _ _ _ _ H0). - destruct l. intros [A|B]. left; apply list_drop2_incl; auto. - right; apply list_drop1_incl; auto. - destruct s; try contradiction. omega. + destruct a. + destruct iregl; elim H; intro. + subst l. omega. + generalize (IHtyl _ _ _ _ H0). destruct l; auto. destruct s; auto. omega. + subst l. auto with coqlib. + generalize (IHtyl _ _ _ _ H0). destruct l; auto. simpl; intuition. + destruct fregl; elim H; intro. + subst l. omega. + generalize (IHtyl _ _ _ _ H0). destruct l; auto. destruct s; auto. omega. + subst l. auto with coqlib. + generalize (IHtyl _ _ _ _ H0). destruct l; auto. + intros [A|B]. left; apply list_drop2_incl; auto. right; auto with coqlib. Qed. Lemma loc_arguments_acceptable: @@ -432,12 +489,15 @@ Remark loc_arguments_rec_notin_reg: Proof. induction tyl; simpl; intros. auto. - destruct a; simpl; split. - destruct iregl. auto. red; intro; subst m. apply H. auto with coqlib. - apply IHtyl. red; intro. apply H. apply list_drop1_incl; auto. auto. - destruct fregl. auto. red; intro; subst m. apply H0. auto with coqlib. - apply IHtyl. red; intro. apply H. apply list_drop2_incl; auto. - red; intro. apply H0. apply list_drop1_incl; auto. + destruct a. + destruct iregl; simpl. auto. + simpl in H. split. apply sym_not_equal. tauto. + apply IHtyl. tauto. tauto. + destruct fregl; simpl. auto. + simpl in H0. split. apply sym_not_equal. tauto. + apply IHtyl. + red; intro. apply H. apply list_drop2_incl. auto. + tauto. Qed. Remark loc_arguments_rec_notin_local: @@ -446,11 +506,9 @@ Remark loc_arguments_rec_notin_local: Proof. induction tyl; simpl; intros. auto. - destruct a; simpl; split. - destruct iregl. auto. auto. - apply IHtyl. - destruct fregl. auto. auto. - apply IHtyl. + destruct a. + destruct iregl; simpl; auto. + destruct fregl; simpl; auto. Qed. Remark loc_arguments_rec_notin_outgoing: @@ -460,11 +518,13 @@ Remark loc_arguments_rec_notin_outgoing: Proof. induction tyl; simpl; intros. auto. - destruct a; simpl; split. - destruct iregl. omega. auto. - apply IHtyl. omega. - destruct fregl. omega. auto. - apply IHtyl. omega. + destruct a. + destruct iregl; simpl. + split. omega. eapply IHtyl. omega. + auto. + destruct fregl; simpl. + split. omega. eapply IHtyl. omega. + auto. Qed. Lemma loc_arguments_norepet: @@ -477,21 +537,21 @@ Proof. Loc.norepet (loc_arguments_rec tyl iregl fregl ofs)). induction tyl; simpl; intros. constructor. - destruct a; constructor. - destruct iregl. - apply loc_arguments_rec_notin_outgoing. simpl; omega. - apply loc_arguments_rec_notin_reg. simpl. inversion H. auto. + destruct a. + destruct iregl; constructor. + apply loc_arguments_rec_notin_outgoing. simpl; omega. auto. + apply loc_arguments_rec_notin_reg. inversion H. auto. apply list_disjoint_notin with (m :: iregl); auto with coqlib. - apply IHtyl. apply list_drop1_norepet; auto. auto. - red; intros. apply H1. apply list_drop1_incl; auto. auto. - destruct fregl. - apply loc_arguments_rec_notin_outgoing. simpl; omega. - apply loc_arguments_rec_notin_reg. simpl. + apply IHtyl. inv H; auto. auto. + eapply list_disjoint_cons_left; eauto. + destruct fregl; constructor. + apply loc_arguments_rec_notin_outgoing. simpl; omega. auto. + apply loc_arguments_rec_notin_reg. red; intro. apply (H1 m m). apply list_drop2_incl; auto. - auto with coqlib. auto. - simpl. inversion H0. auto. - apply IHtyl. apply list_drop2_norepet; auto. apply list_drop1_norepet; auto. - red; intros. apply H1. apply list_drop2_incl; auto. apply list_drop1_incl; auto. + auto with coqlib. auto. inv H0; auto. + apply IHtyl. apply list_drop2_norepet; auto. + inv H0; auto. + red; intros. apply H1. apply list_drop2_incl; auto. auto with coqlib. intro. unfold loc_arguments. apply H. unfold int_param_regs. NoRepet. @@ -501,32 +561,42 @@ Qed. (** The offsets of [Outgoing] arguments are below [size_arguments s]. *) +Remark size_arguments_rec_above: + forall tyl iregl fregl ofs0, + ofs0 <= size_arguments_rec tyl iregl fregl ofs0. +Proof. + induction tyl; simpl; intros. + omega. + destruct a. + destruct iregl. apply Zle_trans with (ofs0 + 1); auto; omega. auto. + destruct fregl. apply Zle_trans with (ofs0 + 2); auto; omega. auto. +Qed. + +Lemma size_arguments_above: + forall s, size_arguments s >= 14. +Proof. + intros; unfold size_arguments. apply Zle_ge. + apply size_arguments_rec_above. +Qed. + Lemma loc_arguments_bounded: forall (s: signature) (ofs: Z) (ty: typ), In (S (Outgoing ofs ty)) (loc_arguments s) -> ofs + typesize ty <= size_arguments s. Proof. intros. - assert (forall tyl, size_arguments_rec tyl >= 6). - induction tyl; unfold size_arguments_rec; fold size_arguments_rec; intros. - omega. - destruct a; omega. assert (forall tyl iregl fregl ofs0, In (S (Outgoing ofs ty)) (loc_arguments_rec tyl iregl fregl ofs0) -> - ofs + typesize ty <= size_arguments_rec tyl + ofs0 - 6). - induction tyl; simpl loc_arguments_rec; intros. - elim H1. - unfold size_arguments_rec; fold size_arguments_rec. - destruct a. - elim H1; intro. destruct iregl; simplify_eq H2; intros. - subst ty; subst ofs. generalize (H0 tyl). simpl typesize. omega. - generalize (IHtyl _ _ _ H2). omega. - elim H1; intro. destruct fregl; simplify_eq H2; intros. - subst ty; subst ofs. generalize (H0 tyl). simpl typesize. omega. - generalize (IHtyl _ _ _ H2). omega. - replace (size_arguments s) with (size_arguments s + 6 - 6). - unfold size_arguments. eapply H1. unfold loc_arguments in H. eauto. - omega. + ofs + typesize ty <= size_arguments_rec tyl iregl fregl ofs0). + induction tyl; simpl; intros. + elim H0. + destruct a. destruct iregl; elim H0; intro. + inv H1. simpl. apply size_arguments_rec_above. auto. + discriminate. auto. + destruct fregl; elim H0; intro. + inv H1. simpl. apply size_arguments_rec_above. auto. + discriminate. auto. + unfold size_arguments. eapply H0. unfold loc_arguments in H. eauto. Qed. (** Temporary registers do not overlap with argument locations. *) @@ -543,6 +613,18 @@ Proof. Qed. Hint Resolve loc_arguments_not_temporaries: locs. +(** Argument registers are caller-save. *) + +Lemma arguments_caller_save: + forall sig r, + In (R r) (loc_arguments sig) -> In (R r) destroyed_at_call. +Proof. + unfold loc_arguments; intros. + elim (loc_arguments_rec_charact _ _ _ _ _ H); simpl. + ElimOrEq; intuition. + ElimOrEq; intuition. +Qed. + (** Callee-save registers do not overlap with argument locations. *) Lemma arguments_not_preserved: @@ -571,7 +653,9 @@ Proof. List.length (loc_arguments_rec tyl iregl fregl ofs) = List.length tyl). induction tyl; simpl; intros. auto. - destruct a; simpl; decEq; auto. + destruct a. + destruct iregl; simpl; decEq; auto. + destruct fregl; simpl; decEq; auto. intros. unfold loc_arguments. auto. Qed. @@ -586,14 +670,10 @@ Proof. List.map Loc.type (loc_arguments_rec tyl iregl fregl ofs) = tyl). induction tyl; simpl; intros. auto. - destruct a; simpl; apply (f_equal2 (@cons typ)). - destruct iregl. reflexivity. simpl. apply H. auto with coqlib. - apply IHtyl. - intros. apply H. apply list_drop1_incl. auto. auto. - destruct fregl. reflexivity. simpl. apply H0. auto with coqlib. - apply IHtyl. - intros. apply H. apply list_drop2_incl. auto. - intros. apply H0. apply list_drop1_incl. auto. + destruct a; [destruct iregl|destruct fregl]; simpl; + f_equal; eauto with coqlib. + apply IHtyl. intros. apply H. apply list_drop2_incl; auto. + eauto with coqlib. intros. unfold loc_arguments. apply H. intro; simpl. ElimOrEq; reflexivity. @@ -618,6 +698,30 @@ Proof. destruct s; try tauto. destruct s0; tauto. Qed. +(** A tailcall is possible if and only if the size of arguments is 14. *) + +Lemma tailcall_possible_size: + forall s, tailcall_possible s <-> size_arguments s = 14. +Proof. + intro; split; intro. + assert (forall tyl iregl fregl ofs, + (forall l, In l (loc_arguments_rec tyl iregl fregl ofs) -> + match l with R _ => True | S _ => False end) -> + size_arguments_rec tyl iregl fregl ofs = ofs). + induction tyl; simpl; intros. + auto. + destruct a. destruct iregl. elim (H0 _ (in_eq _ _)). + apply IHtyl; intros. apply H0. auto with coqlib. + destruct fregl. elim (H0 _ (in_eq _ _)). + apply IHtyl; intros. apply H0. auto with coqlib. + unfold size_arguments. apply H0. assumption. + red; intros. + generalize (loc_arguments_acceptable s l H0). + destruct l; simpl. auto. destruct s0; intro; auto. + generalize (loc_arguments_bounded _ _ _ H0). + generalize (typesize_pos t). omega. +Qed. + (** ** Location of function parameters *) (** A function finds the values of its parameter in the same locations @@ -645,6 +749,13 @@ Proof. destruct s; reflexivity. Qed. +Lemma loc_parameters_length: + forall sg, List.length (loc_parameters sg) = List.length sg.(sig_args). +Proof. + intros. unfold loc_parameters. rewrite list_length_map. + apply loc_arguments_length. +Qed. + Lemma loc_parameters_not_temporaries: forall sig, Loc.disjoint (loc_parameters sig) temporaries. Proof. @@ -676,7 +787,7 @@ Proof. intros; simpl. tauto. Qed. -(** ** Location of argument and result of dynamic allocation *) +(** ** Location of argument and result for dynamic memory allocation *) Definition loc_alloc_argument := R3. Definition loc_alloc_result := R3. diff --git a/backend/LTL.v b/backend/LTL.v index 0dc97020..edb8ecc5 100644 --- a/backend/LTL.v +++ b/backend/LTL.v @@ -3,7 +3,6 @@ LTL (``Location Transfer Language'') is the target language for register allocation and the source language for linearization. *) -Require Import Relations. Require Import Coqlib. Require Import Maps. Require Import AST. @@ -12,54 +11,38 @@ Require Import Values. Require Import Events. Require Import Mem. Require Import Globalenvs. +Require Import Smallstep. Require Import Op. Require Import Locations. -Require Conventions. +Require Import Conventions. (** * Abstract syntax *) -(** LTL is close to RTL, but uses locations instead of pseudo-registers, - and basic blocks instead of single instructions as nodes of its - control-flow graph. *) +(** LTL is close to RTL, but uses locations instead of pseudo-registers. *) Definition node := positive. -(** A basic block is a sequence of instructions terminated by - a [Bgoto], [Bcond] or [Breturn] instruction. (This invariant - is enforced by the following inductive type definition.) - The instructions behave like the similarly-named instructions - of RTL. They take machine registers (type [mreg]) as arguments - and results. Two new instructions are added: [Bgetstack] - and [Bsetstack], which are ``move'' instructions between - a machine register and a stack slot. *) - -Inductive block: Set := - | Bgetstack: slot -> mreg -> block -> block - | Bsetstack: mreg -> slot -> block -> block - | Bop: operation -> list mreg -> mreg -> block -> block - | Bload: memory_chunk -> addressing -> list mreg -> mreg -> block -> block - | Bstore: memory_chunk -> addressing -> list mreg -> mreg -> block -> block - | Bcall: signature -> mreg + ident -> block -> block - | Balloc: block -> block - | Bgoto: node -> block - | Bcond: condition -> list mreg -> node -> node -> block - | Breturn: block. - -Definition code: Set := PTree.t block. - -(** Unlike in RTL, parameter passing (passing values of the arguments - to a function call to the parameters of the called function) is done - via conventional locations (machine registers and stack slots). - Consequently, the [Bcall] instruction has no list of argument registers, - and function descriptions have no list of parameter registers. *) +Inductive instruction: Set := + | Lnop: node -> instruction + | Lop: operation -> list loc -> loc -> node -> instruction + | Lload: memory_chunk -> addressing -> list loc -> loc -> node -> instruction + | Lstore: memory_chunk -> addressing -> list loc -> loc -> node -> instruction + | Lcall: signature -> loc + ident -> list loc -> loc -> node -> instruction + | Ltailcall: signature -> loc + ident -> list loc -> instruction + | Lalloc: loc -> loc -> node -> instruction + | Lcond: condition -> list loc -> node -> node -> instruction + | Lreturn: option loc -> instruction. + +Definition code: Set := PTree.t instruction. Record function: Set := mkfunction { fn_sig: signature; + fn_params: list loc; fn_stacksize: Z; fn_code: code; fn_entrypoint: node; - fn_code_wf: - forall (pc: node), Plt pc (Psucc fn_entrypoint) \/ fn_code!pc = None + fn_nextpc: node; + fn_code_wf: forall (pc: node), Plt pc fn_nextpc \/ fn_code!pc = None }. Definition fundef := AST.fundef function. @@ -107,7 +90,7 @@ Definition call_regs (caller: locset) : locset := set [callee] of the callee at the return instruction. - Callee-save machine registers have the same values as in the caller before the call. -- Caller-save and temporary machine registers have the same values +- Caller-save machine registers have the same values as in the callee at the return point. - Stack slots have the same values as in the caller before the call. *) @@ -125,11 +108,72 @@ Definition return_regs (caller callee: locset) : locset := | S s => caller (S s) end. +(** [parmov srcs dsts ls] performs the parallel assignment + of locations [dsts] to the values of the corresponding locations + [srcs]. *) + +Fixpoint parmov (srcs dsts: list loc) (ls: locset) {struct srcs} : locset := + match srcs, dsts with + | s1 :: sl, d1 :: dl => Locmap.set d1 (ls s1) (parmov sl dl ls) + | _, _ => ls + end. + +Definition set_result_reg (s: signature) (or: option loc) (ls: locset) := + match or with + | Some r => Locmap.set (R (loc_result s)) (ls r) ls + | None => ls + end. + +(** The components of an LTL execution state are: + +- [State cs f sp pc ls m]: [f] is the function currently executing. + [sp] is the stack pointer (as in RTL). [pc] is the current + program point (CFG node) within the code of [f]. + [ls] maps locations to their current values. [m] is the current + memory state. +- [Callstate cs f ls m]: + [f] is the function definition that we are calling. + [ls] is the values of locations just before the call. + [m] is the current memory state. +- [Returnstate cs sig ls m]: + [sig] is the signature of the function that just returned. + [ls] is the values of locations just before the return. + [m] is the current memory state. + +[cs] is a list of stack frames [Stackframe res f sp ls pc], +where [res] is the location that will receive the result of the call, +[f] is the calling function, [sp] its stack pointer, +[ls] the values of locations just before the call, +and [pc] the program point within [f] of the successor of the +[Lcall] instruction. *) + +Inductive stackframe : Set := + | Stackframe: + forall (res: loc) (f: function) (sp: val) (ls: locset) (pc: node), + stackframe. + +Inductive state : Set := + | State: + forall (stack: list stackframe) (f: function) (sp: val) + (pc: node) (ls: locset) (m: mem), state + | Callstate: + forall (stack: list stackframe) (f: fundef) (ls: locset) (m: mem), + state + | Returnstate: + forall (stack: list stackframe) (sig: signature) (ls: locset) (m: mem), + state. + +Definition parent_locset (stack: list stackframe) : locset := + match stack with + | nil => Locmap.init Vundef + | Stackframe res f sp ls pc :: stack' => ls + end. + Variable ge: genv. -Definition find_function (ros: mreg + ident) (rs: locset) : option fundef := - match ros with - | inl r => Genv.find_funct ge (rs (R r)) +Definition find_function (los: loc + ident) (rs: locset) : option fundef := + match los with + | inl l => Genv.find_funct ge (rs l) | inr symb => match Genv.find_symbol ge symb with | None => None @@ -137,158 +181,140 @@ Definition find_function (ros: mreg + ident) (rs: locset) : option fundef := end end. -Definition reglist (rl: list mreg) (rs: locset) : list val := - List.map (fun r => rs (R r)) rl. - -(** The dynamic semantics of LTL, like that of RTL, is a combination - of small-step transition semantics and big-step semantics. - Function calls are treated in big-step style so that they appear - as a single transition in the caller function. Other instructions - are treated in purely small-step style, as a single transition. - - The introduction of basic blocks increases the number of inductive - predicates needed to express the semantics: -- [exec_instr ge sp b ls m b' ls' m'] is the execution of the first - instruction of block [b]. [b'] is the remainder of the block. -- [exec_instrs ge sp b ls m b' ls' m'] is similar, but executes - zero, one or several instructions at the beginning of block [b]. -- [exec_block ge sp b ls m out ls' m'] executes all instructions - of block [b]. The outcome [out] is either [Cont s], indicating - that the block terminates by branching to block labeled [s], - or [Return], indicating that the block terminates by returning - from the current function. -- [exec_blocks ge code sp pc ls m out ls' m'] executes a sequence - of zero, one or several blocks, starting at the block labeled [pc]. - [code] is the control-flow graph for the current function. - The outcome [out] indicates how the last block in this sequence - terminates: by branching to another block or by returning from the - function. -- [exec_function ge f ls m ls' m'] executes the body of function [f], - from its entry point to the first [Lreturn] instruction encountered. - - In all these predicates, [ls] and [ls'] are the location sets - (values of locations) at the beginning and end of the transitions, - respectively. +(** The main difference between the LTL transition relation + and the RTL transition relation is the handling of function calls. + In RTL, arguments and results to calls are transmitted via + [vargs] and [vres] components of [Callstate] and [Returnstate], + respectively. The semantics takes care of transferring these values + between the pseudo-registers of the caller and of the callee. + + In lower-level intermediate languages (e.g [Linear], [Mach], [PPC]), + arguments and results are transmitted implicitly: the generated + code for the caller arranges for arguments to be left in conventional + registers and stack locations, as determined by the calling conventions, + where the function being called will find them. Similarly, + conventional registers will be used to pass the result value back + to the caller. + + In LTL, we take an hybrid view of argument and result passing. + The LTL code does not contain (yet) instructions for moving + arguments and results to the conventional registers. However, + the dynamic semantics "goes through the motions" of such code: +- The [exec_Lcall] transition from [State] to [Callstate] + leaves the values of arguments in the conventional locations + given by [loc_arguments]. +- The [exec_function_internal] transition from [Callstate] to [State] + changes the view of stack slots ([Outgoing] slots slide to + [Incoming] slots as per [call_regs]), then recovers the + values of parameters from the conventional locations given by + [loc_parameters]. +- The [exec_Lreturn] transition from [State] to [Returnstate] + moves the result value to the conventional location [loc_result], + then restores the values of callee-save locations from + the location state of the caller, using [return_regs]. +- The [exec_return] transition from [Returnstate] to [State] + reads the result value from the conventional location [loc_result], + then stores it in the result location for the [Lcall] instruction. + +This complicated protocol will make it much easier to prove +the correctness of the [Stacking] pass later, which inserts actual +code that performs all the shuffling of arguments and results +described above. *) -Inductive outcome: Set := - | Cont: node -> outcome - | Return: outcome. - -Inductive exec_instr: val -> - block -> locset -> mem -> trace -> - block -> locset -> mem -> Prop := - | exec_Bgetstack: - forall sp sl r b rs m, - exec_instr sp (Bgetstack sl r b) rs m - E0 b (Locmap.set (R r) (rs (S sl)) rs) m - | exec_Bsetstack: - forall sp r sl b rs m, - exec_instr sp (Bsetstack r sl b) rs m - E0 b (Locmap.set (S sl) (rs (R r)) rs) m - | exec_Bop: - forall sp op args res b rs m v, - eval_operation ge sp op (reglist args rs) = Some v -> - exec_instr sp (Bop op args res b) rs m - E0 b (Locmap.set (R res) v rs) m - | exec_Bload: - forall sp chunk addr args dst b rs m a v, - eval_addressing ge sp addr (reglist args rs) = Some a -> - loadv chunk m a = Some v -> - exec_instr sp (Bload chunk addr args dst b) rs m - E0 b (Locmap.set (R dst) v rs) m - | exec_Bstore: - forall sp chunk addr args src b rs m m' a, - eval_addressing ge sp addr (reglist args rs) = Some a -> - storev chunk m a (rs (R src)) = Some m' -> - exec_instr sp (Bstore chunk addr args src b) rs m - E0 b rs m' - | exec_Bcall: - forall sp sig ros b rs m t f rs' m', - find_function ros rs = Some f -> - sig = funsig f -> - exec_function f rs m t rs' m' -> - exec_instr sp (Bcall sig ros b) rs m - t b (return_regs rs rs') m' - | exec_Balloc: - forall sp b rs m sz m' blk, - rs (R Conventions.loc_alloc_argument) = Vint sz -> - Mem.alloc m 0 (Int.signed sz) = (m', blk) -> - exec_instr sp (Balloc b) rs m E0 b - (Locmap.set (R Conventions.loc_alloc_result) - (Vptr blk Int.zero) rs) m' - -with exec_instrs: val -> - block -> locset -> mem -> trace -> - block -> locset -> mem -> Prop := - | exec_refl: - forall sp b rs m, - exec_instrs sp b rs m E0 b rs m - | exec_one: - forall sp b1 rs1 m1 t b2 rs2 m2, - exec_instr sp b1 rs1 m1 t b2 rs2 m2 -> - exec_instrs sp b1 rs1 m1 t b2 rs2 m2 - | exec_trans: - forall sp b1 rs1 m1 t t1 b2 rs2 m2 t2 b3 rs3 m3, - exec_instrs sp b1 rs1 m1 t1 b2 rs2 m2 -> - exec_instrs sp b2 rs2 m2 t2 b3 rs3 m3 -> - t = t1 ** t2 -> - exec_instrs sp b1 rs1 m1 t b3 rs3 m3 - -with exec_block: val -> - block -> locset -> mem -> trace -> - outcome -> locset -> mem -> Prop := - | exec_Bgoto: - forall sp b rs m t s rs' m', - exec_instrs sp b rs m t (Bgoto s) rs' m' -> - exec_block sp b rs m t (Cont s) rs' m' - | exec_Bcond_true: - forall sp b rs m t cond args ifso ifnot rs' m', - exec_instrs sp b rs m t (Bcond cond args ifso ifnot) rs' m' -> - eval_condition cond (reglist args rs') = Some true -> - exec_block sp b rs m t (Cont ifso) rs' m' - | exec_Bcond_false: - forall sp b rs m t cond args ifso ifnot rs' m', - exec_instrs sp b rs m t (Bcond cond args ifso ifnot) rs' m' -> - eval_condition cond (reglist args rs') = Some false -> - exec_block sp b rs m t (Cont ifnot) rs' m' - | exec_Breturn: - forall sp b rs m t rs' m', - exec_instrs sp b rs m t Breturn rs' m' -> - exec_block sp b rs m t Return rs' m' - -with exec_blocks: code -> val -> - node -> locset -> mem -> trace -> - outcome -> locset -> mem -> Prop := - | exec_blocks_refl: - forall c sp pc rs m, - exec_blocks c sp pc rs m E0 (Cont pc) rs m - | exec_blocks_one: - forall c sp pc b m rs t out rs' m', - c!pc = Some b -> - exec_block sp b rs m t out rs' m' -> - exec_blocks c sp pc rs m t out rs' m' - | exec_blocks_trans: - forall c sp pc1 rs1 m1 t t1 pc2 rs2 m2 t2 out rs3 m3, - exec_blocks c sp pc1 rs1 m1 t1 (Cont pc2) rs2 m2 -> - exec_blocks c sp pc2 rs2 m2 t2 out rs3 m3 -> - t = t1 ** t2 -> - exec_blocks c sp pc1 rs1 m1 t out rs3 m3 - -with exec_function: fundef -> locset -> mem -> trace -> - locset -> mem -> Prop := - | exec_funct_internal: - forall f rs m m1 stk t rs2 m2, - alloc m 0 f.(fn_stacksize) = (m1, stk) -> - exec_blocks f.(fn_code) (Vptr stk Int.zero) - f.(fn_entrypoint) (call_regs rs) m1 t Return rs2 m2 -> - exec_function (Internal f) rs m t rs2 (free m2 stk) - | exec_funct_external: - forall ef args res rs1 rs2 m t, +Inductive step: state -> trace -> state -> Prop := + | exec_Lnop: + forall s f sp pc rs m pc', + (fn_code f)!pc = Some(Lnop pc') -> + step (State s f sp pc rs m) + E0 (State s f sp pc' rs m) + | exec_Lop: + forall s f sp pc rs m op args res pc' v, + (fn_code f)!pc = Some(Lop op args res pc') -> + eval_operation ge sp op (map rs args) m = Some v -> + step (State s f sp pc rs m) + E0 (State s f sp pc' (Locmap.set res v rs) m) + | exec_Lload: + forall s f sp pc rs m chunk addr args dst pc' a v, + (fn_code f)!pc = Some(Lload chunk addr args dst pc') -> + eval_addressing ge sp addr (map rs args) = Some a -> + Mem.loadv chunk m a = Some v -> + step (State s f sp pc rs m) + E0 (State s f sp pc' (Locmap.set dst v rs) m) + | exec_Lstore: + forall s f sp pc rs m chunk addr args src pc' a m', + (fn_code f)!pc = Some(Lstore chunk addr args src pc') -> + eval_addressing ge sp addr (map rs args) = Some a -> + Mem.storev chunk m a (rs src) = Some m' -> + step (State s f sp pc rs m) + E0 (State s f sp pc' rs m') + | exec_Lcall: + forall s f sp pc rs m sig ros args res pc' f', + (fn_code f)!pc = Some(Lcall sig ros args res pc') -> + find_function ros rs = Some f' -> + funsig f' = sig -> + let rs1 := parmov args (loc_arguments sig) rs in + step (State s f sp pc rs m) + E0 (Callstate (Stackframe res f sp rs1 pc' :: s) f' rs1 m) + | exec_Ltailcall: + forall s f stk pc rs m sig ros args f', + (fn_code f)!pc = Some(Ltailcall sig ros args) -> + find_function ros rs = Some f' -> + funsig f' = sig -> + let rs1 := parmov args (loc_arguments sig) rs in + let rs2 := return_regs (parent_locset s) rs1 in + step (State s f (Vptr stk Int.zero) pc rs m) + E0 (Callstate s f' rs2 (Mem.free m stk)) + | exec_Lalloc: + forall s f sp pc rs m pc' arg res sz m' b, + (fn_code f)!pc = Some(Lalloc arg res pc') -> + rs arg = Vint sz -> + Mem.alloc m 0 (Int.signed sz) = (m', b) -> + let rs1 := Locmap.set (R loc_alloc_argument) (rs arg) rs in + let rs2 := Locmap.set (R loc_alloc_result) (Vptr b Int.zero) rs1 in + let rs3 := Locmap.set res (rs2 (R loc_alloc_result)) rs2 in + step (State s f sp pc rs m) + E0 (State s f sp pc' rs3 m') + | exec_Lcond_true: + forall s f sp pc rs m cond args ifso ifnot, + (fn_code f)!pc = Some(Lcond cond args ifso ifnot) -> + eval_condition cond (map rs args) m = Some true -> + step (State s f sp pc rs m) + E0 (State s f sp ifso rs m) + | exec_Lcond_false: + forall s f sp pc rs m cond args ifso ifnot, + (fn_code f)!pc = Some(Lcond cond args ifso ifnot) -> + eval_condition cond (map rs args) m = Some false -> + step (State s f sp pc rs m) + E0 (State s f sp ifnot rs m) + | exec_Lreturn: + forall s f stk pc rs m or, + (fn_code f)!pc = Some(Lreturn or) -> + let rs1 := set_result_reg f.(fn_sig) or rs in + let rs2 := return_regs (parent_locset s) rs1 in + step (State s f (Vptr stk Int.zero) pc rs m) + E0 (Returnstate s f.(fn_sig) rs2 (Mem.free m stk)) + | exec_function_internal: + forall s f rs m m' stk, + Mem.alloc m 0 f.(fn_stacksize) = (m', stk) -> + let rs1 := call_regs rs in + let rs2 := parmov (loc_parameters f.(fn_sig)) f.(fn_params) rs1 in + step (Callstate s (Internal f) rs m) + E0 (State s f (Vptr stk Int.zero) f.(fn_entrypoint) rs2 m') + | exec_function_external: + forall s ef t res rs m, + let args := map rs (Conventions.loc_arguments ef.(ef_sig)) in event_match ef args t res -> - args = List.map rs1 (Conventions.loc_arguments ef.(ef_sig)) -> - rs2 = Locmap.set (R (Conventions.loc_result ef.(ef_sig))) res rs1 -> - exec_function (External ef) rs1 m t rs2 m. + let rs1 := + Locmap.set (R (Conventions.loc_result ef.(ef_sig))) res rs in + step (Callstate s (External ef) rs m) + t (Returnstate s ef.(ef_sig) rs1 m) + | exec_return: + forall res f sp rs0 pc s sig rs m, + let rs1 := Locmap.set res (rs (R (loc_result sig))) rs in + step (Returnstate (Stackframe res f sp rs0 pc :: s) + sig rs m) + E0 (State s f sp pc rs1 m). End RELSEM. @@ -297,87 +323,41 @@ End RELSEM. main function, to be found in the machine register dictated by the calling conventions. *) -Definition exec_program (p: program) (t: trace) (r: val) : Prop := - let ge := Genv.globalenv p in - let m0 := Genv.init_mem p in - exists b, exists f, exists rs, exists m, - Genv.find_symbol ge p.(prog_main) = Some b /\ - Genv.find_funct_ptr ge b = Some f /\ - funsig f = mksignature nil (Some Tint) /\ - exec_function ge f (Locmap.init Vundef) m0 t rs m /\ - rs (R (Conventions.loc_result (funsig f))) = r. - -(** We remark that the [exec_blocks] relation is stable if - the control-flow graph is extended by adding new basic blocks - at previously unused graph nodes. *) +Inductive initial_state (p: program): state -> Prop := + | initial_state_intro: forall b f, + let ge := Genv.globalenv p in + let m0 := Genv.init_mem p in + Genv.find_symbol ge p.(prog_main) = Some b -> + Genv.find_funct_ptr ge b = Some f -> + funsig f = mksignature nil (Some Tint) -> + initial_state p (Callstate nil f (Locmap.init Vundef) m0). -Section EXEC_BLOCKS_EXTENDS. +Inductive final_state: state -> int -> Prop := + | final_state_intro: forall sig rs m r, + rs (R (loc_result sig)) = Vint r -> + final_state (Returnstate nil sig rs m) r. -Variable ge: genv. -Variable c1 c2: code. -Hypothesis EXT: forall pc, c2!pc = c1!pc \/ c1!pc = None. - -Lemma exec_blocks_extends: - forall sp pc1 rs1 m1 t out rs2 m2, - exec_blocks ge c1 sp pc1 rs1 m1 t out rs2 m2 -> - exec_blocks ge c2 sp pc1 rs1 m1 t out rs2 m2. -Proof. - induction 1. - apply exec_blocks_refl. - apply exec_blocks_one with b. - elim (EXT pc); intro; congruence. assumption. - eapply exec_blocks_trans; eauto. -Qed. - -End EXEC_BLOCKS_EXTENDS. +Definition exec_program (p: program) (beh: program_behavior) : Prop := + program_behaves step (initial_state p) final_state (Genv.globalenv p) beh. (** * Operations over LTL *) -(** Computation of the possible successors of a basic block. - This is used for dataflow analyses. *) - -Fixpoint successors_aux (b: block) : list node := - match b with - | Bgetstack s r b => successors_aux b - | Bsetstack r s b => successors_aux b - | Bop op args res b => successors_aux b - | Bload chunk addr args dst b => successors_aux b - | Bstore chunk addr args src b => successors_aux b - | Bcall sig ros b => successors_aux b - | Balloc b => successors_aux b - | Bgoto n => n :: nil - | Bcond cond args ifso ifnot => ifso :: ifnot :: nil - | Breturn => nil - end. +(** Computation of the possible successors of an instruction. + This is used in particular for dataflow analyses. *) Definition successors (f: function) (pc: node) : list node := match f.(fn_code)!pc with | None => nil - | Some b => successors_aux b + | Some i => + match i with + | Lnop s => s :: nil + | Lop op args res s => s :: nil + | Lload chunk addr args dst s => s :: nil + | Lstore chunk addr args src s => s :: nil + | Lcall sig ros args res s => s :: nil + | Ltailcall sig ros args => nil + | Lalloc arg res s => s :: nil + | Lcond cond args ifso ifnot => ifso :: ifnot :: nil + | Lreturn optarg => nil + end end. - -Lemma successors_aux_invariant: - forall ge sp b rs m t b' rs' m', - exec_instrs ge sp b rs m t b' rs' m' -> - successors_aux b = successors_aux b'. -Proof. - induction 1; simpl; intros. - reflexivity. - inversion H; reflexivity. - transitivity (successors_aux b2); auto. -Qed. - -Lemma successors_correct: - forall ge f sp pc rs m t pc' rs' m' b, - f.(fn_code)!pc = Some b -> - exec_block ge sp b rs m t (Cont pc') rs' m' -> - In pc' (successors f pc). -Proof. - intros. unfold successors. rewrite H. inversion H0. - rewrite (successors_aux_invariant _ _ _ _ _ _ _ _ _ H7); simpl. - tauto. - rewrite (successors_aux_invariant _ _ _ _ _ _ _ _ _ H2); simpl. - tauto. - rewrite (successors_aux_invariant _ _ _ _ _ _ _ _ _ H2); simpl. - tauto. -Qed. diff --git a/backend/LTLin.v b/backend/LTLin.v new file mode 100644 index 00000000..368c13cd --- /dev/null +++ b/backend/LTLin.v @@ -0,0 +1,255 @@ +(** The LTLin intermediate language: abstract syntax and semantcs *) + +(** The LTLin language is a variant of LTL where control-flow is not + expressed as a graph of basic blocks, but as a linear list of + instructions with explicit labels and ``goto'' instructions. *) + +Require Import Coqlib. +Require Import Maps. +Require Import AST. +Require Import Integers. +Require Import Values. +Require Import Mem. +Require Import Events. +Require Import Globalenvs. +Require Import Smallstep. +Require Import Op. +Require Import Locations. +Require Import LTL. +Require Import Conventions. + +(** * Abstract syntax *) + +Definition label := positive. + +(** LTLin instructions are similar to those of LTL. + Except the last three, these instructions continue in sequence + with the next instruction in the linear list of instructions. + Unconditional branches [Lgoto] and conditional branches [Lcond] + transfer control to the given code label. Labels are explicitly + inserted in the instruction list as pseudo-instructions [Llabel]. *) + +Inductive instruction: Set := + | Lop: operation -> list loc -> loc -> instruction + | Lload: memory_chunk -> addressing -> list loc -> loc -> instruction + | Lstore: memory_chunk -> addressing -> list loc -> loc -> instruction + | Lcall: signature -> loc + ident -> list loc -> loc -> instruction + | Ltailcall: signature -> loc + ident -> list loc -> instruction + | Lalloc: loc -> loc -> instruction + | Llabel: label -> instruction + | Lgoto: label -> instruction + | Lcond: condition -> list loc -> label -> instruction + | Lreturn: option loc -> instruction. + +Definition code: Set := list instruction. + +Record function: Set := mkfunction { + fn_sig: signature; + fn_params: list loc; + fn_stacksize: Z; + fn_code: code +}. + +Definition fundef := AST.fundef function. + +Definition program := AST.program fundef unit. + +Definition funsig (fd: fundef) := + match fd with + | Internal f => f.(fn_sig) + | External ef => ef.(ef_sig) + end. + +Definition genv := Genv.t fundef. +Definition locset := Locmap.t. + +(** * Operational semantics *) + +(** Looking up labels in the instruction list. *) + +Definition is_label (lbl: label) (instr: instruction) : bool := + match instr with + | Llabel lbl' => if peq lbl lbl' then true else false + | _ => false + end. + +Lemma is_label_correct: + forall lbl instr, + if is_label lbl instr then instr = Llabel lbl else instr <> Llabel lbl. +Proof. + intros. destruct instr; simpl; try discriminate. + case (peq lbl l); intro; congruence. +Qed. + +(** [find_label lbl c] returns a list of instruction, suffix of the + code [c], that immediately follows the [Llabel lbl] pseudo-instruction. + If the label [lbl] is multiply-defined, the first occurrence is + retained. If the label [lbl] is not defined, [None] is returned. *) + +Fixpoint find_label (lbl: label) (c: code) {struct c} : option code := + match c with + | nil => None + | i1 :: il => if is_label lbl i1 then Some il else find_label lbl il + end. + +(** The states of the dynamic semantics are similar to those used + in the LTL semantics (see module [LTL]). The only difference + is that program points [pc] (nodes of the CFG in LTL) become + code sequences [c] (suffixes of the code of the current function). +*) + +Inductive stackframe : Set := + | Stackframe: + forall (res: loc) (f: function) (sp: val) (ls: locset) (c: code), + stackframe. + +Inductive state : Set := + | State: + forall (stack: list stackframe) (f: function) (sp: val) + (c: code) (ls: locset) (m: mem), state + | Callstate: + forall (stack: list stackframe) (f: fundef) (ls: locset) (m: mem), + state + | Returnstate: + forall (stack: list stackframe) (sig: signature) (ls: locset) (m: mem), + state. + +Definition parent_locset (stack: list stackframe) : locset := + match stack with + | nil => Locmap.init Vundef + | Stackframe res f sp ls pc :: stack' => ls + end. + +Section RELSEM. + +Variable ge: genv. + +Definition find_function (ros: loc + ident) (rs: locset) : option fundef := + match ros with + | inl r => Genv.find_funct ge (rs r) + | inr symb => + match Genv.find_symbol ge symb with + | None => None + | Some b => Genv.find_funct_ptr ge b + end + end. + +Inductive step: state -> trace -> state -> Prop := + | exec_Lop: + forall s f sp op args res b rs m v, + eval_operation ge sp op (map rs args) m = Some v -> + step (State s f sp (Lop op args res :: b) rs m) + E0 (State s f sp b (Locmap.set res v rs) m) + | exec_Lload: + forall s f sp chunk addr args dst b rs m a v, + eval_addressing ge sp addr (map rs args) = Some a -> + loadv chunk m a = Some v -> + step (State s f sp (Lload chunk addr args dst :: b) rs m) + E0 (State s f sp b (Locmap.set dst v rs) m) + | exec_Lstore: + forall s f sp chunk addr args src b rs m m' a, + eval_addressing ge sp addr (map rs args) = Some a -> + storev chunk m a (rs src) = Some m' -> + step (State s f sp (Lstore chunk addr args src :: b) rs m) + E0 (State s f sp b rs m') + | exec_Lcall: + forall s f sp sig ros args res b rs m f', + find_function ros rs = Some f' -> + sig = funsig f' -> + let rs1 := parmov args (loc_arguments sig) rs in + step (State s f sp (Lcall sig ros args res :: b) rs m) + E0 (Callstate (Stackframe res f sp rs1 b :: s) f' rs1 m) + | exec_Ltailcall: + forall s f stk sig ros args b rs m f', + find_function ros rs = Some f' -> + sig = funsig f' -> + let rs1 := parmov args (loc_arguments sig) rs in + let rs2 := return_regs (parent_locset s) rs1 in + step (State s f (Vptr stk Int.zero) (Ltailcall sig ros args :: b) rs m) + E0 (Callstate s f' rs2 (Mem.free m stk)) + | exec_Lalloc: + forall s f sp arg res b rs m sz m' blk, + rs arg = Vint sz -> + Mem.alloc m 0 (Int.signed sz) = (m', blk) -> + let rs1 := Locmap.set (R loc_alloc_argument) (rs arg) rs in + let rs2 := Locmap.set (R loc_alloc_result) (Vptr blk Int.zero) rs1 in + let rs3 := Locmap.set res (rs2 (R loc_alloc_result)) rs2 in + step (State s f sp (Lalloc arg res :: b) rs m) + E0 (State s f sp b rs3 m') + | exec_Llabel: + forall s f sp lbl b rs m, + step (State s f sp (Llabel lbl :: b) rs m) + E0 (State s f sp b rs m) + | exec_Lgoto: + forall s f sp lbl b rs m b', + find_label lbl f.(fn_code) = Some b' -> + step (State s f sp (Lgoto lbl :: b) rs m) + E0 (State s f sp b' rs m) + | exec_Lcond_true: + forall s f sp cond args lbl b rs m b', + eval_condition cond (map rs args) m = Some true -> + find_label lbl f.(fn_code) = Some b' -> + step (State s f sp (Lcond cond args lbl :: b) rs m) + E0 (State s f sp b' rs m) + | exec_Lcond_false: + forall s f sp cond args lbl b rs m, + eval_condition cond (map rs args) m = Some false -> + step (State s f sp (Lcond cond args lbl :: b) rs m) + E0 (State s f sp b rs m) + | exec_Lreturn: + forall s f stk rs m or b, + let rs1 := set_result_reg f.(fn_sig) or rs in + let rs2 := return_regs (parent_locset s) rs1 in + step (State s f (Vptr stk Int.zero) (Lreturn or :: b) rs m) + E0 (Returnstate s f.(fn_sig) rs2 (Mem.free m stk)) + | exec_function_internal: + forall s f rs m m' stk, + Mem.alloc m 0 f.(fn_stacksize) = (m', stk) -> + let rs1 := call_regs rs in + let rs2 := parmov (loc_parameters f.(fn_sig)) f.(fn_params) rs1 in + step (Callstate s (Internal f) rs m) + E0 (State s f (Vptr stk Int.zero) f.(fn_code) rs2 m') + | exec_function_external: + forall s ef t res rs m, + let args := map rs (Conventions.loc_arguments ef.(ef_sig)) in + event_match ef args t res -> + let rs1 := + Locmap.set (R (Conventions.loc_result ef.(ef_sig))) res rs in + step (Callstate s (External ef) rs m) + t (Returnstate s ef.(ef_sig) rs1 m) + | exec_return: + forall res f sp rs0 b s sig rs m, + let rs1 := Locmap.set res (rs (R (loc_result sig))) rs in + step (Returnstate (Stackframe res f sp rs0 b :: s) sig rs m) + E0 (State s f sp b rs1 m). + +End RELSEM. + +Inductive initial_state (p: program): state -> Prop := + | initial_state_intro: forall b f, + let ge := Genv.globalenv p in + let m0 := Genv.init_mem p in + Genv.find_symbol ge p.(prog_main) = Some b -> + Genv.find_funct_ptr ge b = Some f -> + funsig f = mksignature nil (Some Tint) -> + initial_state p (Callstate nil f (Locmap.init Vundef) m0). + +Inductive final_state: state -> int -> Prop := + | final_state_intro: forall sig rs m r, + rs (R (loc_result sig)) = Vint r -> + final_state (Returnstate nil sig rs m) r. + +Definition exec_program (p: program) (beh: program_behavior) : Prop := + program_behaves step (initial_state p) final_state (Genv.globalenv p) beh. + +(** * Properties of the operational semantics *) + +Lemma find_label_is_tail: + forall lbl c c', find_label lbl c = Some c' -> is_tail c' c. +Proof. + induction c; simpl; intros. + discriminate. + destruct (is_label lbl a). inv H. constructor. constructor. + constructor. auto. +Qed. + diff --git a/backend/LTLintyping.v b/backend/LTLintyping.v new file mode 100644 index 00000000..06c50f8b --- /dev/null +++ b/backend/LTLintyping.v @@ -0,0 +1,104 @@ +(** Typing rules for LTLin. *) + +Require Import Coqlib. +Require Import Maps. +Require Import AST. +Require Import Op. +Require Import RTL. +Require Import Locations. +Require Import LTLin. +Require Import Conventions. + +(** The following predicates define a type system for LTLin similar to that + of LTL. *) + +Section WT_INSTR. + +Variable funsig: signature. + +Inductive wt_instr : instruction -> Prop := + | wt_Lopmove: + forall r1 r, + Loc.type r1 = Loc.type r -> loc_acceptable r1 -> loc_acceptable r -> + wt_instr (Lop Omove (r1 :: nil) r) + | wt_Lop: + forall op args res, + op <> Omove -> + (List.map Loc.type args, Loc.type res) = type_of_operation op -> + locs_acceptable args -> loc_acceptable res -> + wt_instr (Lop op args res) + | wt_Lload: + forall chunk addr args dst, + List.map Loc.type args = type_of_addressing addr -> + Loc.type dst = type_of_chunk chunk -> + locs_acceptable args -> loc_acceptable dst -> + wt_instr (Lload chunk addr args dst) + | wt_Lstore: + forall chunk addr args src, + List.map Loc.type args = type_of_addressing addr -> + Loc.type src = type_of_chunk chunk -> + locs_acceptable args -> loc_acceptable src -> + wt_instr (Lstore chunk addr args src) + | wt_Lcall: + forall sig ros args res, + match ros with inl r => Loc.type r = Tint | inr s => True end -> + List.map Loc.type args = sig.(sig_args) -> + Loc.type res = match sig.(sig_res) with None => Tint | Some ty => ty end -> + match ros with inl r => loc_acceptable r | inr s => True end -> + locs_acceptable args -> loc_acceptable res -> + wt_instr (Lcall sig ros args res) + | wt_Ltailcall: + forall sig ros args, + match ros with inl r => Loc.type r = Tint | inr s => True end -> + List.map Loc.type args = sig.(sig_args) -> + match ros with inl r => loc_acceptable r | inr s => True end -> + locs_acceptable args -> + sig.(sig_res) = funsig.(sig_res) -> + Conventions.tailcall_possible sig -> + wt_instr (Ltailcall sig ros args) + | wt_Lalloc: + forall arg res, + Loc.type arg = Tint -> Loc.type res = Tint -> + loc_acceptable arg -> loc_acceptable res -> + wt_instr (Lalloc arg res) + | wt_Llabel: forall lbl, + wt_instr (Llabel lbl) + | wt_Lgoto: forall lbl, + wt_instr (Lgoto lbl) + | wt_Lcond: + forall cond args lbl, + List.map Loc.type args = type_of_condition cond -> + locs_acceptable args -> + wt_instr (Lcond cond args lbl) + | wt_Lreturn: + forall optres, + option_map Loc.type optres = funsig.(sig_res) -> + match optres with None => True | Some r => loc_acceptable r end -> + wt_instr (Lreturn optres). + +Definition wt_code (c: code) : Prop := + forall i, In i c -> wt_instr i. + +End WT_INSTR. + +Record wt_function (f: function): Prop := + mk_wt_function { + wt_params: + List.map Loc.type f.(fn_params) = f.(fn_sig).(sig_args); + wt_acceptable: + locs_acceptable f.(fn_params); + wt_norepet: + Loc.norepet f.(fn_params); + wt_instrs: + wt_code f.(fn_sig) f.(fn_code) +}. + +Inductive wt_fundef: fundef -> Prop := + | wt_fundef_external: forall ef, + wt_fundef (External ef) + | wt_function_internal: forall f, + wt_function f -> + wt_fundef (Internal f). + +Definition wt_program (p: program): Prop := + forall i f, In (i, f) (prog_funct p) -> wt_fundef f. diff --git a/backend/LTLtyping.v b/backend/LTLtyping.v index 187c5cb8..646edc82 100644 --- a/backend/LTLtyping.v +++ b/backend/LTLtyping.v @@ -13,84 +13,99 @@ Require Import Conventions. of [RTL] (see file [RTLtyping]): it statically guarantees that operations and addressing modes are applied to the right number of arguments and that the arguments are of the correct types. Moreover, it also - enforces some correctness conditions on the offsets of stack slots - accessed through [Bgetstack] and [Bsetstack] LTL instructions. *) + guarantees that the locations of arguments and results are "acceptable", + i.e. either non-temporary registers or [Local] stack locations. *) -Section WT_BLOCK. +Section WT_INSTR. Variable funct: function. -Definition slot_bounded (s: slot) := - match s with - | Local ofs ty => 0 <= ofs - | Outgoing ofs ty => 6 <= ofs - | Incoming ofs ty => 6 <= ofs /\ ofs + typesize ty <= size_arguments funct.(fn_sig) - end. +Definition valid_successor (s: node) : Prop := + exists i, funct.(fn_code)!s = Some i. -Inductive wt_block : block -> Prop := - | wt_Bgetstack: - forall s r b, - slot_type s = mreg_type r -> - slot_bounded s -> - wt_block b -> - wt_block (Bgetstack s r b) - | wt_Bsetstack: - forall r s b, - match s with Incoming _ _ => False | _ => True end -> - slot_type s = mreg_type r -> - slot_bounded s -> - wt_block b -> - wt_block (Bsetstack r s b) - | wt_Bopmove: - forall r1 r b, - mreg_type r1 = mreg_type r -> - wt_block b -> - wt_block (Bop Omove (r1 :: nil) r b) - | wt_Bopundef: - forall r b, - wt_block b -> - wt_block (Bop Oundef nil r b) - | wt_Bop: - forall op args res b, - op <> Omove -> op <> Oundef -> - (List.map mreg_type args, mreg_type res) = type_of_operation op -> - wt_block b -> - wt_block (Bop op args res b) - | wt_Bload: - forall chunk addr args dst b, - List.map mreg_type args = type_of_addressing addr -> - mreg_type dst = type_of_chunk chunk -> - wt_block b -> - wt_block (Bload chunk addr args dst b) - | wt_Bstore: - forall chunk addr args src b, - List.map mreg_type args = type_of_addressing addr -> - mreg_type src = type_of_chunk chunk -> - wt_block b -> - wt_block (Bstore chunk addr args src b) - | wt_Bcall: - forall sig ros b, - match ros with inl r => mreg_type r = Tint | _ => True end -> - wt_block b -> - wt_block (Bcall sig ros b) - | wt_Balloc: - forall b, - wt_block b -> - wt_block (Balloc b) - | wt_Bgoto: - forall lbl, - wt_block (Bgoto lbl) - | wt_Bcond: - forall cond args ifso ifnot, - List.map mreg_type args = type_of_condition cond -> - wt_block (Bcond cond args ifso ifnot) - | wt_Breturn: - wt_block (Breturn). +Inductive wt_instr : instruction -> Prop := + | wt_Lnop: + forall s, + valid_successor s -> + wt_instr (Lnop s) + | wt_Lopmove: + forall r1 r s, + Loc.type r1 = Loc.type r -> loc_acceptable r1 -> loc_acceptable r -> + valid_successor s -> + wt_instr (Lop Omove (r1 :: nil) r s) + | wt_Lop: + forall op args res s, + op <> Omove -> + (List.map Loc.type args, Loc.type res) = type_of_operation op -> + locs_acceptable args -> loc_acceptable res -> + valid_successor s -> + wt_instr (Lop op args res s) + | wt_Lload: + forall chunk addr args dst s, + List.map Loc.type args = type_of_addressing addr -> + Loc.type dst = type_of_chunk chunk -> + locs_acceptable args -> loc_acceptable dst -> + valid_successor s -> + wt_instr (Lload chunk addr args dst s) + | wt_Lstore: + forall chunk addr args src s, + List.map Loc.type args = type_of_addressing addr -> + Loc.type src = type_of_chunk chunk -> + locs_acceptable args -> loc_acceptable src -> + valid_successor s -> + wt_instr (Lstore chunk addr args src s) + | wt_Lcall: + forall sig ros args res s, + match ros with inl r => Loc.type r = Tint | inr s => True end -> + List.map Loc.type args = sig.(sig_args) -> + Loc.type res = proj_sig_res sig -> + match ros with inl r => loc_acceptable r | inr s => True end -> + locs_acceptable args -> loc_acceptable res -> + valid_successor s -> + wt_instr (Lcall sig ros args res s) + | wt_Ltailcall: + forall sig ros args, + match ros with inl r => Loc.type r = Tint | inr s => True end -> + List.map Loc.type args = sig.(sig_args) -> + match ros with inl r => loc_acceptable r | inr s => True end -> + locs_acceptable args -> + sig.(sig_res) = funct.(fn_sig).(sig_res) -> + Conventions.tailcall_possible sig -> + wt_instr (Ltailcall sig ros args) + | wt_Lalloc: + forall arg res s, + Loc.type arg = Tint -> Loc.type res = Tint -> + loc_acceptable arg -> loc_acceptable res -> + valid_successor s -> + wt_instr (Lalloc arg res s) + | wt_Lcond: + forall cond args s1 s2, + List.map Loc.type args = type_of_condition cond -> + locs_acceptable args -> + valid_successor s1 -> valid_successor s2 -> + wt_instr (Lcond cond args s1 s2) + | wt_Lreturn: + forall optres, + option_map Loc.type optres = funct.(fn_sig).(sig_res) -> + match optres with None => True | Some r => loc_acceptable r end -> + wt_instr (Lreturn optres). -End WT_BLOCK. +End WT_INSTR. -Definition wt_function (f: function) : Prop := - forall pc b, f.(fn_code)!pc = Some b -> wt_block f b. +Record wt_function (f: function): Prop := + mk_wt_function { + wt_params: + List.map Loc.type f.(fn_params) = f.(fn_sig).(sig_args); + wt_acceptable: + locs_acceptable f.(fn_params); + wt_norepet: + Loc.norepet f.(fn_params); + wt_instrs: + forall pc instr, + f.(fn_code)!pc = Some instr -> wt_instr f instr; + wt_entrypoint: + valid_successor f f.(fn_entrypoint) +}. Inductive wt_fundef: fundef -> Prop := | wt_fundef_external: forall ef, @@ -99,6 +114,5 @@ Inductive wt_fundef: fundef -> Prop := wt_function f -> wt_fundef (Internal f). -Definition wt_program (p: program) : Prop := +Definition wt_program (p: program): Prop := forall i f, In (i, f) (prog_funct p) -> wt_fundef f. - diff --git a/backend/Linear.v b/backend/Linear.v index 0f1a31f2..65803710 100644 --- a/backend/Linear.v +++ b/backend/Linear.v @@ -1,10 +1,10 @@ (** The Linear intermediate language: abstract syntax and semantcs *) -(** The Linear language is a variant of LTL where control-flow is not - expressed as a graph of basic blocks, but as a linear list of - instructions with explicit labels and ``goto'' instructions. *) +(** The Linear language is a variant of LTLin where arithmetic + instructions operate on machine registers (type [mreg]) instead + of arbitrary locations. Special instructions [Lgetstack] and + [Lsetstack] are provided to access stack slots. *) -Require Import Relations. Require Import Coqlib. Require Import Maps. Require Import AST. @@ -13,24 +13,16 @@ Require Import Values. Require Import Mem. Require Import Events. Require Import Globalenvs. +Require Import Smallstep. Require Import Op. Require Import Locations. Require Import LTL. -Require Conventions. +Require Import Conventions. (** * Abstract syntax *) Definition label := positive. -(** Linear instructions are similar to their LTL counterpart: - arguments and results are machine registers, except for the - [Lgetstack] and [Lsetstack] instructions which are register-stack moves. - Except the last three, these instructions continue in sequence - with the next instruction in the linear list of instructions. - Unconditional branches [Lgoto] and conditional branches [Lcond] - transfer control to the given code label. Labels are explicitly - inserted in the instruction list as pseudo-instructions [Llabel]. *) - Inductive instruction: Set := | Lgetstack: slot -> mreg -> instruction | Lsetstack: mreg -> slot -> instruction @@ -38,6 +30,7 @@ Inductive instruction: Set := | Lload: memory_chunk -> addressing -> list mreg -> mreg -> instruction | Lstore: memory_chunk -> addressing -> list mreg -> mreg -> instruction | Lcall: signature -> mreg + ident -> instruction + | Ltailcall: signature -> mreg + ident -> instruction | Lalloc: instruction | Llabel: label -> instruction | Lgoto: label -> instruction @@ -108,121 +101,161 @@ Definition find_function (ros: mreg + ident) (rs: locset) : option fundef := end end. -(** [exec_instr ge f sp c ls m c' ls' m'] represents the execution - of the first instruction in the code sequence [c]. [ls] and [m] - are the initial location set and memory state, respectively. - [c'] is the current code sequence after execution of the instruction: - it is the tail of [c] if the instruction falls through. - [ls'] and [m'] are the final location state and memory state. *) +Definition reglist (rs: locset) (rl: list mreg) : list val := + List.map (fun r => rs (R r)) rl. + +(** The components of a Linear execution state are: + +- [State cs f sp c rs m]: [f] is the function currently executing. + [sp] is the stack pointer. [c] is the sequence of instructions + that remain to be executed. + [rs] maps locations to their current values. [m] is the current + memory state. + +- [Callstate cs f rs m]: + [f] is the function definition that we are calling. + [rs] is the values of locations just before the call. + [m] is the current memory state. + +- [Returnstate cs rs m]: + [rs] is the values of locations just before the return. + [m] is the current memory state. + +[cs] is a list of stack frames [Stackframe res f rs pc]. +[f] is the calling function, [sp] its stack pointer. +[rs] the values of locations just before the call. +[c] is the sequence of instructions following the call in the code of [f]. +*) + +Inductive stackframe: Set := + | Stackframe: + forall (f: function) (sp: val) (rs: locset) (c: code), + stackframe. + +Inductive state: Set := + | State: + forall (stack: list stackframe) (f: function) (sp: val) + (c: code) (rs: locset) (m: mem), + state + | Callstate: + forall (stack: list stackframe) (f: fundef) (rs: locset) (m: mem), + state + | Returnstate: + forall (stack: list stackframe) (rs: locset) (m: mem), + state. -Inductive exec_instr: function -> val -> - code -> locset -> mem -> trace -> - code -> locset -> mem -> Prop := +(** [parent_locset cs] returns the mapping of values for locations + of the caller function. *) + +Definition parent_locset (stack: list stackframe) : locset := + match stack with + | nil => Locmap.init Vundef + | Stackframe f sp ls c :: stack' => ls + end. + +Inductive step: state -> trace -> state -> Prop := | exec_Lgetstack: - forall f sp sl r b rs m, - exec_instr f sp (Lgetstack sl r :: b) rs m - E0 b (Locmap.set (R r) (rs (S sl)) rs) m + forall s f sp sl r b rs m, + step (State s f sp (Lgetstack sl r :: b) rs m) + E0 (State s f sp b (Locmap.set (R r) (rs (S sl)) rs) m) | exec_Lsetstack: - forall f sp r sl b rs m, - exec_instr f sp (Lsetstack r sl :: b) rs m - E0 b (Locmap.set (S sl) (rs (R r)) rs) m + forall s f sp r sl b rs m, + step (State s f sp (Lsetstack r sl :: b) rs m) + E0 (State s f sp b (Locmap.set (S sl) (rs (R r)) rs) m) | exec_Lop: - forall f sp op args res b rs m v, - eval_operation ge sp op (reglist args rs) = Some v -> - exec_instr f sp (Lop op args res :: b) rs m - E0 b (Locmap.set (R res) v rs) m + forall s f sp op args res b rs m v, + eval_operation ge sp op (reglist rs args) m = Some v -> + step (State s f sp (Lop op args res :: b) rs m) + E0 (State s f sp b (Locmap.set (R res) v rs) m) | exec_Lload: - forall f sp chunk addr args dst b rs m a v, - eval_addressing ge sp addr (reglist args rs) = Some a -> + forall s f sp chunk addr args dst b rs m a v, + eval_addressing ge sp addr (reglist rs args) = Some a -> loadv chunk m a = Some v -> - exec_instr f sp (Lload chunk addr args dst :: b) rs m - E0 b (Locmap.set (R dst) v rs) m + step (State s f sp (Lload chunk addr args dst :: b) rs m) + E0 (State s f sp b (Locmap.set (R dst) v rs) m) | exec_Lstore: - forall f sp chunk addr args src b rs m m' a, - eval_addressing ge sp addr (reglist args rs) = Some a -> + forall s f sp chunk addr args src b rs m m' a, + eval_addressing ge sp addr (reglist rs args) = Some a -> storev chunk m a (rs (R src)) = Some m' -> - exec_instr f sp (Lstore chunk addr args src :: b) rs m - E0 b rs m' + step (State s f sp (Lstore chunk addr args src :: b) rs m) + E0 (State s f sp b rs m') | exec_Lcall: - forall f sp sig ros b rs m t f' rs' m', + forall s f sp sig ros b rs m f', find_function ros rs = Some f' -> sig = funsig f' -> - exec_function f' rs m t rs' m' -> - exec_instr f sp (Lcall sig ros :: b) rs m - t b (return_regs rs rs') m' + step (State s f sp (Lcall sig ros :: b) rs m) + E0 (Callstate (Stackframe f sp rs b:: s) f' rs m) + | exec_Ltailcall: + forall s f stk sig ros b rs m f', + find_function ros rs = Some f' -> + sig = funsig f' -> + step (State s f (Vptr stk Int.zero) (Ltailcall sig ros :: b) rs m) + E0 (Callstate s f' (return_regs (parent_locset s) rs) (Mem.free m stk)) | exec_Lalloc: - forall f sp b rs m sz m' blk, + forall s f sp b rs m sz m' blk, rs (R Conventions.loc_alloc_argument) = Vint sz -> Mem.alloc m 0 (Int.signed sz) = (m', blk) -> - exec_instr f sp (Lalloc :: b) rs m - E0 b (Locmap.set (R Conventions.loc_alloc_result) - (Vptr blk Int.zero) rs) m' + step (State s f sp (Lalloc :: b) rs m) + E0 (State s f sp b + (Locmap.set (R Conventions.loc_alloc_result) + (Vptr blk Int.zero) rs) + m') | exec_Llabel: - forall f sp lbl b rs m, - exec_instr f sp (Llabel lbl :: b) rs m - E0 b rs m + forall s f sp lbl b rs m, + step (State s f sp (Llabel lbl :: b) rs m) + E0 (State s f sp b rs m) | exec_Lgoto: - forall f sp lbl b rs m b', + forall s f sp lbl b rs m b', find_label lbl f.(fn_code) = Some b' -> - exec_instr f sp (Lgoto lbl :: b) rs m - E0 b' rs m + step (State s f sp (Lgoto lbl :: b) rs m) + E0 (State s f sp b' rs m) | exec_Lcond_true: - forall f sp cond args lbl b rs m b', - eval_condition cond (reglist args rs) = Some true -> + forall s f sp cond args lbl b rs m b', + eval_condition cond (reglist rs args) m = Some true -> find_label lbl f.(fn_code) = Some b' -> - exec_instr f sp (Lcond cond args lbl :: b) rs m - E0 b' rs m + step (State s f sp (Lcond cond args lbl :: b) rs m) + E0 (State s f sp b' rs m) | exec_Lcond_false: - forall f sp cond args lbl b rs m, - eval_condition cond (reglist args rs) = Some false -> - exec_instr f sp (Lcond cond args lbl :: b) rs m - E0 b rs m - -with exec_instrs: function -> val -> - code -> locset -> mem -> trace -> - code -> locset -> mem -> Prop := - | exec_refl: - forall f sp b rs m, - exec_instrs f sp b rs m E0 b rs m - | exec_one: - forall f sp b1 rs1 m1 t b2 rs2 m2, - exec_instr f sp b1 rs1 m1 t b2 rs2 m2 -> - exec_instrs f sp b1 rs1 m1 t b2 rs2 m2 - | exec_trans: - forall f sp b1 rs1 m1 t1 b2 rs2 m2 t2 b3 rs3 m3 t, - exec_instrs f sp b1 rs1 m1 t1 b2 rs2 m2 -> - exec_instrs f sp b2 rs2 m2 t2 b3 rs3 m3 -> - t = t1 ** t2 -> - exec_instrs f sp b1 rs1 m1 t b3 rs3 m3 - -with exec_function: fundef -> locset -> mem -> trace -> locset -> mem -> Prop := - | exec_funct_internal: - forall f rs m t m1 stk rs2 m2 b, - alloc m 0 f.(fn_stacksize) = (m1, stk) -> - exec_instrs f (Vptr stk Int.zero) - f.(fn_code) (call_regs rs) m1 - t (Lreturn :: b) rs2 m2 -> - exec_function (Internal f) rs m t rs2 (free m2 stk) - | exec_funct_external: - forall ef args res rs1 rs2 m t, + forall s f sp cond args lbl b rs m, + eval_condition cond (reglist rs args) m = Some false -> + step (State s f sp (Lcond cond args lbl :: b) rs m) + E0 (State s f sp b rs m) + | exec_Lreturn: + forall s f stk b rs m, + step (State s f (Vptr stk Int.zero) (Lreturn :: b) rs m) + E0 (Returnstate s (return_regs (parent_locset s) rs) (Mem.free m stk)) + | exec_function_internal: + forall s f rs m m' stk, + alloc m 0 f.(fn_stacksize) = (m', stk) -> + step (Callstate s (Internal f) rs m) + E0 (State s f (Vptr stk Int.zero) f.(fn_code) (call_regs rs) m') + | exec_function_external: + forall s ef args res rs1 rs2 m t, event_match ef args t res -> args = List.map rs1 (Conventions.loc_arguments ef.(ef_sig)) -> rs2 = Locmap.set (R (Conventions.loc_result ef.(ef_sig))) res rs1 -> - exec_function (External ef) rs1 m t rs2 m. - -Scheme exec_instr_ind3 := Minimality for exec_instr Sort Prop - with exec_instrs_ind3 := Minimality for exec_instrs Sort Prop - with exec_function_ind3 := Minimality for exec_function Sort Prop. + step (Callstate s (External ef) rs1 m) + t (Returnstate s rs2 m) + | exec_return: + forall s f sp rs0 c rs m, + step (Returnstate (Stackframe f sp rs0 c :: s) rs m) + E0 (State s f sp c rs m). End RELSEM. -Definition exec_program (p: program) (t: trace) (r: val) : Prop := - let ge := Genv.globalenv p in - let m0 := Genv.init_mem p in - exists b, exists f, exists rs, exists m, - Genv.find_symbol ge p.(prog_main) = Some b /\ - Genv.find_funct_ptr ge b = Some f /\ - funsig f = mksignature nil (Some Tint) /\ - exec_function ge f (Locmap.init Vundef) m0 t rs m /\ - rs (R (Conventions.loc_result (funsig f))) = r. +Inductive initial_state (p: program): state -> Prop := + | initial_state_intro: forall b f, + let ge := Genv.globalenv p in + let m0 := Genv.init_mem p in + Genv.find_symbol ge p.(prog_main) = Some b -> + Genv.find_funct_ptr ge b = Some f -> + funsig f = mksignature nil (Some Tint) -> + initial_state p (Callstate nil f (Locmap.init Vundef) m0). + +Inductive final_state: state -> int -> Prop := + | final_state_intro: forall rs m r, + rs (R R3) = Vint r -> + final_state (Returnstate nil rs m) r. +Definition exec_program (p: program) (beh: program_behavior) : Prop := + program_behaves step (initial_state p) final_state (Genv.globalenv p) beh. diff --git a/backend/Linearize.v b/backend/Linearize.v index 3151628c..305473ba 100644 --- a/backend/Linearize.v +++ b/backend/Linearize.v @@ -1,5 +1,5 @@ (** Linearization of the control-flow graph: - translation from LTL to Linear *) + translation from LTL to LTLin *) Require Import Coqlib. Require Import Maps. @@ -9,24 +9,24 @@ Require Import Globalenvs. Require Import Op. Require Import Locations. Require Import LTL. -Require Import Linear. +Require Import LTLin. Require Import Kildall. Require Import Lattice. -(** To translate from LTL to Linear, we must layout the basic blocks +(** To translate from LTL to LTLin, we must lay out the basic blocks of the LTL control-flow graph in some linear order, and insert explicit branches and conditional branches to make sure that each basic block jumps to its successors as prescribed by the LTL control-flow graph. However, branches are not necessary - if the fall-through behaviour of Linear instructions already + if the fall-through behaviour of LTLin instructions already implements the desired flow of control. For instance, - consider the two LTL basic blocks + consider the two LTL instructions << - L1: Bop op args res (Bgoto L2) + L1: Lop op args res L2 L2: ... >> - If the blocks [L1] and [L2] are laid out consecutively in the Linear - code, we can generate the following Linear code: + If the instructions [L1] and [L2] are laid out consecutively in the LTLin + code, we can generate the following LTLin code: << L1: Lop op args res L2: ... @@ -49,19 +49,13 @@ Require Import Lattice. - Choosing an order for the basic blocks. This returns an enumeration of CFG nodes stating that the basic blocks must be laid out in the order shown in the list. -- Generate naive Linear code where each basic block branches explicitly - to its successors, even if one of these successors is the next basic - block. -- Simplify the naive Linear code, removing unconditional branches to - a label that immediately follows: -<< - ... ... - Igoto L1; becomes L1: ... - L1: ... ->> +- Generate LTLin code where each basic block branches explicitly + to its successors, except if one of these successors is the + immediately following instruction. + The beauty of this approach is that correct code is generated under surprisingly weak hypotheses on the enumeration of - CFG nodes: it suffices that every reachable basic block occurs + CFG nodes: it suffices that every reachable instruction occurs exactly once in the enumeration. While the enumeration heuristic we use is quite trivial, it is easy to implement more sophisticated trace picking heuristics: as long as they satisfy the property above, @@ -73,10 +67,10 @@ Require Import Lattice. (** * Determination of the order of basic blocks *) (** We first compute a mapping from CFG nodes to booleans, - indicating whether a CFG basic block is reachable or not. + indicating whether a CFG instruction is reachable or not. This computation is a trivial forward dataflow analysis where the transfer function is the identity: the successors - of a reachable block are reachable, by the very + of a reachable instruction are reachable, by the very definition of reachability. *) Module DS := Dataflow_Solver(LBoolean)(NodeSetForward). @@ -84,7 +78,7 @@ Module DS := Dataflow_Solver(LBoolean)(NodeSetForward). Definition reachable_aux (f: LTL.function) : option (PMap.t bool) := DS.fixpoint (successors f) - (Psucc f.(fn_entrypoint)) + (f.(fn_nextpc)) (fun pc r => r) ((f.(fn_entrypoint), true) :: nil). @@ -108,15 +102,17 @@ Definition enumerate (f: LTL.function) : list node := let reach := reachable f in positive_rec (list node) nil (fun pc nodes => if reach!!pc then pc :: nodes else nodes) - (Psucc f.(fn_entrypoint)). + f.(fn_nextpc). -(** * Translation from LTL to Linear *) +(** * Translation from LTL to LTLin *) (** We now flatten the structure of the CFG graph, laying out - basic blocks consecutively in the order computed by [enumerate], - and inserting a branch at the end of every basic block. + LTL instructions consecutively in the order computed by [enumerate], + and inserting branches to the labels of sucessors if necessary. + Whether to insert a branch or not is determined by + the [starts_with] function below. - For blocks ending in a conditional branch [Bcond cond args s1 s2], + For LTL conditional branches [Lcond cond args s1 s2], we have two possible translations: << Lcond cond args s1; or Lcond (not cond) args s2; @@ -124,8 +120,8 @@ Definition enumerate (f: LTL.function) : list node := >> We favour the first translation if [s2] is the label of the next instruction, and the second if [s1] is the label of the - next instruction, thus exhibiting more opportunities for - fall-through optimization later. *) + next instruction, thus avoiding the insertion of a redundant [Lgoto] + instruction. *) Fixpoint starts_with (lbl: label) (k: code) {struct k} : bool := match k with @@ -133,35 +129,35 @@ Fixpoint starts_with (lbl: label) (k: code) {struct k} : bool := | _ => false end. -Fixpoint linearize_block (b: block) (k: code) {struct b} : code := +Definition add_branch (s: label) (k: code) : code := + if starts_with s k then k else Lgoto s :: k. + +Definition linearize_instr (b: LTL.instruction) (k: code) : code := match b with - | Bgetstack s r b => - Lgetstack s r :: linearize_block b k - | Bsetstack r s b => - Lsetstack r s :: linearize_block b k - | Bop op args res b => - Lop op args res :: linearize_block b k - | Bload chunk addr args dst b => - Lload chunk addr args dst :: linearize_block b k - | Bstore chunk addr args src b => - Lstore chunk addr args src :: linearize_block b k - | Bcall sig ros b => - Lcall sig ros :: linearize_block b k - | Balloc b => - Lalloc :: linearize_block b k - | Bgoto s => - Lgoto s :: k - | Bcond cond args s1 s2 => + | LTL.Lnop s => + add_branch s k + | LTL.Lop op args res s => + Lop op args res :: add_branch s k + | LTL.Lload chunk addr args dst s => + Lload chunk addr args dst :: add_branch s k + | LTL.Lstore chunk addr args src s => + Lstore chunk addr args src :: add_branch s k + | LTL.Lcall sig ros args res s => + Lcall sig ros args res :: add_branch s k + | LTL.Ltailcall sig ros args => + Ltailcall sig ros args :: k + | LTL.Lalloc arg res s => + Lalloc arg res :: add_branch s k + | LTL.Lcond cond args s1 s2 => if starts_with s1 k then - Lcond (negate_condition cond) args s2 :: Lgoto s1 :: k + Lcond (negate_condition cond) args s2 :: add_branch s1 k else - Lcond cond args s1 :: Lgoto s2 :: k - | Breturn => - Lreturn :: k + Lcond cond args s1 :: add_branch s2 k + | LTL.Lreturn or => + Lreturn or :: k end. -(* Linearize a function body according to an enumeration of its - nodes. *) +(** Linearize a function body according to an enumeration of its nodes. *) Fixpoint linearize_body (f: LTL.function) (enum: list node) {struct enum} : code := @@ -170,47 +166,21 @@ Fixpoint linearize_body (f: LTL.function) (enum: list node) | pc :: rem => match f.(LTL.fn_code)!pc with | None => linearize_body f rem - | Some b => Llabel pc :: linearize_block b (linearize_body f rem) + | Some b => Llabel pc :: linearize_instr b (linearize_body f rem) end end. -Definition linearize_function (f: LTL.function) : Linear.function := +(** * Entry points for code linearization *) + +Definition transf_function (f: LTL.function) : LTLin.function := mkfunction (LTL.fn_sig f) + (LTL.fn_params f) (LTL.fn_stacksize f) - (linearize_body f (enumerate f)). - -(** * Cleanup of the linearized code *) - -(** We now eliminate [Lgoto] instructions that branch to an - immediately following label: these are redundant, as the fall-through - behaviour obtained by removing the [Lgoto] instruction is - semantically equivalent. *) - -Fixpoint cleanup_code (c: code) {struct c} : code := - match c with - | nil => nil - | Lgoto lbl :: c' => - if starts_with lbl c' - then cleanup_code c' - else Lgoto lbl :: cleanup_code c' - | i :: c' => - i :: cleanup_code c' - end. - -Definition cleanup_function (f: Linear.function) : Linear.function := - mkfunction - (fn_sig f) - (fn_stacksize f) - (cleanup_code f.(fn_code)). - -(** * Entry points for code linearization *) - -Definition transf_function (f: LTL.function) : Linear.function := - cleanup_function (linearize_function f). + (add_branch (LTL.fn_entrypoint f) (linearize_body f (enumerate f))). -Definition transf_fundef (f: LTL.fundef) : Linear.fundef := +Definition transf_fundef (f: LTL.fundef) : LTLin.fundef := AST.transf_fundef transf_function f. -Definition transf_program (p: LTL.program) : Linear.program := +Definition transf_program (p: LTL.program) : LTLin.program := transform_program transf_fundef p. diff --git a/backend/Linearizeproof.v b/backend/Linearizeproof.v index 5937fc34..c7299085 100644 --- a/backend/Linearizeproof.v +++ b/backend/Linearizeproof.v @@ -8,10 +8,12 @@ Require Import Values. Require Import Mem. Require Import Events. Require Import Globalenvs. +Require Import Smallstep. Require Import Op. Require Import Locations. Require Import LTL. -Require Import Linear. +Require Import LTLtyping. +Require Import LTLin. Require Import Linearize. Require Import Lattice. @@ -46,6 +48,18 @@ Proof. destruct f; reflexivity. Qed. +Lemma find_function_translated: + forall ros ls f, + LTL.find_function ge ros ls = Some f -> + find_function tge ros ls = Some (transf_fundef f). +Proof. + intros until f. destruct ros; simpl. + intro. apply functions_translated; auto. + rewrite symbols_preserved. destruct (Genv.find_symbol ge i). + apply function_ptr_translated; auto. + congruence. +Qed. + (** * Correctness of reachability analysis *) (** The entry point of the function is reachable. *) @@ -62,11 +76,10 @@ Proof. intros. apply PMap.gi. Qed. -(** The successors of a reachable basic block are reachable. *) +(** The successors of a reachable instruction are reachable. *) Lemma reachable_successors: forall f pc pc', - f.(LTL.fn_code)!pc <> None -> In pc' (successors f pc) -> (reachable f)!!pc = true -> (reachable f)!!pc' = true. @@ -74,51 +87,19 @@ Proof. intro f. unfold reachable. caseEq (reachable_aux f). unfold reachable_aux. intro reach; intros. + elim (LTL.fn_code_wf f pc); intro. assert (LBoolean.ge reach!!pc' reach!!pc). change (reach!!pc) with ((fun pc r => r) pc (reach!!pc)). - eapply DS.fixpoint_solution. eexact H. - elim (fn_code_wf f pc); intro. auto. contradiction. - auto. + eapply DS.fixpoint_solution. eexact H. auto. auto. elim H3; intro. congruence. auto. + unfold successors in H0. rewrite H2 in H0. contradiction. intros. apply PMap.gi. Qed. -(* If we have a valid LTL transition from [pc] to [pc'], and - [pc] is reachable, then [pc'] is reachable. *) - -Lemma reachable_correct_1: - forall f sp pc rs m t pc' rs' m' b, - f.(LTL.fn_code)!pc = Some b -> - exec_block ge sp b rs m t (Cont pc') rs' m' -> - (reachable f)!!pc = true -> - (reachable f)!!pc' = true. -Proof. - intros. apply reachable_successors with pc; auto. - congruence. - eapply successors_correct; eauto. -Qed. - -Lemma reachable_correct_2: - forall c sp pc rs m t out rs' m', - exec_blocks ge c sp pc rs m t out rs' m' -> - forall f pc', - c = f.(LTL.fn_code) -> - out = Cont pc' -> - (reachable f)!!pc = true -> - (reachable f)!!pc' = true. -Proof. - induction 1; intros. - congruence. - eapply reachable_correct_1. rewrite <- H1; eauto. - subst out; eauto. auto. - auto. -Qed. - (** * Properties of node enumeration *) (** An enumeration of CFG nodes is correct if the following conditions hold: - All nodes for reachable basic blocks must be in the list. -- The function entry point is the first element in the list. - The list is without repetition (so that no code duplication occurs). We prove that our [enumerate] function satisfies all three. *) @@ -131,10 +112,10 @@ Lemma enumerate_complete: Proof. intros. assert (forall p, - Plt p (Psucc f.(fn_entrypoint)) -> + Plt p f.(fn_nextpc) -> (reachable f)!!p = true -> In p (enumerate f)). - unfold enumerate. pattern (Psucc (fn_entrypoint f)). + unfold enumerate. pattern (fn_nextpc f). apply positive_Peano_ind. intros. compute in H1. destruct p; discriminate. intros. rewrite positive_rec_succ. elim (Plt_succ_inv _ _ H2); intro. @@ -143,27 +124,15 @@ Proof. elim (LTL.fn_code_wf f pc); intro. auto. congruence. Qed. -Lemma enumerate_head: - forall f, exists l, enumerate f = f.(LTL.fn_entrypoint) :: l. -Proof. - intro. unfold enumerate. rewrite positive_rec_succ. - rewrite reachable_entrypoint. - exists (positive_rec (list node) nil - (fun (pc : positive) (nodes : list node) => - if (reachable f) !! pc then pc :: nodes else nodes) - (fn_entrypoint f) ). - auto. -Qed. - Lemma enumerate_norepet: forall f, list_norepet (enumerate f). Proof. intro. - unfold enumerate. pattern (Psucc (fn_entrypoint f)). + unfold enumerate. pattern (fn_nextpc f). apply positive_Peano_ind. rewrite positive_rec_base. constructor. intros. rewrite positive_rec_succ. - case (reachable f)!!x. auto. + case (reachable f)!!x. constructor. assert (forall y, In y (positive_rec @@ -183,9 +152,9 @@ Proof. auto. Qed. -(** * Correctness of the cleanup pass *) +(** * Properties related to labels *) -(** If labels are globally unique and the Linear code [c] contains +(** If labels are globally unique and the LTLin code [c] contains a subsequence [Llabel lbl :: c1], [find_label lbl c] returns [c1]. *) @@ -196,27 +165,6 @@ Fixpoint unique_labels (c: code) : Prop := | i :: c => unique_labels c end. -Inductive is_tail: code -> code -> Prop := - | is_tail_refl: - forall c, is_tail c c - | is_tail_cons: - forall i c1 c2, is_tail c1 c2 -> is_tail c1 (i :: c2). - -Lemma is_tail_in: - forall i c1 c2, is_tail (i :: c1) c2 -> In i c2. -Proof. - induction c2; simpl; intros. - inversion H. - inversion H. tauto. right; auto. -Qed. - -Lemma is_tail_cons_left: - forall i c1 c2, is_tail (i :: c1) c2 -> is_tail c1 c2. -Proof. - induction c2; intros; inversion H. - constructor. constructor. constructor. auto. -Qed. - Lemma find_label_unique: forall lbl c1 c2 c3, is_tail (Llabel lbl :: c1) c2 -> @@ -237,163 +185,51 @@ Qed. (** Correctness of the [starts_with] test. *) Lemma starts_with_correct: - forall lbl c1 c2 c3 f sp ls m, + forall lbl c1 c2 c3 s f sp ls m, is_tail c1 c2 -> unique_labels c2 -> starts_with lbl c1 = true -> find_label lbl c2 = Some c3 -> - exec_instrs tge f sp (cleanup_code c1) ls m - E0 (cleanup_code c3) ls m. + plus step tge (State s f sp c1 ls m) + E0 (State s f sp c3 ls m). Proof. induction c1. simpl; intros; discriminate. simpl starts_with. destruct a; try (intros; discriminate). - intros. apply exec_trans with E0 (cleanup_code c1) ls m E0. - simpl. - constructor. constructor. + intros. + apply plus_left with E0 (State s f sp c1 ls m) E0. + simpl. constructor. destruct (peq lbl l). subst l. replace c3 with c1. constructor. apply find_label_unique with lbl c2; auto. + apply plus_star. apply IHc1 with c2; auto. eapply is_tail_cons_left; eauto. traceEq. Qed. -(** Code cleanup preserves the labeling of the code. *) - -Lemma find_label_cleanup_code: - forall lbl c c', - find_label lbl c = Some c' -> - find_label lbl (cleanup_code c) = Some (cleanup_code c'). -Proof. - induction c. - simpl. intros; discriminate. - generalize (is_label_correct lbl a). - simpl find_label. case (is_label lbl a); intro. - subst a. intros. injection H; intros. subst c'. - simpl. rewrite peq_true. auto. - intros. destruct a; auto. - simpl. rewrite peq_false. auto. - congruence. - case (starts_with l c). auto. simpl. auto. -Qed. - -(** One transition in the original Linear code corresponds to zero - or one transitions in the cleaned-up code. *) - -Lemma cleanup_code_correct_1: - forall f sp c1 ls1 m1 t c2 ls2 m2, - exec_instr tge f sp c1 ls1 m1 t c2 ls2 m2 -> - is_tail c1 f.(fn_code) -> - unique_labels f.(fn_code) -> - exec_instrs tge (cleanup_function f) sp - (cleanup_code c1) ls1 m1 - t (cleanup_code c2) ls2 m2. -Proof. - induction 1; simpl; intros; - try (apply exec_one; econstructor; eauto; fail). - (* goto *) - caseEq (starts_with lbl b); intro SW. - eapply starts_with_correct; eauto. - eapply is_tail_cons_left; eauto. - constructor. constructor. - unfold cleanup_function; simpl. - apply find_label_cleanup_code. auto. - (* cond, taken *) - constructor. apply exec_Lcond_true. auto. - unfold cleanup_function; simpl. - apply find_label_cleanup_code. auto. - (* cond, not taken *) - constructor. apply exec_Lcond_false. auto. -Qed. - -Lemma is_tail_find_label: - forall lbl c2 c1, - find_label lbl c1 = Some c2 -> is_tail c2 c1. -Proof. - induction c1; simpl. - intros; discriminate. - case (is_label lbl a). intro. injection H; intro. subst c2. - constructor. constructor. - intro. constructor. auto. -Qed. - -Lemma is_tail_exec_instr: - forall f sp c1 ls1 m1 t c2 ls2 m2, - exec_instr tge f sp c1 ls1 m1 t c2 ls2 m2 -> - is_tail c1 f.(fn_code) -> is_tail c2 f.(fn_code). -Proof. - induction 1; intros; - try (eapply is_tail_cons_left; eauto; fail). - eapply is_tail_find_label; eauto. - eapply is_tail_find_label; eauto. -Qed. - -Lemma is_tail_exec_instrs: - forall f sp c1 ls1 m1 t c2 ls2 m2, - exec_instrs tge f sp c1 ls1 m1 t c2 ls2 m2 -> - is_tail c1 f.(fn_code) -> is_tail c2 f.(fn_code). -Proof. - induction 1; intros. - auto. - eapply is_tail_exec_instr; eauto. - auto. -Qed. - -(** Zero, one or several transitions in the original Linear code correspond - to zero, one or several transitions in the cleaned-up code. *) - -Lemma cleanup_code_correct_2: - forall f sp c1 ls1 m1 t c2 ls2 m2, - exec_instrs tge f sp c1 ls1 m1 t c2 ls2 m2 -> - is_tail c1 f.(fn_code) -> - unique_labels f.(fn_code) -> - exec_instrs tge (cleanup_function f) sp - (cleanup_code c1) ls1 m1 - t (cleanup_code c2) ls2 m2. -Proof. - induction 1; simpl; intros. - apply exec_refl. - eapply cleanup_code_correct_1; eauto. - apply exec_trans with t1 (cleanup_code b2) rs2 m2 t2. - auto. - apply IHexec_instrs2; auto. - eapply is_tail_exec_instrs; eauto. - auto. -Qed. +(** Connection between [find_label] and linearization. *) -Lemma cleanup_function_correct: - forall f ls1 m1 t ls2 m2, - exec_function tge (Internal f) ls1 m1 t ls2 m2 -> - unique_labels f.(fn_code) -> - exec_function tge (Internal (cleanup_function f)) ls1 m1 t ls2 m2. +Lemma find_label_add_branch: + forall lbl k s, + find_label lbl (add_branch s k) = find_label lbl k. Proof. - intros. inversion H; subst. - generalize (cleanup_code_correct_2 _ _ _ _ _ _ _ _ _ H3 (is_tail_refl _) H0). - simpl. intro. - econstructor; eauto. + intros. unfold add_branch. destruct (starts_with s k); auto. Qed. -(** * Properties of linearized code *) - -(** We now state useful properties of the Linear code generated by - the naive LTL-to-Linear translation. *) - -(** Connection between [find_label] and linearization. *) - -Lemma find_label_lin_block: +Lemma find_label_lin_instr: forall lbl k b, - find_label lbl (linearize_block b k) = find_label lbl k. + find_label lbl (linearize_instr b k) = find_label lbl k. Proof. + intros lbl k. generalize (find_label_add_branch lbl k); intro. induction b; simpl; auto. - case (starts_with n k); reflexivity. + case (starts_with n k); simpl; auto. Qed. Lemma find_label_lin_rec: forall f enum pc b, In pc enum -> f.(LTL.fn_code)!pc = Some b -> - exists k, - find_label pc (linearize_body f enum) = Some (linearize_block b k). + exists k, find_label pc (linearize_body f enum) = Some (linearize_instr b k). Proof. induction enum; intros. elim H. @@ -403,7 +239,7 @@ Proof. assert (In pc enum). simpl in H. tauto. elim (IHenum pc b H1 H0). intros k FIND. exists k. simpl. destruct (LTL.fn_code f)!a. - simpl. rewrite peq_false. rewrite find_label_lin_block. auto. auto. + simpl. rewrite peq_false. rewrite find_label_lin_instr. auto. auto. auto. Qed. @@ -412,20 +248,56 @@ Lemma find_label_lin: f.(LTL.fn_code)!pc = Some b -> (reachable f)!!pc = true -> exists k, - find_label pc (fn_code (linearize_function f)) = Some (linearize_block b k). + find_label pc (fn_code (transf_function f)) = Some (linearize_instr b k). Proof. - intros. unfold linearize_function; simpl. apply find_label_lin_rec. + intros. unfold transf_function; simpl. + rewrite find_label_add_branch. apply find_label_lin_rec. eapply enumerate_complete; eauto. auto. Qed. +Lemma find_label_lin_inv: + forall f pc b k , + f.(LTL.fn_code)!pc = Some b -> + (reachable f)!!pc = true -> + find_label pc (fn_code (transf_function f)) = Some k -> + exists k', k = linearize_instr b k'. +Proof. + intros. exploit find_label_lin; eauto. intros [k' FIND]. + exists k'. congruence. +Qed. + +Lemma find_label_lin_succ: + forall f s, + valid_successor f s -> + (reachable f)!!s = true -> + exists k, + find_label s (fn_code (transf_function f)) = Some k. +Proof. + intros. destruct H as [i AT]. + exploit find_label_lin; eauto. intros [k FIND]. + exists (linearize_instr i k); auto. +Qed. + (** Unique label property for linearized code. *) -Lemma label_in_lin_block: +Lemma label_in_add_branch: + forall lbl s k, + In (Llabel lbl) (add_branch s k) -> In (Llabel lbl) k. +Proof. + intros until k; unfold add_branch. + destruct (starts_with s k); simpl; intuition congruence. +Qed. + +Lemma label_in_lin_instr: forall lbl k b, - In (Llabel lbl) (linearize_block b k) -> In (Llabel lbl) k. + In (Llabel lbl) (linearize_instr b k) -> In (Llabel lbl) k. Proof. - induction b; simpl; try (intuition congruence). - case (starts_with n k); simpl; intuition congruence. + induction b; simpl; intros; + try (apply label_in_add_branch with n; intuition congruence); + try (intuition congruence). + destruct (starts_with n k); simpl in H. + apply label_in_add_branch with n; intuition congruence. + apply label_in_add_branch with n0; intuition congruence. Qed. Lemma label_in_lin_rec: @@ -436,16 +308,24 @@ Proof. simpl; auto. simpl. destruct (LTL.fn_code f)!a. simpl. intros [A|B]. left; congruence. - right. apply IHenum. eapply label_in_lin_block; eauto. + right. apply IHenum. eapply label_in_lin_instr; eauto. intro; right; auto. Qed. -Lemma unique_labels_lin_block: +Lemma unique_labels_add_branch: + forall lbl k, + unique_labels k -> unique_labels (add_branch lbl k). +Proof. + intros; unfold add_branch. + destruct (starts_with lbl k); simpl; intuition. +Qed. + +Lemma unique_labels_lin_instr: forall k b, - unique_labels k -> unique_labels (linearize_block b k). + unique_labels k -> unique_labels (linearize_instr b k). Proof. - induction b; simpl; auto. - case (starts_with n k); simpl; auto. + induction b; intro; simpl; auto; try (apply unique_labels_add_branch; auto). + case (starts_with n k); simpl; apply unique_labels_add_branch; auto. Qed. Lemma unique_labels_lin_rec: @@ -458,268 +338,339 @@ Proof. intro. simpl. destruct (LTL.fn_code f)!a. simpl. split. red. intro. inversion H. elim H3. apply label_in_lin_rec with f. - apply label_in_lin_block with b. auto. - apply unique_labels_lin_block. apply IHenum. inversion H; auto. + apply label_in_lin_instr with i. auto. + apply unique_labels_lin_instr. apply IHenum. inversion H; auto. apply IHenum. inversion H; auto. Qed. -Lemma unique_labels_lin_function: +Lemma unique_labels_transf_function: forall f, - unique_labels (fn_code (linearize_function f)). + unique_labels (fn_code (transf_function f)). Proof. - intros. unfold linearize_function; simpl. + intros. unfold transf_function; simpl. + apply unique_labels_add_branch. apply unique_labels_lin_rec. apply enumerate_norepet. Qed. -(** * Correctness of linearization *) +(** Correctness of [add_branch]. *) + +Lemma is_tail_find_label: + forall lbl c2 c1, + find_label lbl c1 = Some c2 -> is_tail c2 c1. +Proof. + induction c1; simpl. + intros; discriminate. + case (is_label lbl a). intro. injection H; intro. subst c2. + constructor. constructor. + intro. constructor. auto. +Qed. -(** The outcome of an LTL [exec_block] or [exec_blocks] execution - is valid if it corresponds to a reachable, existing basic block. - All outcomes occurring in an LTL program execution are actually - valid, but we will prove that along with the main simulation proof. *) +Lemma is_tail_add_branch: + forall lbl c1 c2, is_tail (add_branch lbl c1) c2 -> is_tail c1 c2. +Proof. + intros until c2. unfold add_branch. destruct (starts_with lbl c1). + auto. eauto with coqlib. +Qed. -Definition valid_outcome (f: LTL.function) (out: outcome) := - match out with - | Cont s => - (reachable f)!!s = true /\ exists b, f.(LTL.fn_code)!s = Some b - | Return => True - end. +Lemma add_branch_correct: + forall lbl c k s f sp ls m, + is_tail k (transf_function f).(fn_code) -> + find_label lbl (transf_function f).(fn_code) = Some c -> + plus step tge (State s (transf_function f) sp (add_branch lbl k) ls m) + E0 (State s (transf_function f) sp c ls m). +Proof. + intros. unfold add_branch. + caseEq (starts_with lbl k); intro SW. + eapply starts_with_correct; eauto. + apply unique_labels_transf_function. + apply plus_one. apply exec_Lgoto. auto. +Qed. -(** Auxiliary lemma used to establish the [valid_outcome] property. *) +(** * Correctness of linearization *) -Lemma exec_blocks_valid_outcome: - forall c sp pc ls1 m1 t out ls2 m2, - exec_blocks ge c sp pc ls1 m1 t out ls2 m2 -> - forall f, - c = f.(LTL.fn_code) -> - (reachable f)!!pc = true -> - valid_outcome f out -> - valid_outcome f (Cont pc). +(** The proof of semantic preservation is a simulation argument + based on diagrams of the following form: +<< + st1 --------------- st2 + | | + t| +|t + | | + v v + st1'--------------- st2' +>> + The invariant (horizontal lines above) is the [match_states] + predicate defined below. It captures the fact that the flow + of data is the same in the source and linearized codes. + Moreover, whenever the source state is at node [pc] in its + control-flow graph, the transformed state is at a code + sequence [c] that starts with the label [pc]. *) + +Inductive match_stackframes: LTL.stackframe -> LTLin.stackframe -> Prop := + | match_stackframe_intro: + forall res f sp pc ls c, + (reachable f)!!pc = true -> + valid_successor f pc -> + is_tail c (fn_code (transf_function f)) -> + wt_function f -> + match_stackframes + (LTL.Stackframe res f sp ls pc) + (LTLin.Stackframe res (transf_function f) sp ls (add_branch pc c)). + +Inductive match_states: LTL.state -> LTLin.state -> Prop := + | match_states_intro: + forall s f sp pc ls m ts c + (STACKS: list_forall2 match_stackframes s ts) + (REACH: (reachable f)!!pc = true) + (AT: find_label pc (fn_code (transf_function f)) = Some c) + (WTF: wt_function f), + match_states (LTL.State s f sp pc ls m) + (LTLin.State ts (transf_function f) sp c ls m) + | match_states_call: + forall s f ls m ts, + list_forall2 match_stackframes s ts -> + wt_fundef f -> + match_states (LTL.Callstate s f ls m) + (LTLin.Callstate ts (transf_fundef f) ls m) + | match_states_return: + forall s sig ls m ts, + list_forall2 match_stackframes s ts -> + match_states (LTL.Returnstate s sig ls m) + (LTLin.Returnstate ts sig ls m). + +Remark parent_locset_match: + forall s ts, + list_forall2 match_stackframes s ts -> + parent_locset ts = LTL.parent_locset s. Proof. - induction 1. - auto. - intros. simpl. split. auto. exists b. congruence. - intros. apply IHexec_blocks1. auto. auto. - apply IHexec_blocks2. auto. - eapply reachable_correct_2. eexact H. auto. auto. auto. - auto. + induction 1; simpl; auto. inv H; auto. Qed. -(** Correspondence between an LTL outcome and a fragment of generated - Linear code. *) - -Inductive cont_for_outcome: LTL.function -> outcome -> code -> Prop := - | co_return: - forall f k, - cont_for_outcome f Return (Lreturn :: k) - | co_goto: - forall f s k, - find_label s (linearize_function f).(fn_code) = Some k -> - cont_for_outcome f (Cont s) k. - -(** The simulation properties used in the inductive proof. - They are parameterized by an LTL execution, and state - that a matching execution is possible in the generated Linear code. *) - -Definition exec_instr_prop - (sp: val) (b1: block) (ls1: locset) (m1: mem) - (t: trace) (b2: block) (ls2: locset) (m2: mem) : Prop := - forall f k, - exec_instr tge (linearize_function f) sp - (linearize_block b1 k) ls1 m1 - t (linearize_block b2 k) ls2 m2. - -Definition exec_instrs_prop - (sp: val) (b1: block) (ls1: locset) (m1: mem) - (t: trace) (b2: block) (ls2: locset) (m2: mem) : Prop := - forall f k, - exec_instrs tge (linearize_function f) sp - (linearize_block b1 k) ls1 m1 - t (linearize_block b2 k) ls2 m2. - -Definition exec_block_prop - (sp: val) (b: block) (ls1: locset) (m1: mem) - (t: trace) (out: outcome) (ls2: locset) (m2: mem): Prop := - forall f k, - valid_outcome f out -> - exists k', - exec_instrs tge (linearize_function f) sp - (linearize_block b k) ls1 m1 - t k' ls2 m2 - /\ cont_for_outcome f out k'. - -Definition exec_blocks_prop - (c: LTL.code) (sp: val) (pc: node) (ls1: locset) (m1: mem) - (t: trace) (out: outcome) (ls2: locset) (m2: mem): Prop := - forall f k, - c = f.(LTL.fn_code) -> - (reachable f)!!pc = true -> - find_label pc (fn_code (linearize_function f)) = Some k -> - valid_outcome f out -> - exists k', - exec_instrs tge (linearize_function f) sp - k ls1 m1 - t k' ls2 m2 - /\ cont_for_outcome f out k'. - -Definition exec_function_prop - (f: LTL.fundef) (ls1: locset) (m1: mem) (t: trace) - (ls2: locset) (m2: mem): Prop := - exec_function tge (transf_fundef f) ls1 m1 t ls2 m2. - -Scheme exec_instr_ind5 := Minimality for LTL.exec_instr Sort Prop - with exec_instrs_ind5 := Minimality for LTL.exec_instrs Sort Prop - with exec_block_ind5 := Minimality for LTL.exec_block Sort Prop - with exec_blocks_ind5 := Minimality for LTL.exec_blocks Sort Prop - with exec_function_ind5 := Minimality for LTL.exec_function Sort Prop. - -(** The obligatory proof by structural induction on the LTL evaluation - derivation. *) - -Lemma transf_function_correct: - forall f ls1 m1 t ls2 m2, - LTL.exec_function ge f ls1 m1 t ls2 m2 -> - exec_function_prop f ls1 m1 t ls2 m2. +Hypothesis wt_prog: wt_program prog. + +Theorem transf_step_correct: + forall s1 t s2, LTL.step ge s1 t s2 -> + forall s1' (MS: match_states s1 s1'), + exists s2', plus LTLin.step tge s1' t s2' /\ match_states s2 s2'. Proof. - apply (exec_function_ind5 ge - exec_instr_prop - exec_instrs_prop - exec_block_prop - exec_blocks_prop - exec_function_prop); - intros; red; intros; simpl. - (* getstack *) - constructor. - (* setstack *) - constructor. - (* op *) - constructor. rewrite <- H. apply eval_operation_preserved. - exact symbols_preserved. - (* load *) - apply exec_Lload with a. - rewrite <- H. apply eval_addressing_preserved. - exact symbols_preserved. - auto. - (* store *) - apply exec_Lstore with a. - rewrite <- H. apply eval_addressing_preserved. - exact symbols_preserved. - auto. - (* call *) - apply exec_Lcall with (transf_fundef f). - generalize H. destruct ros; simpl. - intro; apply functions_translated; auto. - rewrite symbols_preserved. destruct (Genv.find_symbol ge i). - intro; apply function_ptr_translated; auto. congruence. - generalize (sig_preserved f). congruence. - apply H2. - (* alloc *) - eapply exec_Lalloc; eauto. - (* instr_refl *) - apply exec_refl. - (* instr_one *) - apply exec_one. apply H0. - (* instr_trans *) - apply exec_trans with t1 (linearize_block b2 k) rs2 m2 t2. - apply H0. apply H2. auto. - (* goto *) - elim H1. intros REACH [b2 AT2]. - generalize (H0 f k). simpl. intro. - elim (find_label_lin f s b2 AT2 REACH). intros k2 FIND. - exists (linearize_block b2 k2). - split. - eapply exec_trans. eexact H2. constructor. constructor. auto. traceEq. - constructor. auto. - (* cond, true *) - elim H2. intros REACH [b2 AT2]. - elim (find_label_lin f ifso b2 AT2 REACH). intros k2 FIND. - exists (linearize_block b2 k2). - split. - generalize (H0 f k). simpl. - case (starts_with ifso k); intro. - eapply exec_trans. eexact H3. - eapply exec_trans. apply exec_one. apply exec_Lcond_false. - change false with (negb true). apply eval_negate_condition. auto. - apply exec_one. apply exec_Lgoto. auto. reflexivity. traceEq. - eapply exec_trans. eexact H3. - apply exec_one. apply exec_Lcond_true. - auto. auto. traceEq. - constructor; auto. - (* cond, false *) - elim H2. intros REACH [b2 AT2]. - elim (find_label_lin f ifnot b2 AT2 REACH). intros k2 FIND. - exists (linearize_block b2 k2). - split. - generalize (H0 f k). simpl. - case (starts_with ifso k); intro. - eapply exec_trans. eexact H3. - apply exec_one. apply exec_Lcond_true. - change true with (negb false). apply eval_negate_condition. auto. - auto. traceEq. - eapply exec_trans. eexact H3. - eapply exec_trans. apply exec_one. apply exec_Lcond_false. auto. - apply exec_one. apply exec_Lgoto. auto. reflexivity. traceEq. - constructor; auto. - (* return *) - exists (Lreturn :: k). split. - exact (H0 f k). constructor. - (* refl blocks *) - exists k. split. apply exec_refl. constructor. auto. - (* one blocks *) - subst c. elim (find_label_lin f pc b H H3). intros k' FIND. - assert (k = linearize_block b k'). congruence. subst k. - elim (H1 f k' H5). intros k'' [EXEC CFO]. - exists k''. tauto. - (* trans blocks *) - assert ((reachable f)!!pc2 = true). - eapply reachable_correct_2. eexact H. auto. auto. auto. - assert (valid_outcome f (Cont pc2)). - eapply exec_blocks_valid_outcome; eauto. - generalize (H0 f k H4 H5 H6 H9). intros [k1 [EX1 CFO2]]. - inversion CFO2. - generalize (H2 f k1 H4 H8 H12 H7). intros [k2 [EX2 CFO3]]. - exists k2. split. eapply exec_trans; eauto. auto. - (* internal function -- TA-DA! *) - assert (REACH0: (reachable f)!!(fn_entrypoint f) = true). + induction 1; intros; try (inv MS); + try (generalize (wt_instrs _ WTF _ _ H); intro WTI). + (* Lnop *) + destruct (find_label_lin_inv _ _ _ _ H REACH AT) as [c' EQ]. + simpl in EQ. subst c. + assert (REACH': (reachable f)!!pc' = true). + eapply reachable_successors; eauto. + unfold successors; rewrite H; auto with coqlib. + exploit find_label_lin_succ; eauto. inv WTI; auto. intros [c'' AT']. + econstructor; split. + eapply add_branch_correct; eauto. + eapply is_tail_add_branch. eapply is_tail_find_label. eauto. + econstructor; eauto. + (* Lop *) + destruct (find_label_lin_inv _ _ _ _ H REACH AT) as [c' EQ]. + simpl in EQ. subst c. + assert (REACH': (reachable f)!!pc' = true). + eapply reachable_successors; eauto. + unfold successors; rewrite H; auto with coqlib. + exploit find_label_lin_succ; eauto. inv WTI; auto. intros [c'' AT']. + econstructor; split. + eapply plus_left'. + eapply exec_Lop with (v := v); eauto. + rewrite <- H0. apply eval_operation_preserved. exact symbols_preserved. + eapply add_branch_correct; eauto. + eapply is_tail_add_branch. eapply is_tail_cons_left. + eapply is_tail_find_label. eauto. + traceEq. + econstructor; eauto. + (* Lload *) + destruct (find_label_lin_inv _ _ _ _ H REACH AT) as [c' EQ]. + simpl in EQ. subst c. + assert (REACH': (reachable f)!!pc' = true). + eapply reachable_successors; eauto. + unfold successors; rewrite H; auto with coqlib. + exploit find_label_lin_succ; eauto. inv WTI; auto. intros [c'' AT']. + econstructor; split. + eapply plus_left'. + eapply exec_Lload; eauto. + rewrite <- H0. apply eval_addressing_preserved. exact symbols_preserved. + eapply add_branch_correct; eauto. + eapply is_tail_add_branch. eapply is_tail_cons_left. + eapply is_tail_find_label. eauto. + traceEq. + econstructor; eauto. + (* Lstore *) + destruct (find_label_lin_inv _ _ _ _ H REACH AT) as [c' EQ]. + simpl in EQ. subst c. + assert (REACH': (reachable f)!!pc' = true). + eapply reachable_successors; eauto. + unfold successors; rewrite H; auto with coqlib. + exploit find_label_lin_succ; eauto. inv WTI; auto. intros [c'' AT']. + econstructor; split. + eapply plus_left'. + eapply exec_Lstore; eauto. + rewrite <- H0. apply eval_addressing_preserved. exact symbols_preserved. + eapply add_branch_correct; eauto. + eapply is_tail_add_branch. eapply is_tail_cons_left. + eapply is_tail_find_label. eauto. + traceEq. + econstructor; eauto. + (* Lcall *) + unfold rs1 in *. inv MS. fold rs1. + generalize (wt_instrs _ WTF _ _ H); intro WTI. + destruct (find_label_lin_inv _ _ _ _ H REACH AT) as [c' EQ]. + simpl in EQ. subst c. + assert (REACH': (reachable f)!!pc' = true). + eapply reachable_successors; eauto. + unfold successors; rewrite H; auto with coqlib. + assert (VALID: valid_successor f pc'). inv WTI; auto. + econstructor; split. + apply plus_one. eapply exec_Lcall with (f' := transf_fundef f'); eauto. + apply find_function_translated; auto. + symmetry; apply sig_preserved. + econstructor; eauto. + constructor; auto. econstructor; eauto. + eapply is_tail_add_branch. eapply is_tail_cons_left. + eapply is_tail_find_label. eauto. + destruct ros; simpl in H0. + eapply Genv.find_funct_prop; eauto. + destruct (Genv.find_symbol ge i); try discriminate. + eapply Genv.find_funct_ptr_prop; eauto. + + (* Ltailcall *) + unfold rs2, rs1 in *. inv MS. fold rs1; fold rs2. + destruct (find_label_lin_inv _ _ _ _ H REACH AT) as [c' EQ]. + simpl in EQ. subst c. + econstructor; split. + apply plus_one. eapply exec_Ltailcall with (f' := transf_fundef f'); eauto. + apply find_function_translated; auto. + symmetry; apply sig_preserved. + rewrite (parent_locset_match _ _ STACKS). + econstructor; eauto. + destruct ros; simpl in H0. + eapply Genv.find_funct_prop; eauto. + destruct (Genv.find_symbol ge i); try discriminate. + eapply Genv.find_funct_ptr_prop; eauto. + + (* Lalloc *) + destruct (find_label_lin_inv _ _ _ _ H REACH AT) as [c' EQ]. + simpl in EQ. subst c. + assert (REACH': (reachable f)!!pc' = true). + eapply reachable_successors; eauto. + unfold successors; rewrite H; auto with coqlib. + exploit find_label_lin_succ; eauto. inv WTI; auto. intros [c'' AT']. + econstructor; split. + eapply plus_left'. + eapply exec_Lalloc; eauto. + eapply add_branch_correct; eauto. + eapply is_tail_add_branch. eapply is_tail_cons_left. + eapply is_tail_find_label. eauto. + traceEq. + econstructor; eauto. + (* Lcond true *) + destruct (find_label_lin_inv _ _ _ _ H REACH AT) as [c' EQ]. + simpl in EQ. subst c. + assert (REACH': (reachable f)!!ifso = true). + eapply reachable_successors; eauto. + unfold successors; rewrite H; auto with coqlib. + exploit find_label_lin_succ; eauto. inv WTI; auto. intros [c'' AT']. + destruct (starts_with ifso c'). + econstructor; split. + eapply plus_left'. + eapply exec_Lcond_false; eauto. + change false with (negb true). apply eval_negate_condition; auto. + eapply add_branch_correct; eauto. + eapply is_tail_add_branch. eapply is_tail_cons_left. + eapply is_tail_find_label. eauto. + traceEq. + econstructor; eauto. + econstructor; split. + apply plus_one. eapply exec_Lcond_true; eauto. + econstructor; eauto. + (* Lcond false *) + destruct (find_label_lin_inv _ _ _ _ H REACH AT) as [c' EQ]. + simpl in EQ. subst c. + assert (REACH': (reachable f)!!ifnot = true). + eapply reachable_successors; eauto. + unfold successors; rewrite H; auto with coqlib. + exploit find_label_lin_succ; eauto. inv WTI; auto. intros [c'' AT']. + destruct (starts_with ifso c'). + econstructor; split. + apply plus_one. eapply exec_Lcond_true; eauto. + change true with (negb false). apply eval_negate_condition; auto. + econstructor; eauto. + econstructor; split. + eapply plus_left'. + eapply exec_Lcond_false; eauto. + eapply add_branch_correct; eauto. + eapply is_tail_add_branch. eapply is_tail_cons_left. + eapply is_tail_find_label. eauto. + traceEq. + econstructor; eauto. + (* Lreturn *) + destruct (find_label_lin_inv _ _ _ _ H REACH AT) as [c' EQ]. + simpl in EQ. subst c. + econstructor; split. + apply plus_one. eapply exec_Lreturn; eauto. + rewrite (parent_locset_match _ _ STACKS). + econstructor; eauto. + (* internal function *) + assert (REACH: (reachable f)!!(LTL.fn_entrypoint f) = true). apply reachable_entrypoint. - assert (VO2: valid_outcome f Return). simpl; auto. - assert (VO1: valid_outcome f (Cont (fn_entrypoint f))). - eapply exec_blocks_valid_outcome; eauto. - assert (exists k, fn_code (linearize_function f) = Llabel f.(fn_entrypoint) :: k). - unfold linearize_function; simpl. - elim (enumerate_head f). intros tl EN. rewrite EN. - simpl. elim VO1. intros REACH [b EQ]. rewrite EQ. - exists (linearize_block b (linearize_body f tl)). auto. - elim H2; intros k EQ. - assert (find_label (fn_entrypoint f) (fn_code (linearize_function f)) = - Some k). - rewrite EQ. simpl. rewrite peq_true. auto. - generalize (H1 f k (refl_equal _) REACH0 H3 VO2). - intros [k' [EX CO]]. - inversion CO. subst k'. - unfold transf_function. apply cleanup_function_correct. - econstructor. eauto. rewrite EQ. eapply exec_trans. - apply exec_one. constructor. eauto. traceEq. - apply unique_labels_lin_function. + inv H6. + exploit find_label_lin_succ; eauto. inv H1; auto. intros [c'' AT']. + simpl. econstructor; split. + eapply plus_left'. + eapply exec_function_internal; eauto. + simpl. eapply add_branch_correct. + simpl. eapply is_tail_add_branch. constructor. eauto. + traceEq. + econstructor; eauto. (* external function *) + simpl. econstructor; split. + apply plus_one. eapply exec_function_external; eauto. + econstructor; eauto. + (* return *) + inv H4. inv H1. + exploit find_label_lin_succ; eauto. intros [c' AT]. + econstructor; split. + eapply plus_left'. + eapply exec_return; eauto. + eapply add_branch_correct; eauto. traceEq. econstructor; eauto. Qed. -End LINEARIZATION. +Lemma transf_initial_states: + forall st1, LTL.initial_state prog st1 -> + exists st2, LTLin.initial_state tprog st2 /\ match_states st1 st2. +Proof. + intros. inversion H. + exists (Callstate nil (transf_fundef f) (Locmap.init Vundef) (Genv.init_mem tprog)); split. + econstructor; eauto. + change (prog_main tprog) with (prog_main prog). + rewrite symbols_preserved. eauto. + apply function_ptr_translated; auto. + rewrite <- H2. apply sig_preserved. + replace (Genv.init_mem tprog) with (Genv.init_mem prog). + constructor. constructor. + eapply Genv.find_funct_ptr_prop; eauto. + symmetry. unfold tprog, transf_program. apply Genv.init_mem_transf. +Qed. + +Lemma transf_final_states: + forall st1 st2 r, + match_states st1 st2 -> LTL.final_state st1 r -> LTLin.final_state st2 r. +Proof. + intros. inv H0. inv H. inv H6. constructor. auto. +Qed. Theorem transf_program_correct: - forall (p: LTL.program) (t: trace) (r: val), - LTL.exec_program p t r -> - Linear.exec_program (transf_program p) t r. + forall (beh: program_behavior), + LTL.exec_program prog beh -> LTLin.exec_program tprog beh. Proof. - intros p t r [b [f [ls [m [FIND1 [FIND2 [SIG [EX RES]]]]]]]]. - red. exists b; exists (transf_fundef f); exists ls; exists m. - split. change (prog_main (transf_program p)) with (prog_main p). - rewrite symbols_preserved; auto. - split. apply function_ptr_translated. auto. - split. generalize (sig_preserved f); congruence. - split. apply transf_function_correct. - unfold transf_program. rewrite Genv.init_mem_transf. auto. - rewrite sig_preserved. exact RES. + unfold LTL.exec_program, exec_program; intros. + eapply simulation_plus_preservation; eauto. + eexact transf_initial_states. + eexact transf_final_states. + eexact transf_step_correct. Qed. +End LINEARIZATION. diff --git a/backend/Linearizetyping.v b/backend/Linearizetyping.v index 66926e9a..c930ca52 100644 --- a/backend/Linearizetyping.v +++ b/backend/Linearizetyping.v @@ -6,327 +6,72 @@ Require Import AST. Require Import Op. Require Import Locations. Require Import LTL. -Require Import Linear. -Require Import Linearize. Require Import LTLtyping. -Require Import Lineartyping. +Require Import LTLin. +Require Import Linearize. +Require Import LTLintyping. Require Import Conventions. -(** * Validity of resource bounds *) - -(** In this section, we show that the resource bounds computed by - [function_bounds] are valid: all references to callee-save registers - and stack slots in the code of the function are within those bounds. *) - -Section BOUNDS. - -Variable f: Linear.function. -Let b := function_bounds f. - -Lemma max_over_list_bound: - forall (A: Set) (valu: A -> Z) (l: list A) (x: A), - In x l -> valu x <= max_over_list A valu l. -Proof. - intros until x. unfold max_over_list. - assert (forall c z, - let f := fold_left (fun x y => Zmax x (valu y)) c z in - z <= f /\ (In x c -> valu x <= f)). - induction c; simpl; intros. - split. omega. tauto. - elim (IHc (Zmax z (valu a))); intros. - split. apply Zle_trans with (Zmax z (valu a)). apply Zmax1. auto. - intro H1; elim H1; intro. - subst a. apply Zle_trans with (Zmax z (valu x)). - apply Zmax2. auto. auto. - intro. elim (H l 0); intros. auto. -Qed. - -Lemma max_over_instrs_bound: - forall (valu: instruction -> Z) i, - In i f.(fn_code) -> valu i <= max_over_instrs f valu. -Proof. - intros. unfold max_over_instrs. apply max_over_list_bound; auto. -Qed. - -Lemma max_over_regs_of_funct_bound: - forall (valu: mreg -> Z) i r, - In i f.(fn_code) -> In r (regs_of_instr i) -> - valu r <= max_over_regs_of_funct f valu. -Proof. - intros. unfold max_over_regs_of_funct. - apply Zle_trans with (max_over_regs_of_instr valu i). - unfold max_over_regs_of_instr. apply max_over_list_bound. auto. - apply max_over_instrs_bound. auto. -Qed. - -Lemma max_over_slots_of_funct_bound: - forall (valu: slot -> Z) i s, - In i f.(fn_code) -> In s (slots_of_instr i) -> - valu s <= max_over_slots_of_funct f valu. -Proof. - intros. unfold max_over_slots_of_funct. - apply Zle_trans with (max_over_slots_of_instr valu i). - unfold max_over_slots_of_instr. apply max_over_list_bound. auto. - apply max_over_instrs_bound. auto. -Qed. - -Lemma int_callee_save_bound: - forall i r, - In i f.(fn_code) -> In r (regs_of_instr i) -> - index_int_callee_save r < bound_int_callee_save b. -Proof. - intros. apply Zlt_le_trans with (int_callee_save r). - unfold int_callee_save. omega. - unfold b, function_bounds, bound_int_callee_save. - eapply max_over_regs_of_funct_bound; eauto. -Qed. - -Lemma float_callee_save_bound: - forall i r, - In i f.(fn_code) -> In r (regs_of_instr i) -> - index_float_callee_save r < bound_float_callee_save b. -Proof. - intros. apply Zlt_le_trans with (float_callee_save r). - unfold float_callee_save. omega. - unfold b, function_bounds, bound_float_callee_save. - eapply max_over_regs_of_funct_bound; eauto. -Qed. - -Lemma int_local_slot_bound: - forall i ofs, - In i f.(fn_code) -> In (Local ofs Tint) (slots_of_instr i) -> - ofs < bound_int_local b. -Proof. - intros. apply Zlt_le_trans with (int_local (Local ofs Tint)). - unfold int_local. omega. - unfold b, function_bounds, bound_int_local. - eapply max_over_slots_of_funct_bound; eauto. -Qed. - -Lemma float_local_slot_bound: - forall i ofs, - In i f.(fn_code) -> In (Local ofs Tfloat) (slots_of_instr i) -> - ofs < bound_float_local b. -Proof. - intros. apply Zlt_le_trans with (float_local (Local ofs Tfloat)). - unfold float_local. omega. - unfold b, function_bounds, bound_float_local. - eapply max_over_slots_of_funct_bound; eauto. -Qed. - -Lemma outgoing_slot_bound: - forall i ofs ty, - In i f.(fn_code) -> In (Outgoing ofs ty) (slots_of_instr i) -> - ofs + typesize ty <= bound_outgoing b. -Proof. - intros. change (ofs + typesize ty) with (outgoing_slot (Outgoing ofs ty)). - unfold b, function_bounds, bound_outgoing. - apply Zmax_bound_r. apply Zmax_bound_r. - eapply max_over_slots_of_funct_bound; eauto. -Qed. - -Lemma size_arguments_bound: - forall sig ros, - In (Lcall sig ros) f.(fn_code) -> - size_arguments sig <= bound_outgoing b. -Proof. - intros. change (size_arguments sig) with (outgoing_space (Lcall sig ros)). - unfold b, function_bounds, bound_outgoing. - apply Zmax_bound_r. apply Zmax_bound_l. - apply max_over_instrs_bound; auto. -Qed. - -End BOUNDS. - -(** Consequently, all machine registers or stack slots mentioned by one - of the instructions of function [f] are within bounds. *) - -Lemma mreg_is_bounded: - forall f i r, - In i f.(fn_code) -> In r (regs_of_instr i) -> - mreg_bounded f r. -Proof. - intros. unfold mreg_bounded. - case (mreg_type r). - eapply int_callee_save_bound; eauto. - eapply float_callee_save_bound; eauto. -Qed. - -Lemma slot_is_bounded: - forall f i s, - In i (transf_function f).(fn_code) -> In s (slots_of_instr i) -> - LTLtyping.slot_bounded f s -> - slot_bounded (transf_function f) s. -Proof. - intros. unfold slot_bounded. - destruct s. - destruct t. - split. exact H1. eapply int_local_slot_bound; eauto. - split. exact H1. eapply float_local_slot_bound; eauto. - unfold linearize_function; simpl. exact H1. - split. exact H1. eapply outgoing_slot_bound; eauto. -Qed. - -(** * Conservation property of the cleanup pass *) - -(** We show that the cleanup pass only deletes some [Lgoto] instructions: - all other instructions present in the output of naive linearization - are in the cleaned-up code, and all instructions in the cleaned-up code - are in the output of naive linearization. *) - -Lemma cleanup_code_conservation: - forall i, - match i with Lgoto _ => False | _ => True end -> - forall c, - In i c -> In i (cleanup_code c). -Proof. - induction c; simpl. - auto. - intro. - assert (In i (a :: cleanup_code c)). - elim H0; intro. subst i. auto with coqlib. - apply in_cons. auto. - destruct a; auto. - assert (In i (cleanup_code c)). - elim H1; intro. subst i. contradiction. auto. - case (starts_with l c). auto. apply in_cons; auto. -Qed. - -Lemma cleanup_function_conservation: - forall f i, - In i (linearize_function f).(fn_code) -> - match i with Lgoto _ => False | _ => True end -> - In i (transf_function f).(fn_code). -Proof. - intros. unfold transf_function. unfold cleanup_function. - simpl. simpl in H0. eapply cleanup_code_conservation; eauto. -Qed. - -Lemma cleanup_code_conservation_2: - forall i c, In i (cleanup_code c) -> In i c. -Proof. - induction c; simpl. - auto. - assert (In i (a :: cleanup_code c) -> a = i \/ In i c). - intro. elim H; tauto. - destruct a; auto. - case (starts_with l c). auto. auto. -Qed. +(** * Type preservation for the linearization pass *) -Lemma cleanup_function_conservation_2: - forall f i, - In i (transf_function f).(fn_code) -> - In i (linearize_function f).(fn_code). +Lemma wt_add_instr: + forall f i k, wt_instr f i -> wt_code f k -> wt_code f (i :: k). Proof. - simpl. intros. eapply cleanup_code_conservation_2; eauto. + intros; red; intros. elim H1; intro. subst i0; auto. auto. Qed. -(** * Type preservation for the linearization pass *) - -Lemma linearize_block_incl: - forall k b, incl k (linearize_block b k). +Lemma wt_add_branch: + forall f s k, wt_code f k -> wt_code f (add_branch s k). Proof. - induction b; simpl; auto with coqlib. - case (starts_with n k); auto with coqlib. + intros; unfold add_branch. destruct (starts_with s k). + auto. apply wt_add_instr; auto. constructor. Qed. -Lemma wt_linearize_block: - forall f k, - (forall i, In i k -> wt_instr (transf_function f) i) -> - forall b i, - wt_block f b -> - incl (linearize_block b k) (linearize_function f).(fn_code) -> - In i (linearize_block b k) -> wt_instr (transf_function f) i. +Lemma wt_linearize_instr: + forall f instr, + LTLtyping.wt_instr f instr -> + forall k, + wt_code f.(LTL.fn_sig) k -> + wt_code f.(LTL.fn_sig) (linearize_instr instr k). Proof. - induction b; simpl; intros; - try (generalize (cleanup_function_conservation - _ _ (H1 _ (in_eq _ _)) I)); - inversion H0; - try (elim H2; intro; [subst i|eauto with coqlib]); - intros. - (* getstack *) - constructor. auto. eapply slot_is_bounded; eauto. - simpl; auto with coqlib. - eapply mreg_is_bounded; eauto. - simpl; auto with coqlib. - (* setstack *) - constructor. auto. auto. - eapply slot_is_bounded; eauto. - simpl; auto with coqlib. - (* move *) - subst o; subst l. constructor. auto. - eapply mreg_is_bounded; eauto. - simpl; auto with coqlib. - (* undef *) - subst o; subst l. constructor. - eapply mreg_is_bounded; eauto. - simpl; auto with coqlib. - (* other ops *) - constructor; auto. - eapply mreg_is_bounded; eauto. - simpl; auto with coqlib. - (* load *) - constructor; auto. - eapply mreg_is_bounded; eauto. - simpl; auto with coqlib. - (* store *) - constructor; auto. - (* call *) - constructor; auto. - eapply size_arguments_bound; eauto. - (* alloc *) - constructor. - (* goto *) - constructor. - (* cond *) - destruct (starts_with n k). - elim H2; intro. - subst i. constructor. - rewrite H4. destruct c; reflexivity. - elim H8; intro. - subst i. constructor. - eauto with coqlib. - elim H2; intro. - subst i. constructor. auto. - elim H8; intro. - subst i. constructor. - eauto with coqlib. - (* return *) - constructor. + induction 1; simpl; intros. + apply wt_add_branch; auto. + apply wt_add_instr. constructor; auto. apply wt_add_branch; auto. + apply wt_add_instr. constructor; auto. apply wt_add_branch; auto. + apply wt_add_instr. constructor; auto. apply wt_add_branch; auto. + apply wt_add_instr. constructor; auto. apply wt_add_branch; auto. + apply wt_add_instr. constructor; auto. apply wt_add_branch; auto. + apply wt_add_instr. constructor; auto. auto. + apply wt_add_instr. constructor; auto. apply wt_add_branch; auto. + destruct (starts_with s1 k); apply wt_add_instr. + constructor; auto. rewrite H. destruct cond; auto. + apply wt_add_branch; auto. + constructor; auto. apply wt_add_branch; auto. + apply wt_add_instr. constructor; auto. auto. Qed. Lemma wt_linearize_body: forall f, - LTLtyping.wt_function f -> - forall enum i, - incl (linearize_body f enum) (linearize_function f).(fn_code) -> - In i (linearize_body f enum) -> wt_instr (transf_function f) i. -Proof. - induction enum. - simpl; intros; contradiction. - intro i. simpl. - caseEq (LTL.fn_code f)!a. intros b EQ INCL IN. - elim IN; intro. subst i; constructor. - apply wt_linearize_block with (linearize_body f enum) b. - intros; apply IHenum. - apply incl_tran with (linearize_block b (linearize_body f enum)). - apply linearize_block_incl. - eauto with coqlib. - auto. - eapply H; eauto. - eauto with coqlib. auto. + (forall pc instr, + f.(LTL.fn_code)!pc = Some instr -> LTLtyping.wt_instr f instr) -> + forall enum, + wt_code f.(LTL.fn_sig) (linearize_body f enum). +Proof. + induction enum; simpl. + red; simpl; intros; contradiction. + caseEq ((LTL.fn_code f)!a); intros. + apply wt_add_instr. constructor. apply wt_linearize_instr; eauto with coqlib. auto. -Qed. +Qed. Lemma wt_transf_function: forall f, LTLtyping.wt_function f -> wt_function (transf_function f). Proof. - intros; red; intros. - apply wt_linearize_body with (enumerate f); auto. - simpl. apply incl_refl. - apply cleanup_function_conservation_2; auto. + intros. inv H. constructor; auto. + simpl. apply wt_add_branch. + apply wt_linearize_body. auto. Qed. Lemma wt_transf_fundef: @@ -342,7 +87,7 @@ Qed. Lemma program_typing_preserved: forall (p: LTL.program), LTLtyping.wt_program p -> - Lineartyping.wt_program (transf_program p). + LTLintyping.wt_program (transf_program p). Proof. intros; red; intros. generalize (transform_program_function transf_fundef p i f H0). diff --git a/backend/Lineartyping.v b/backend/Lineartyping.v index cbe18311..baf522aa 100644 --- a/backend/Lineartyping.v +++ b/backend/Lineartyping.v @@ -1,4 +1,4 @@ -(** Typing rules and computation of stack bounds for Linear. *) +(** Typing rules for Linear. *) Require Import Coqlib. Require Import Maps. @@ -9,218 +9,55 @@ Require Import Locations. Require Import Linear. Require Import Conventions. -(** * Resource bounds for a function *) - -(** The [bounds] record capture how many local and outgoing stack slots - and callee-save registers are used by a function. *) - -Record bounds : Set := mkbounds { - bound_int_local: Z; - bound_float_local: Z; - bound_int_callee_save: Z; - bound_float_callee_save: Z; - bound_outgoing: Z -}. - -(** The resource bounds for a function are computed by a linear scan - of its instructions. *) - -Section BOUNDS. - -Variable f: function. - -Definition regs_of_instr (i: instruction) : list mreg := - match i with - | Lgetstack s r => r :: nil - | Lsetstack r s => r :: nil - | Lop op args res => res :: args - | Lload chunk addr args dst => dst :: args - | Lstore chunk addr args src => src :: args - | Lcall sig (inl fn) => fn :: nil - | Lcall sig (inr _) => nil - | Lalloc => nil - | Llabel lbl => nil - | Lgoto lbl => nil - | Lcond cond args lbl => args - | Lreturn => nil - end. - -Definition slots_of_instr (i: instruction) : list slot := - match i with - | Lgetstack s r => s :: nil - | Lsetstack r s => s :: nil - | _ => nil - end. - -Definition max_over_list (A: Set) (valu: A -> Z) (l: list A) : Z := - List.fold_left (fun m l => Zmax m (valu l)) l 0. - -Definition max_over_instrs (valu: instruction -> Z) : Z := - max_over_list instruction valu f.(fn_code). - -Definition max_over_regs_of_instr (valu: mreg -> Z) (i: instruction) : Z := - max_over_list mreg valu (regs_of_instr i). - -Definition max_over_slots_of_instr (valu: slot -> Z) (i: instruction) : Z := - max_over_list slot valu (slots_of_instr i). - -Definition max_over_regs_of_funct (valu: mreg -> Z) : Z := - max_over_instrs (max_over_regs_of_instr valu). - -Definition max_over_slots_of_funct (valu: slot -> Z) : Z := - max_over_instrs (max_over_slots_of_instr valu). - -Definition int_callee_save (r: mreg) := 1 + index_int_callee_save r. - -Definition float_callee_save (r: mreg) := 1 + index_float_callee_save r. - -Definition int_local (s: slot) := - match s with Local ofs Tint => 1 + ofs | _ => 0 end. - -Definition float_local (s: slot) := - match s with Local ofs Tfloat => 1 + ofs | _ => 0 end. - -Definition outgoing_slot (s: slot) := - match s with Outgoing ofs ty => ofs + typesize ty | _ => 0 end. - -Definition outgoing_space (i: instruction) := - match i with Lcall sig _ => size_arguments sig | _ => 0 end. - -Definition function_bounds := - mkbounds - (max_over_slots_of_funct int_local) - (max_over_slots_of_funct float_local) - (max_over_regs_of_funct int_callee_save) - (max_over_regs_of_funct float_callee_save) - (Zmax 6 - (Zmax (max_over_instrs outgoing_space) - (max_over_slots_of_funct outgoing_slot))). - -(** We show that bounds computed by [function_bounds] are all positive - or null, and moreover [bound_outgoing] is greater or equal to 6. - These properties are used later to reason about the layout of - the activation record. *) - -Lemma max_over_list_pos: - forall (A: Set) (valu: A -> Z) (l: list A), - max_over_list A valu l >= 0. -Proof. - intros until valu. unfold max_over_list. - assert (forall l z, fold_left (fun x y => Zmax x (valu y)) l z >= z). - induction l; simpl; intros. - omega. apply Zge_trans with (Zmax z (valu a)). - auto. apply Zle_ge. apply Zmax1. auto. -Qed. - -Lemma max_over_slots_of_funct_pos: - forall (valu: slot -> Z), max_over_slots_of_funct valu >= 0. -Proof. - intros. unfold max_over_slots_of_funct. - unfold max_over_instrs. apply max_over_list_pos. -Qed. - -Lemma max_over_regs_of_funct_pos: - forall (valu: mreg -> Z), max_over_regs_of_funct valu >= 0. -Proof. - intros. unfold max_over_regs_of_funct. - unfold max_over_instrs. apply max_over_list_pos. -Qed. - -Lemma bound_int_local_pos: - bound_int_local function_bounds >= 0. -Proof. - simpl. apply max_over_slots_of_funct_pos. -Qed. - -Lemma bound_float_local_pos: - bound_float_local function_bounds >= 0. -Proof. - simpl. apply max_over_slots_of_funct_pos. -Qed. - -Lemma bound_int_callee_save_pos: - bound_int_callee_save function_bounds >= 0. -Proof. - simpl. apply max_over_regs_of_funct_pos. -Qed. - -Lemma bound_float_callee_save_pos: - bound_float_callee_save function_bounds >= 0. -Proof. - simpl. apply max_over_regs_of_funct_pos. -Qed. - -Lemma bound_outgoing_pos: - bound_outgoing function_bounds >= 6. -Proof. - simpl. apply Zle_ge. apply Zmax_bound_l. omega. -Qed. - -End BOUNDS. - -(** * Typing rules for Linear *) - -(** The typing rules for Linear are similar to those for LTL: we check +(** The typing rules for Linear are similar to those for LTLin: we check that instructions receive the right number of arguments, and that the types of the argument and result registers agree - with what the instruction expects. Moreover, we state that references - to callee-save registers and to stack slots are within the bounds - computed by [function_bounds]. This is true by construction of - [function_bounds], and is proved in [Linearizetyping], but it - is convenient to integrate this property within the typing judgement. -*) + with what the instruction expects. Moreover, we also + enforces some correctness conditions on the offsets of stack slots + accessed through [Lgetstack] and [Lsetstack] Linear instructions. *) Section WT_INSTR. Variable funct: function. -Let b := function_bounds funct. -Definition mreg_bounded (r: mreg) := - match mreg_type r with - | Tint => index_int_callee_save r < bound_int_callee_save b - | Tfloat => index_float_callee_save r < bound_float_callee_save b +Definition slot_valid (s: slot) := + match s with + | Local ofs ty => 0 <= ofs + | Outgoing ofs ty => 14 <= ofs + | Incoming ofs ty => 14 <= ofs /\ ofs + typesize ty <= size_arguments funct.(fn_sig) end. -Definition slot_bounded (s: slot) := +Definition slot_writable (s: slot) := match s with - | Local ofs Tint => 0 <= ofs < bound_int_local b - | Local ofs Tfloat => 0 <= ofs < bound_float_local b - | Outgoing ofs ty => 6 <= ofs /\ ofs + typesize ty <= bound_outgoing b - | Incoming ofs ty => 6 <= ofs /\ ofs + typesize ty <= size_arguments funct.(fn_sig) + | Local ofs ty => True + | Outgoing ofs ty => True + | Incoming ofs ty => False end. Inductive wt_instr : instruction -> Prop := | wt_Lgetstack: forall s r, slot_type s = mreg_type r -> - slot_bounded s -> mreg_bounded r -> + slot_valid s -> wt_instr (Lgetstack s r) | wt_Lsetstack: forall s r, - match s with Incoming _ _ => False | _ => True end -> slot_type s = mreg_type r -> - slot_bounded s -> + slot_valid s -> slot_writable s -> wt_instr (Lsetstack r s) | wt_Lopmove: forall r1 r, mreg_type r1 = mreg_type r -> - mreg_bounded r -> wt_instr (Lop Omove (r1 :: nil) r) - | wt_Lopundef: - forall r, - mreg_bounded r -> - wt_instr (Lop Oundef nil r) | wt_Lop: forall op args res, - op <> Omove -> op <> Oundef -> + op <> Omove -> (List.map mreg_type args, mreg_type res) = type_of_operation op -> - mreg_bounded res -> wt_instr (Lop op args res) | wt_Lload: forall chunk addr args dst, List.map mreg_type args = type_of_addressing addr -> mreg_type dst = type_of_chunk chunk -> - mreg_bounded dst -> wt_instr (Lload chunk addr args dst) | wt_Lstore: forall chunk addr args src, @@ -229,9 +66,13 @@ Inductive wt_instr : instruction -> Prop := wt_instr (Lstore chunk addr args src) | wt_Lcall: forall sig ros, - size_arguments sig <= bound_outgoing b -> match ros with inl r => mreg_type r = Tint | _ => True end -> wt_instr (Lcall sig ros) + | wt_Ltailcall: + forall sig ros, + tailcall_possible sig -> + match ros with inl r => r = IT3 | _ => True end -> + wt_instr (Ltailcall sig ros) | wt_Lalloc: wt_instr Lalloc | wt_Llabel: @@ -249,8 +90,11 @@ Inductive wt_instr : instruction -> Prop := End WT_INSTR. +Definition wt_code (f: function) (c: code) : Prop := + forall instr, In instr c -> wt_instr f instr. + Definition wt_function (f: function) : Prop := - forall instr, In instr f.(fn_code) -> wt_instr f instr. + wt_code f f.(fn_code). Inductive wt_fundef: fundef -> Prop := | wt_fundef_external: forall ef, diff --git a/backend/Locations.v b/backend/Locations.v index c97855ea..aaefc08c 100644 --- a/backend/Locations.v +++ b/backend/Locations.v @@ -434,7 +434,7 @@ End Loc. (** The [Locmap] module defines mappings from locations to values, used as evaluation environments for the semantics of the [LTL] - and [Linear] intermediate languages. *) + and [LTLin] intermediate languages. *) Set Implicit Arguments. diff --git a/backend/Mach.v b/backend/Mach.v index f61620d1..05805ec5 100644 --- a/backend/Mach.v +++ b/backend/Mach.v @@ -1,7 +1,8 @@ -(** The Mach intermediate language: abstract syntax and semantics. +(** The Mach intermediate language: abstract syntax. Mach is the last intermediate language before generation of assembly - code. + code. This file defines the abstract syntax for Mach; two dynamic + semantics are given in modules [Machabstr] and [Machconcr]. *) Require Import Coqlib. @@ -14,7 +15,6 @@ Require Import Events. Require Import Globalenvs. Require Import Op. Require Import Locations. -Require Conventions. (** * Abstract syntax *) @@ -30,8 +30,8 @@ Require Conventions. the caller. These instructions implement a more concrete view of the activation - record than the the [Bgetstack] and [Bsetstack] instructions of - Linear: actual offsets are used instead of abstract stack slots; the + record than the the [Lgetstack] and [Lsetstack] instructions of + Linear: actual offsets are used instead of abstract stack slots, and the distinction between the caller's frame and the callee's frame is made explicit. *) @@ -45,6 +45,7 @@ Inductive instruction: Set := | Mload: memory_chunk -> addressing -> list mreg -> mreg -> instruction | Mstore: memory_chunk -> addressing -> list mreg -> mreg -> instruction | Mcall: signature -> mreg + ident -> instruction + | Mtailcall: signature -> mreg + ident -> instruction | Malloc: instruction | Mlabel: label -> instruction | Mgoto: label -> instruction @@ -105,238 +106,25 @@ Fixpoint find_label (lbl: label) (c: code) {struct c} : option code := | i1 :: il => if is_label lbl i1 then Some il else find_label lbl il end. -(** The three stack-related Mach instructions are interpreted as - memory accesses relative to the stack pointer. More precisely: -- [Mgetstack ofs ty r] is a memory load at offset [ofs * 4] relative - to the stack pointer. -- [Msetstack r ofs ty] is a memory store at offset [ofs * 4] relative - to the stack pointer. -- [Mgetparam ofs ty r] is a memory load at offset [ofs * 4] - relative to the pointer found at offset 0 from the stack pointer. - The semantics maintain a linked structure of activation records, - with the current record containing a pointer to the record of the - caller function at offset 0. *) - -Definition chunk_of_type (ty: typ) := - match ty with Tint => Mint32 | Tfloat => Mfloat64 end. - -Definition load_stack (m: mem) (sp: val) (ty: typ) (ofs: int) := - Mem.loadv (chunk_of_type ty) m (Val.add sp (Vint ofs)). - -Definition store_stack (m: mem) (sp: val) (ty: typ) (ofs: int) (v: val) := - Mem.storev (chunk_of_type ty) m (Val.add sp (Vint ofs)) v. - -Definition align_16_top (lo hi: Z) := - Zmax 0 (((hi - lo + 15) / 16) * 16 + lo). - -Section RELSEM. - -Variable ge: genv. +Lemma find_label_incl: + forall lbl c c', find_label lbl c = Some c' -> incl c' c. +Proof. + induction c; simpl; intros. discriminate. + destruct (is_label lbl a). inv H. auto with coqlib. eauto with coqlib. +Qed. -Definition find_function (ros: mreg + ident) (rs: regset) : option fundef := +Definition find_function_ptr + (ge: genv) (ros: mreg + ident) (rs: regset) : option block := match ros with - | inl r => Genv.find_funct ge (rs r) - | inr symb => - match Genv.find_symbol ge symb with - | None => None - | Some b => Genv.find_funct_ptr ge b + | inl r => + match rs r with + | Vptr b ofs => if Int.eq ofs Int.zero then Some b else None + | _ => None end + | inr symb => + Genv.find_symbol ge symb end. -(** Extract the values of the arguments of an external call. *) - -Inductive extcall_arg: regset -> mem -> val -> loc -> val -> Prop := - | extcall_arg_reg: forall rs m sp r, - extcall_arg rs m sp (R r) (rs r) - | extcall_arg_stack: forall rs m sp ofs ty v, - load_stack m sp ty (Int.repr (4 * ofs)) = Some v -> - extcall_arg rs m sp (S (Outgoing ofs ty)) v. - -Inductive extcall_args: regset -> mem -> val -> list loc -> list val -> Prop := - | extcall_args_nil: forall rs m sp, - extcall_args rs m sp nil nil - | extcall_args_cons: forall rs m sp l1 ll v1 vl, - extcall_arg rs m sp l1 v1 -> extcall_args rs m sp ll vl -> - extcall_args rs m sp (l1 :: ll) (v1 :: vl). - -Definition extcall_arguments - (rs: regset) (m: mem) (sp: val) (sg: signature) (args: list val) : Prop := - extcall_args rs m sp (Conventions.loc_arguments sg) args. - -(** [exec_instr ge f sp c rs m c' rs' m'] reflects the execution of - the first instruction in the current instruction sequence [c]. - [c'] is the current instruction sequence after this execution. - [rs] and [rs'] map machine registers to values, respectively - before and after instruction execution. [m] and [m'] are the - memory states before and after. *) - -Inductive exec_instr: - function -> val -> - code -> regset -> mem -> trace -> - code -> regset -> mem -> Prop := - | exec_Mlabel: - forall f sp lbl c rs m, - exec_instr f sp - (Mlabel lbl :: c) rs m - E0 c rs m - | exec_Mgetstack: - forall f sp ofs ty dst c rs m v, - load_stack m sp ty ofs = Some v -> - exec_instr f sp - (Mgetstack ofs ty dst :: c) rs m - E0 c (rs#dst <- v) m - | exec_Msetstack: - forall f sp src ofs ty c rs m m', - store_stack m sp ty ofs (rs src) = Some m' -> - exec_instr f sp - (Msetstack src ofs ty :: c) rs m - E0 c rs m' - | exec_Mgetparam: - forall f sp parent ofs ty dst c rs m v, - load_stack m sp Tint (Int.repr 0) = Some parent -> - load_stack m parent ty ofs = Some v -> - exec_instr f sp - (Mgetparam ofs ty dst :: c) rs m - E0 c (rs#dst <- v) m - | exec_Mop: - forall f sp op args res c rs m v, - eval_operation ge sp op rs##args = Some v -> - exec_instr f sp - (Mop op args res :: c) rs m - E0 c (rs#res <- v) m - | exec_Mload: - forall f sp chunk addr args dst c rs m a v, - eval_addressing ge sp addr rs##args = Some a -> - Mem.loadv chunk m a = Some v -> - exec_instr f sp - (Mload chunk addr args dst :: c) rs m - E0 c (rs#dst <- v) m - | exec_Mstore: - forall f sp chunk addr args src c rs m m' a, - eval_addressing ge sp addr rs##args = Some a -> - Mem.storev chunk m a (rs src) = Some m' -> - exec_instr f sp - (Mstore chunk addr args src :: c) rs m - E0 c rs m' - | exec_Mcall: - forall f sp sig ros c rs m f' t rs' m', - find_function ros rs = Some f' -> - exec_function f' sp rs m t rs' m' -> - exec_instr f sp - (Mcall sig ros :: c) rs m - t c rs' m' - | exec_Malloc: - forall f sp c rs m sz m' blk, - rs (Conventions.loc_alloc_argument) = Vint sz -> - Mem.alloc m 0 (Int.signed sz) = (m', blk) -> - exec_instr f sp - (Malloc :: c) rs m - E0 c (rs#Conventions.loc_alloc_result <- - (Vptr blk Int.zero)) m' - | exec_Mgoto: - forall f sp lbl c rs m c', - find_label lbl f.(fn_code) = Some c' -> - exec_instr f sp - (Mgoto lbl :: c) rs m - E0 c' rs m - | exec_Mcond_true: - forall f sp cond args lbl c rs m c', - eval_condition cond rs##args = Some true -> - find_label lbl f.(fn_code) = Some c' -> - exec_instr f sp - (Mcond cond args lbl :: c) rs m - E0 c' rs m - | exec_Mcond_false: - forall f sp cond args lbl c rs m, - eval_condition cond rs##args = Some false -> - exec_instr f sp - (Mcond cond args lbl :: c) rs m - E0 c rs m - -with exec_instrs: - function -> val -> - code -> regset -> mem -> trace -> - code -> regset -> mem -> Prop := - | exec_refl: - forall f sp c rs m, - exec_instrs f sp c rs m E0 c rs m - | exec_one: - forall f sp c rs m t c' rs' m', - exec_instr f sp c rs m t c' rs' m' -> - exec_instrs f sp c rs m t c' rs' m' - | exec_trans: - forall f sp c1 rs1 m1 t1 c2 rs2 m2 t2 c3 rs3 m3 t3, - exec_instrs f sp c1 rs1 m1 t1 c2 rs2 m2 -> - exec_instrs f sp c2 rs2 m2 t2 c3 rs3 m3 -> - t3 = t1 ** t2 -> - exec_instrs f sp c1 rs1 m1 t3 c3 rs3 m3 - -(** In addition to reserving the word at offset 0 in the activation - record for maintaining the linking of activation records, - we need to reserve the word at offset 12 to store the return address - into the caller. However, the return address (a pointer within - the code of the caller) is not precisely known at this point: - it will be determined only after the final translation to PowerPC - assembly code. Therefore, we simply reserve that word in the strongest - sense of the word ``reserve'': we make sure that whatever pointer - is stored there at function entry keeps the same value until the - final return instruction, and that the return value and final memory - state are the same regardless of the return address. - This is captured in the evaluation rule [exec_function] - that quantifies universally over all possible values of the return - address, and pass this value to [exec_function_body]. In other - terms, the inference rule [exec_function] has an infinity of - premises, one for each possible return address. Such infinitely - branching inference rules are uncommon in operational semantics, - but cause no difficulties in Coq. *) - -with exec_function_body: - function -> val -> val -> - regset -> mem -> trace -> regset -> mem -> Prop := - | exec_funct_body: - forall f parent ra rs m t rs' m1 m2 m3 m4 stk c, - Mem.alloc m (- f.(fn_framesize)) - (align_16_top (- f.(fn_framesize)) f.(fn_stacksize)) - = (m1, stk) -> - let sp := Vptr stk (Int.repr (-f.(fn_framesize))) in - store_stack m1 sp Tint (Int.repr 0) parent = Some m2 -> - store_stack m2 sp Tint (Int.repr 12) ra = Some m3 -> - exec_instrs f sp - f.(fn_code) rs m3 - t (Mreturn :: c) rs' m4 -> - load_stack m4 sp Tint (Int.repr 0) = Some parent -> - load_stack m4 sp Tint (Int.repr 12) = Some ra -> - exec_function_body f parent ra rs m t rs' (Mem.free m4 stk) - -with exec_function: - fundef -> val -> regset -> mem -> trace -> regset -> mem -> Prop := - | exec_funct_internal: - forall f parent rs m t rs' m', - (forall ra, - Val.has_type ra Tint -> - exec_function_body f parent ra rs m t rs' m') -> - exec_function (Internal f) parent rs m t rs' m' - | exec_funct_external: - forall ef parent args res rs1 rs2 m t, - event_match ef args t res -> - extcall_arguments rs1 m parent ef.(ef_sig) args -> - rs2 = (rs1#(Conventions.loc_result ef.(ef_sig)) <- res) -> - exec_function (External ef) parent rs1 m t rs2 m. - -Scheme exec_instr_ind4 := Minimality for exec_instr Sort Prop - with exec_instrs_ind4 := Minimality for exec_instrs Sort Prop - with exec_function_body_ind4 := Minimality for exec_function_body Sort Prop - with exec_function_ind4 := Minimality for exec_function Sort Prop. - -End RELSEM. - -Definition exec_program (p: program) (t: trace) (r: val) : Prop := - let ge := Genv.globalenv p in - let m0 := Genv.init_mem p in - exists b, exists f, exists rs, exists m, - Genv.find_symbol ge p.(prog_main) = Some b /\ - Genv.find_funct_ptr ge b = Some f /\ - exec_function ge f (Vptr Mem.nullptr Int.zero) (Regmap.init Vundef) m0 - t rs m /\ - rs R3 = r. +Definition align_16_top (lo hi: Z) := + Zmax 0 (((hi - lo + 15) / 16) * 16 + lo). diff --git a/backend/Machabstr.v b/backend/Machabstr.v index d83ffa51..ad4e8e1a 100644 --- a/backend/Machabstr.v +++ b/backend/Machabstr.v @@ -1,4 +1,4 @@ -(** Alternate semantics for the Mach intermediate language. *) +(** The Mach intermediate language: abstract semantics. *) Require Import Coqlib. Require Import Maps. @@ -9,37 +9,53 @@ Require Import Values. Require Import Mem. Require Import Events. Require Import Globalenvs. +Require Import Smallstep. Require Import Op. Require Import Locations. Require Conventions. Require Import Mach. -(** This file defines an alternate semantics for the Mach intermediate - language, which differ from the standard semantics given in file [Mach] - as follows: the stack access instructions [Mgetstack], [Msetstack] - and [Mgetparam] are interpreted not as memory accesses, but as - accesses in a frame environment, not resident in memory. The evaluation - relations take two such frame environments as parameters and results, - one for the current function and one for its caller. +(** This file defines the "abstract" semantics for the Mach + intermediate language, as opposed to the more concrete + semantics given in module [Machconcr]. + + The only difference with the concrete semantics is the interpretation + of the stack access instructions [Mgetstack], [Msetstack] and [Mgetparam]. + In the concrete semantics, these are interpreted as memory accesses + relative to the stack pointer. In the abstract semantics, these + instructions are interpreted as accesses in a frame environment, + not resident in memory. The frame environment is an additional + component of the state. Not having the frame data in memory facilitates the proof of the [Stacking] pass, which shows that the generated code executes - correctly with the alternate semantics. In file [Machabstr2mach], - we show an implication from this alternate semantics to - the standard semantics, thus establishing that the [Stacking] pass - generates code that behaves correctly against the standard [Mach] - semantics as well. *) + correctly with the abstract semantics. +*) (** * Structure of abstract stack frames *) -(** A frame has the same structure as the contents of a memory block. *) +(** An abstract stack frame comprises a low bound [fr_low] (the high bound + is implicitly 0) and a mapping from (type, offset) pairs to values. *) + +Record frame : Set := mkframe { + fr_low: Z; + fr_contents: typ -> Z -> val +}. -Definition frame := block_contents. +Definition typ_eq: forall (ty1 ty2: typ), {ty1=ty2} + {ty1<>ty2}. +Proof. decide equality. Defined. -Definition empty_frame := empty_block 0 0. +Definition update (ty: typ) (ofs: Z) (v: val) (f: frame) : frame := + mkframe f.(fr_low) + (fun ty' ofs' => + if zeq ofs ofs' then + if typ_eq ty ty' then v else Vundef + else + if zle (ofs' + AST.typesize ty') ofs then f.(fr_contents) ty' ofs' + else if zle (ofs + AST.typesize ty) ofs' then f.(fr_contents) ty' ofs' + else Vundef). -Definition mem_type (ty: typ) := - match ty with Tint => Size32 | Tfloat => Size64 end. +Definition empty_frame := mkframe 0 (fun ty ofs => Vundef). (** [get_slot fr ty ofs v] holds if the frame [fr] contains value [v] with type [ty] at word offset [ofs]. *) @@ -47,46 +63,24 @@ Definition mem_type (ty: typ) := Inductive get_slot: frame -> typ -> Z -> val -> Prop := | get_slot_intro: forall fr ty ofs v, - 0 <= ofs -> - fr.(low) + ofs + 4 * typesize ty <= 0 -> - v = load_contents (mem_type ty) fr.(contents) (fr.(low) + ofs) -> + 24 <= ofs -> + fr.(fr_low) + ofs + AST.typesize ty <= 0 -> + v = fr.(fr_contents) ty (fr.(fr_low) + ofs) -> get_slot fr ty ofs v. -Remark size_mem_type: - forall ty, size_mem (mem_type ty) = 4 * typesize ty. -Proof. - destruct ty; reflexivity. -Qed. - -Remark set_slot_undef_outside: - forall fr ty ofs v, - fr.(high) = 0 -> - 0 <= ofs -> - fr.(low) + ofs + 4 * typesize ty <= 0 -> - (forall x, x < fr.(low) \/ x >= fr.(high) -> fr.(contents) x = Undef) -> - (forall x, x < fr.(low) \/ x >= fr.(high) -> - store_contents (mem_type ty) fr.(contents) (fr.(low) + ofs) v x = Undef). -Proof. - intros. apply store_contents_undef_outside with fr.(low) fr.(high). - rewrite <- size_mem_type in H1. omega. assumption. assumption. -Qed. - (** [set_slot fr ty ofs v fr'] holds if frame [fr'] is obtained from frame [fr] by storing value [v] with type [ty] at word offset [ofs]. *) Inductive set_slot: frame -> typ -> Z -> val -> frame -> Prop := | set_slot_intro: - forall fr ty ofs v - (A: fr.(high) = 0) - (B: 0 <= ofs) - (C: fr.(low) + ofs + 4 * typesize ty <= 0), - set_slot fr ty ofs v - (mkblock fr.(low) fr.(high) - (store_contents (mem_type ty) fr.(contents) (fr.(low) + ofs) v) - (set_slot_undef_outside fr ty ofs v A B C fr.(undef_outside))). + forall fr ty ofs v fr', + 24 <= ofs -> + fr.(fr_low) + ofs + AST.typesize ty <= 0 -> + fr' = update ty (fr.(fr_low) + ofs) v fr -> + set_slot fr ty ofs v fr'. Definition init_frame (f: function) := - empty_block (- f.(fn_framesize)) 0. + mkframe (- f.(fn_framesize)) (fun ty ofs => Vundef). (** Extract the values of the arguments of an external call. *) @@ -108,320 +102,172 @@ Definition extcall_arguments (rs: regset) (fr: frame) (sg: signature) (args: list val) : Prop := extcall_args rs fr (Conventions.loc_arguments sg) args. +(** The components of an execution state are: + +- [State cs f sp c rs fr m]: [f] is the function currently executing. + [sp] is the stack pointer. [c] is the list of instructions that + remain to be executed. [rs] assigns values to registers. + [fr] is the current frame, as described above. [m] is the memory state. +- [Callstate cs f rs m]: [f] is the function definition being called. + [rs] is the current values of registers, + and [m] the current memory state. +- [Returnstate cs rs m]: [rs] is the current values of registers, + and [m] the current memory state. + +[cs] is a list of stack frames [Stackframe f sp c fr], +where [f] is the block reference for the calling function, +[c] the code within this function that follows the call instruction, +[sp] its stack pointer, and [fr] its private frame. *) + +Inductive stackframe: Set := + | Stackframe: + forall (f: function) (sp: val) (c: code) (fr: frame), + stackframe. + +Inductive state: Set := + | State: + forall (stack: list stackframe) (f: function) (sp: val) + (c: code) (rs: regset) (fr: frame) (m: mem), + state + | Callstate: + forall (stack: list stackframe) (f: fundef) (rs: regset) (m: mem), + state + | Returnstate: + forall (stack: list stackframe) (rs: regset) (m: mem), + state. + +(** [parent_frame s] returns the frame of the calling function. + It is used to access function parameters that are passed on the stack + (the [Mgetparent] instruction). *) + +Definition parent_frame (s: list stackframe) : frame := + match s with + | nil => empty_frame + | Stackframe f sp c fr :: s => fr + end. + Section RELSEM. Variable ge: genv. -(** Execution of one instruction has the form - [exec_instr ge f sp parent c rs fr m c' rs' fr' m'], - where [parent] is the caller's frame (read-only) - and [fr], [fr'] are the current frame, before and after execution - of one instruction. The other parameters are as in the Mach semantics. *) +Definition find_function (ros: mreg + ident) (rs: regset) : option fundef := + match ros with + | inl r => Genv.find_funct ge (rs r) + | inr symb => + match Genv.find_symbol ge symb with + | None => None + | Some b => Genv.find_funct_ptr ge b + end + end. -Inductive exec_instr: - function -> val -> frame -> - code -> regset -> frame -> mem -> trace -> - code -> regset -> frame -> mem -> Prop := +Inductive step: state -> trace -> state -> Prop := | exec_Mlabel: - forall f sp parent lbl c rs fr m, - exec_instr f sp parent - (Mlabel lbl :: c) rs fr m - E0 c rs fr m + forall s f sp lbl c rs fr m, + step (State s f sp (Mlabel lbl :: c) rs fr m) + E0 (State s f sp c rs fr m) | exec_Mgetstack: - forall f sp parent ofs ty dst c rs fr m v, + forall s f sp ofs ty dst c rs fr m v, get_slot fr ty (Int.signed ofs) v -> - exec_instr f sp parent - (Mgetstack ofs ty dst :: c) rs fr m - E0 c (rs#dst <- v) fr m + step (State s f sp (Mgetstack ofs ty dst :: c) rs fr m) + E0 (State s f sp c (rs#dst <- v) fr m) | exec_Msetstack: - forall f sp parent src ofs ty c rs fr m fr', + forall s f sp src ofs ty c rs fr m fr', set_slot fr ty (Int.signed ofs) (rs src) fr' -> - exec_instr f sp parent - (Msetstack src ofs ty :: c) rs fr m - E0 c rs fr' m + step (State s f sp (Msetstack src ofs ty :: c) rs fr m) + E0 (State s f sp c rs fr' m) | exec_Mgetparam: - forall f sp parent ofs ty dst c rs fr m v, - get_slot parent ty (Int.signed ofs) v -> - exec_instr f sp parent - (Mgetparam ofs ty dst :: c) rs fr m - E0 c (rs#dst <- v) fr m + forall s f sp ofs ty dst c rs fr m v, + get_slot (parent_frame s) ty (Int.signed ofs) v -> + step (State s f sp (Mgetparam ofs ty dst :: c) rs fr m) + E0 (State s f sp c (rs#dst <- v) fr m) | exec_Mop: - forall f sp parent op args res c rs fr m v, - eval_operation ge sp op rs##args = Some v -> - exec_instr f sp parent - (Mop op args res :: c) rs fr m - E0 c (rs#res <- v) fr m + forall s f sp op args res c rs fr m v, + eval_operation ge sp op rs##args m = Some v -> + step (State s f sp (Mop op args res :: c) rs fr m) + E0 (State s f sp c (rs#res <- v) fr m) | exec_Mload: - forall f sp parent chunk addr args dst c rs fr m a v, + forall s f sp chunk addr args dst c rs fr m a v, eval_addressing ge sp addr rs##args = Some a -> Mem.loadv chunk m a = Some v -> - exec_instr f sp parent - (Mload chunk addr args dst :: c) rs fr m - E0 c (rs#dst <- v) fr m + step (State s f sp (Mload chunk addr args dst :: c) rs fr m) + E0 (State s f sp c (rs#dst <- v) fr m) | exec_Mstore: - forall f sp parent chunk addr args src c rs fr m m' a, + forall s f sp chunk addr args src c rs fr m m' a, eval_addressing ge sp addr rs##args = Some a -> Mem.storev chunk m a (rs src) = Some m' -> - exec_instr f sp parent - (Mstore chunk addr args src :: c) rs fr m - E0 c rs fr m' + step (State s f sp (Mstore chunk addr args src :: c) rs fr m) + E0 (State s f sp c rs fr m') | exec_Mcall: - forall f sp parent sig ros c rs fr m t f' rs' m', - find_function ge ros rs = Some f' -> - exec_function f' fr rs m t rs' m' -> - exec_instr f sp parent - (Mcall sig ros :: c) rs fr m - t c rs' fr m' + forall s f sp sig ros c rs fr m f', + find_function ros rs = Some f' -> + step (State s f sp (Mcall sig ros :: c) rs fr m) + E0 (Callstate (Stackframe f sp c fr :: s) f' rs m) + | exec_Mtailcall: + forall s f stk soff sig ros c rs fr m f', + find_function ros rs = Some f' -> + step (State s f (Vptr stk soff) (Mtailcall sig ros :: c) rs fr m) + E0 (Callstate s f' rs (Mem.free m stk)) + | exec_Malloc: - forall f sp parent c rs fr m sz m' blk, + forall s f sp c rs fr m sz m' blk, rs (Conventions.loc_alloc_argument) = Vint sz -> Mem.alloc m 0 (Int.signed sz) = (m', blk) -> - exec_instr f sp parent - (Malloc :: c) rs fr m - E0 c (rs#Conventions.loc_alloc_result <- - (Vptr blk Int.zero)) fr m' + step (State s f sp (Malloc :: c) rs fr m) + E0 (State s f sp c + (rs#Conventions.loc_alloc_result <- (Vptr blk Int.zero)) + fr m') | exec_Mgoto: - forall f sp parent lbl c rs fr m c', + forall s f sp lbl c rs fr m c', find_label lbl f.(fn_code) = Some c' -> - exec_instr f sp parent - (Mgoto lbl :: c) rs fr m - E0 c' rs fr m + step (State s f sp (Mgoto lbl :: c) rs fr m) + E0 (State s f sp c' rs fr m) | exec_Mcond_true: - forall f sp parent cond args lbl c rs fr m c', - eval_condition cond rs##args = Some true -> + forall s f sp cond args lbl c rs fr m c', + eval_condition cond rs##args m = Some true -> find_label lbl f.(fn_code) = Some c' -> - exec_instr f sp parent - (Mcond cond args lbl :: c) rs fr m - E0 c' rs fr m + step (State s f sp (Mcond cond args lbl :: c) rs fr m) + E0 (State s f sp c' rs fr m) | exec_Mcond_false: - forall f sp parent cond args lbl c rs fr m, - eval_condition cond rs##args = Some false -> - exec_instr f sp parent - (Mcond cond args lbl :: c) rs fr m - E0 c rs fr m - -with exec_instrs: - function -> val -> frame -> - code -> regset -> frame -> mem -> trace -> - code -> regset -> frame -> mem -> Prop := - | exec_refl: - forall f sp parent c rs fr m, - exec_instrs f sp parent c rs fr m E0 c rs fr m - | exec_one: - forall f sp parent c rs fr m t c' rs' fr' m', - exec_instr f sp parent c rs fr m t c' rs' fr' m' -> - exec_instrs f sp parent c rs fr m t c' rs' fr' m' - | exec_trans: - forall f sp parent c1 rs1 fr1 m1 t1 c2 rs2 fr2 m2 t2 c3 rs3 fr3 m3 t3, - exec_instrs f sp parent c1 rs1 fr1 m1 t1 c2 rs2 fr2 m2 -> - exec_instrs f sp parent c2 rs2 fr2 m2 t2 c3 rs3 fr3 m3 -> - t3 = t1 ** t2 -> - exec_instrs f sp parent c1 rs1 fr1 m1 t3 c3 rs3 fr3 m3 - -with exec_function_body: - function -> frame -> val -> val -> - regset -> mem -> trace -> regset -> mem -> Prop := - | exec_funct_body: - forall f parent link ra rs m t rs' m1 m2 stk fr1 fr2 fr3 c, - Mem.alloc m 0 f.(fn_stacksize) = (m1, stk) -> - set_slot (init_frame f) Tint 0 link fr1 -> - set_slot fr1 Tint 12 ra fr2 -> - exec_instrs f (Vptr stk (Int.repr (-f.(fn_framesize)))) parent - f.(fn_code) rs fr2 m1 - t (Mreturn :: c) rs' fr3 m2 -> - exec_function_body f parent link ra rs m t rs' (Mem.free m2 stk) - -with exec_function: - fundef -> frame -> regset -> mem -> trace -> regset -> mem -> Prop := - | exec_funct_internal: - forall f parent rs m t rs' m', - (forall link ra, - Val.has_type link Tint -> - Val.has_type ra Tint -> - exec_function_body f parent link ra rs m t rs' m') -> - exec_function (Internal f) parent rs m t rs' m' - | exec_funct_external: - forall ef parent args res rs1 rs2 m t, + forall s f sp cond args lbl c rs fr m, + eval_condition cond rs##args m = Some false -> + step (State s f sp (Mcond cond args lbl :: c) rs fr m) + E0 (State s f sp c rs fr m) + | exec_Mreturn: + forall s f stk soff c rs fr m, + step (State s f (Vptr stk soff) (Mreturn :: c) rs fr m) + E0 (Returnstate s rs (Mem.free m stk)) + | exec_function_internal: + forall s f rs m m' stk, + Mem.alloc m 0 f.(fn_stacksize) = (m', stk) -> + step (Callstate s (Internal f) rs m) + E0 (State s f (Vptr stk (Int.repr (-f.(fn_framesize)))) + f.(fn_code) rs (init_frame f) m') + | exec_function_external: + forall s ef args res rs1 rs2 m t, event_match ef args t res -> - extcall_arguments rs1 parent ef.(ef_sig) args -> + extcall_arguments rs1 (parent_frame s) ef.(ef_sig) args -> rs2 = (rs1#(Conventions.loc_result ef.(ef_sig)) <- res) -> - exec_function (External ef) parent rs1 m t rs2 m. - -Scheme exec_instr_ind4 := Minimality for exec_instr Sort Prop - with exec_instrs_ind4 := Minimality for exec_instrs Sort Prop - with exec_function_body_ind4 := Minimality for exec_function_body Sort Prop - with exec_function_ind4 := Minimality for exec_function Sort Prop. - -(** Ugly mutual induction principle over evaluation derivations. - Coq is not able to generate it directly, even though it is - an immediate consequence of the 4 induction principles generated - by the [Scheme] command above. *) - -Lemma exec_mutual_induction: - forall - (P - P0 : function -> - val -> - frame -> - code -> - regset -> - frame -> - mem -> trace -> code -> regset -> frame -> mem -> Prop) - (P1 : function -> - frame -> - val -> val -> regset -> mem -> trace -> regset -> mem -> Prop) - (P2 : fundef -> - frame -> regset -> mem -> trace -> regset -> mem -> Prop), - (forall (f : function) (sp : val) (parent : frame) (lbl : label) - (c : list instruction) (rs : regset) (fr : frame) (m : mem), - P f sp parent (Mlabel lbl :: c) rs fr m E0 c rs fr m) -> - (forall (f0 : function) (sp : val) (parent : frame) (ofs : int) - (ty : typ) (dst : mreg) (c : list instruction) (rs : regset) - (fr : frame) (m : mem) (v : val), - get_slot fr ty (Int.signed ofs) v -> - P f0 sp parent (Mgetstack ofs ty dst :: c) rs fr m E0 c rs # dst <- v - fr m) -> - (forall (f1 : function) (sp : val) (parent : frame) (src : mreg) - (ofs : int) (ty : typ) (c : list instruction) (rs : mreg -> val) - (fr : frame) (m : mem) (fr' : frame), - set_slot fr ty (Int.signed ofs) (rs src) fr' -> - P f1 sp parent (Msetstack src ofs ty :: c) rs fr m E0 c rs fr' m) -> - (forall (f2 : function) (sp : val) (parent : frame) (ofs : int) - (ty : typ) (dst : mreg) (c : list instruction) (rs : regset) - (fr : frame) (m : mem) (v : val), - get_slot parent ty (Int.signed ofs) v -> - P f2 sp parent (Mgetparam ofs ty dst :: c) rs fr m E0 c rs # dst <- v - fr m) -> - (forall (f3 : function) (sp : val) (parent : frame) (op : operation) - (args : list mreg) (res : mreg) (c : list instruction) - (rs : mreg -> val) (fr : frame) (m : mem) (v : val), - eval_operation ge sp op rs ## args = Some v -> - P f3 sp parent (Mop op args res :: c) rs fr m E0 c rs # res <- v fr m) -> - (forall (f4 : function) (sp : val) (parent : frame) - (chunk : memory_chunk) (addr : addressing) (args : list mreg) - (dst : mreg) (c : list instruction) (rs : mreg -> val) (fr : frame) - (m : mem) (a v : val), - eval_addressing ge sp addr rs ## args = Some a -> - loadv chunk m a = Some v -> - P f4 sp parent (Mload chunk addr args dst :: c) rs fr m E0 c - rs # dst <- v fr m) -> - (forall (f5 : function) (sp : val) (parent : frame) - (chunk : memory_chunk) (addr : addressing) (args : list mreg) - (src : mreg) (c : list instruction) (rs : mreg -> val) (fr : frame) - (m m' : mem) (a : val), - eval_addressing ge sp addr rs ## args = Some a -> - storev chunk m a (rs src) = Some m' -> - P f5 sp parent (Mstore chunk addr args src :: c) rs fr m E0 c rs fr - m') -> - (forall (f6 : function) (sp : val) (parent : frame) (sig : signature) - (ros : mreg + ident) (c : list instruction) (rs : regset) - (fr : frame) (m : mem) (t : trace) (f' : fundef) (rs' : regset) - (m' : mem), - find_function ge ros rs = Some f' -> - exec_function f' fr rs m t rs' m' -> - P2 f' fr rs m t rs' m' -> - P f6 sp parent (Mcall sig ros :: c) rs fr m t c rs' fr m') -> - (forall (f7 : function) (sp : val) (parent : frame) - (c : list instruction) (rs : mreg -> val) (fr : frame) (m : mem) - (sz : int) (m' : mem) (blk : block), - rs Conventions.loc_alloc_argument = Vint sz -> - alloc m 0 (Int.signed sz) = (m', blk) -> - P f7 sp parent (Malloc :: c) rs fr m E0 c - rs # Conventions.loc_alloc_result <- (Vptr blk Int.zero) fr m') -> - (forall (f7 : function) (sp : val) (parent : frame) (lbl : label) - (c : list instruction) (rs : regset) (fr : frame) (m : mem) - (c' : code), - find_label lbl (fn_code f7) = Some c' -> - P f7 sp parent (Mgoto lbl :: c) rs fr m E0 c' rs fr m) -> - (forall (f8 : function) (sp : val) (parent : frame) (cond : condition) - (args : list mreg) (lbl : label) (c : list instruction) - (rs : mreg -> val) (fr : frame) (m : mem) (c' : code), - eval_condition cond rs ## args = Some true -> - find_label lbl (fn_code f8) = Some c' -> - P f8 sp parent (Mcond cond args lbl :: c) rs fr m E0 c' rs fr m) -> - (forall (f9 : function) (sp : val) (parent : frame) (cond : condition) - (args : list mreg) (lbl : label) (c : list instruction) - (rs : mreg -> val) (fr : frame) (m : mem), - eval_condition cond rs ## args = Some false -> - P f9 sp parent (Mcond cond args lbl :: c) rs fr m E0 c rs fr m) -> - (forall (f10 : function) (sp : val) (parent : frame) (c : code) - (rs : regset) (fr : frame) (m : mem), - P0 f10 sp parent c rs fr m E0 c rs fr m) -> - (forall (f11 : function) (sp : val) (parent : frame) (c : code) - (rs : regset) (fr : frame) (m : mem) (t : trace) (c' : code) - (rs' : regset) (fr' : frame) (m' : mem), - exec_instr f11 sp parent c rs fr m t c' rs' fr' m' -> - P f11 sp parent c rs fr m t c' rs' fr' m' -> - P0 f11 sp parent c rs fr m t c' rs' fr' m') -> - (forall (f12 : function) (sp : val) (parent : frame) (c1 : code) - (rs1 : regset) (fr1 : frame) (m1 : mem) (t1 : trace) (c2 : code) - (rs2 : regset) (fr2 : frame) (m2 : mem) (t2 : trace) (c3 : code) - (rs3 : regset) (fr3 : frame) (m3 : mem) (t3 : trace), - exec_instrs f12 sp parent c1 rs1 fr1 m1 t1 c2 rs2 fr2 m2 -> - P0 f12 sp parent c1 rs1 fr1 m1 t1 c2 rs2 fr2 m2 -> - exec_instrs f12 sp parent c2 rs2 fr2 m2 t2 c3 rs3 fr3 m3 -> - P0 f12 sp parent c2 rs2 fr2 m2 t2 c3 rs3 fr3 m3 -> - t3 = t1 ** t2 -> P0 f12 sp parent c1 rs1 fr1 m1 t3 c3 rs3 fr3 m3) -> - (forall (f13 : function) (parent : frame) (link ra : val) - (rs : regset) (m : mem) (t : trace) (rs' : regset) (m1 m2 : mem) - (stk : block) (fr1 fr2 fr3 : frame) (c : list instruction), - alloc m 0 (fn_stacksize f13) = (m1, stk) -> - set_slot (init_frame f13) Tint 0 link fr1 -> - set_slot fr1 Tint 12 ra fr2 -> - exec_instrs f13 (Vptr stk (Int.repr (- fn_framesize f13))) parent - (fn_code f13) rs fr2 m1 t (Mreturn :: c) rs' fr3 m2 -> - P0 f13 (Vptr stk (Int.repr (- fn_framesize f13))) parent - (fn_code f13) rs fr2 m1 t (Mreturn :: c) rs' fr3 m2 -> - P1 f13 parent link ra rs m t rs' (free m2 stk)) -> - (forall (f14 : function) (parent : frame) (rs : regset) (m : mem) - (t : trace) (rs' : regset) (m' : mem), - (forall link ra : val, - Val.has_type link Tint -> - Val.has_type ra Tint -> - exec_function_body f14 parent link ra rs m t rs' m') -> - (forall link ra : val, - Val.has_type link Tint -> - Val.has_type ra Tint -> P1 f14 parent link ra rs m t rs' m') -> - P2 (Internal f14) parent rs m t rs' m') -> - (forall (ef : external_function) (parent : frame) (args : list val) - (res : val) (rs1 : mreg -> val) (rs2 : RegEq.t -> val) (m : mem) - (t0 : trace), - event_match ef args t0 res -> - extcall_arguments rs1 parent ef.(ef_sig) args -> - rs2 = rs1 # (Conventions.loc_result (ef_sig ef)) <- res -> - P2 (External ef) parent rs1 m t0 rs2 m) -> - (forall (f16 : function) (v : val) (f17 : frame) (c : code) - (r : regset) (f18 : frame) (m : mem) (t : trace) (c0 : code) - (r0 : regset) (f19 : frame) (m0 : mem), - exec_instr f16 v f17 c r f18 m t c0 r0 f19 m0 -> - P f16 v f17 c r f18 m t c0 r0 f19 m0) - /\ (forall (f16 : function) (v : val) (f17 : frame) (c : code) - (r : regset) (f18 : frame) (m : mem) (t : trace) (c0 : code) - (r0 : regset) (f19 : frame) (m0 : mem), - exec_instrs f16 v f17 c r f18 m t c0 r0 f19 m0 -> - P0 f16 v f17 c r f18 m t c0 r0 f19 m0) - /\ (forall (f16 : function) (f17 : frame) (v v0 : val) (r : regset) - (m : mem) (t : trace) (r0 : regset) (m0 : mem), - exec_function_body f16 f17 v v0 r m t r0 m0 -> - P1 f16 f17 v v0 r m t r0 m0) - /\ (forall (f16 : fundef) (f17 : frame) (r : regset) (m : mem) (t : trace) - (r0 : regset) (m0 : mem), - exec_function f16 f17 r m t r0 m0 -> P2 f16 f17 r m t r0 m0). -Proof. - intros. split. apply (exec_instr_ind4 P P0 P1 P2); assumption. - split. apply (exec_instrs_ind4 P P0 P1 P2); assumption. - split. apply (exec_function_body_ind4 P P0 P1 P2); assumption. - apply (exec_function_ind4 P P0 P1 P2); assumption. -Qed. + step (Callstate s (External ef) rs1 m) + t (Returnstate s rs2 m) + | exec_return: + forall f sp c fr s rs m, + step (Returnstate (Stackframe f sp c fr :: s) rs m) + E0 (State s f sp c rs fr m). End RELSEM. -Definition exec_program (p: program) (t: trace) (r: val) : Prop := - let ge := Genv.globalenv p in - let m0 := Genv.init_mem p in - exists b, exists f, exists rs, exists m, - Genv.find_symbol ge p.(prog_main) = Some b /\ - Genv.find_funct_ptr ge b = Some f /\ - exec_function ge f empty_frame (Regmap.init Vundef) m0 t rs m /\ - rs R3 = r. +Inductive initial_state (p: program): state -> Prop := + | initial_state_intro: forall b f, + let ge := Genv.globalenv p in + let m0 := Genv.init_mem p in + Genv.find_symbol ge p.(prog_main) = Some b -> + Genv.find_funct_ptr ge b = Some f -> + initial_state p (Callstate nil f (Regmap.init Vundef) m0). + +Inductive final_state: state -> int -> Prop := + | final_state_intro: forall rs m r, + rs R3 = Vint r -> + final_state (Returnstate nil rs m) r. +Definition exec_program (p: program) (beh: program_behavior) : Prop := + program_behaves step (initial_state p) final_state (Genv.globalenv p) beh. diff --git a/backend/Machabstr2concr.v b/backend/Machabstr2concr.v new file mode 100644 index 00000000..5349fb50 --- /dev/null +++ b/backend/Machabstr2concr.v @@ -0,0 +1,947 @@ +(** Simulation between the two semantics for the Mach language. *) + +Require Import Coqlib. +Require Import Maps. +Require Import AST. +Require Import Integers. +Require Import Values. +Require Import Mem. +Require Import Events. +Require Import Globalenvs. +Require Import Smallstep. +Require Import Op. +Require Import Locations. +Require Import Mach. +Require Import Machtyping. +Require Import Machabstr. +Require Import Machconcr. +Require Import Stackingproof. +Require Import PPCgenretaddr. + +(** Two semantics were defined for the Mach intermediate language: +- The concrete semantics (file [Mach]), where the whole activation + record resides in memory and the [Mgetstack], [Msetstack] and + [Mgetparent] are interpreted as [sp]-relative memory accesses. +- The abstract semantics (file [Machabstr]), where the activation + record is split in two parts: the Cminor stack data, resident in + memory, and the frame information, residing not in memory but + in additional evaluation environments. + + In this file, we show a simulation result between these + semantics: if a program executes with some behaviour [beh] in the + abstract semantics, it also executes with the same behaviour in + the concrete semantics. This result bridges the correctness proof + in file [Stackingproof] (which uses the abstract Mach semantics + as output) and that in file [PPCgenproof] (which uses the concrete + Mach semantics as input). +*) + +Remark align_16_top_ge: + forall lo hi, + hi <= align_16_top lo hi. +Proof. + intros. unfold align_16_top. apply Zmax_bound_r. + assert (forall x, x <= (x + 15) / 16 * 16). + intro. assert (16 > 0). omega. + generalize (Z_div_mod_eq (x + 15) 16 H). intro. + replace ((x + 15) / 16 * 16) with ((x + 15) - (x + 15) mod 16). + generalize (Z_mod_lt (x + 15) 16 H). omega. + rewrite Zmult_comm. omega. + generalize (H (hi - lo)). omega. +Qed. + +Remark align_16_top_pos: + forall lo hi, + 0 <= align_16_top lo hi. +Proof. + intros. unfold align_16_top. apply Zmax_bound_l. omega. +Qed. + +Remark size_type_chunk: + forall ty, size_chunk (chunk_of_type ty) = AST.typesize ty. +Proof. + destruct ty; reflexivity. +Qed. + +(** * Agreement between frames and memory-resident activation records *) + +(** ** Agreement for one frame *) + +(** The core idea of the simulation proof is that for all active + functions, the memory-allocated activation record, in the concrete + semantics, contains the same data as the Cminor stack block + (at positive offsets) and the frame of the function (at negative + offsets) in the abstract semantics. + + This intuition (activation record = Cminor stack data + frame) + is formalized by the following predicate [frame_match fr sp base mm ms]. + [fr] is a frame and [mm] the current memory state in the abstract + semantics. [ms] is the current memory state in the concrete semantics. + The stack pointer is [Vptr sp base] in both semantics. *) + +Inductive frame_match (fr: frame) (sp: block) (base: int) + (mm ms: mem) : Prop := + frame_match_intro: + valid_block ms sp -> + low_bound mm sp = 0 -> + low_bound ms sp = fr.(fr_low) -> + high_bound ms sp >= 0 -> + fr.(fr_low) <= -24 -> + Int.min_signed <= fr.(fr_low) -> + base = Int.repr fr.(fr_low) -> + (forall ty ofs, + fr.(fr_low) + 24 <= ofs -> ofs + AST.typesize ty <= 0 -> + load (chunk_of_type ty) ms sp ofs = Some(fr.(fr_contents) ty ofs)) -> + frame_match fr sp base mm ms. + +(** The following two innocuous-looking lemmas are the key results + showing that [sp]-relative memory accesses in the concrete + semantics behave like the direct frame accesses in the abstract + semantics. First, a value [v] that has type [ty] is preserved + when stored in memory with chunk [chunk_of_type ty], then read + back with the same chunk. The typing hypothesis is crucial here: + for instance, a float value reads back as [Vundef] when stored + and load with chunk [Mint32]. *) + +Lemma load_result_ty: + forall v ty, + Val.has_type v ty -> Val.load_result (chunk_of_type ty) v = v. +Proof. + destruct v; destruct ty; simpl; contradiction || reflexivity. +Qed. + +(** Second, computations of [sp]-relative offsets using machine + arithmetic (as done in the concrete semantics) never overflows + and behaves identically to the offset computations using exact + arithmetic (as done in the abstract semantics). *) + +Lemma int_add_no_overflow: + forall x y, + Int.min_signed <= Int.signed x + Int.signed y <= Int.max_signed -> + Int.signed (Int.add x y) = Int.signed x + Int.signed y. +Proof. + intros. rewrite Int.add_signed. rewrite Int.signed_repr. auto. auto. +Qed. + +(** Given matching frames and activation records, loading from the + activation record (in the concrete semantics) behaves identically + to reading the corresponding slot from the frame + (in the abstract semantics). *) + +Lemma frame_match_get_slot: + forall fr sp base mm ms ty ofs v, + frame_match fr sp base mm ms -> + get_slot fr ty (Int.signed ofs) v -> + load_stack ms (Vptr sp base) ty ofs = Some v. +Proof. + intros. inv H. inv H0. + unfold load_stack, Val.add, loadv. + assert (Int.signed (Int.repr (fr_low fr)) = fr_low fr). + apply Int.signed_repr. + split. auto. apply Zle_trans with (-24). auto. compute; congruence. + assert (Int.signed (Int.add (Int.repr (fr_low fr)) ofs) = fr_low fr + Int.signed ofs). + rewrite int_add_no_overflow. rewrite H0. auto. + rewrite H0. split. omega. apply Zle_trans with 0. + generalize (AST.typesize_pos ty). omega. compute; congruence. + rewrite H9. apply H8. omega. auto. +Qed. + +(** Assigning a value to a frame slot (in the abstract semantics) + corresponds to storing this value in the activation record + (in the concrete semantics). Moreover, agreement between frames + and activation records is preserved. *) + +Lemma frame_match_set_slot: + forall fr sp base mm ms ty ofs v fr', + frame_match fr sp base mm ms -> + set_slot fr ty (Int.signed ofs) v fr' -> + Val.has_type v ty -> + Mem.extends mm ms -> + exists ms', + store_stack ms (Vptr sp base) ty ofs v = Some ms' /\ + frame_match fr' sp base mm ms' /\ + Mem.extends mm ms' /\ + Int.signed base + 24 <= Int.signed (Int.add base ofs). +Proof. + intros. inv H. inv H0. + unfold store_stack, Val.add, storev. + assert (Int.signed (Int.repr (fr_low fr)) = fr_low fr). + apply Int.signed_repr. + split. auto. apply Zle_trans with (-24). auto. compute; congruence. + assert (Int.signed (Int.add (Int.repr (fr_low fr)) ofs) = fr_low fr + Int.signed ofs). + rewrite int_add_no_overflow. congruence. + rewrite H0. split. omega. apply Zle_trans with 0. + generalize (AST.typesize_pos ty). omega. compute; congruence. + rewrite H11. + assert (exists ms', store (chunk_of_type ty) ms sp (fr_low fr + Int.signed ofs) v = Some ms'). + apply valid_access_store. + constructor. auto. omega. + rewrite size_type_chunk. omega. + destruct H12 as [ms' STORE]. + generalize (low_bound_store _ _ _ _ _ _ STORE sp). intro LB. + generalize (high_bound_store _ _ _ _ _ _ STORE sp). intro HB. + exists ms'. + split. exact STORE. + (* frame match *) + split. constructor; simpl fr_low; try congruence. + eauto with mem. intros. simpl. + destruct (zeq (fr_low fr + Int.signed ofs) ofs0). subst ofs0. + destruct (typ_eq ty ty0). subst ty0. + (* same *) + transitivity (Some (Val.load_result (chunk_of_type ty) v)). + eapply load_store_same; eauto. + decEq. apply load_result_ty; auto. + (* mismatch *) + eapply load_store_mismatch'; eauto with mem. + destruct ty; destruct ty0; simpl; congruence. + destruct (zle (ofs0 + AST.typesize ty0) (fr_low fr + Int.signed ofs)). + (* disjoint *) + rewrite <- H10; auto. eapply load_store_other; eauto. + right; left. rewrite size_type_chunk; auto. + destruct (zle (fr_low fr + Int.signed ofs + AST.typesize ty)). + rewrite <- H10; auto. eapply load_store_other; eauto. + right; right. rewrite size_type_chunk; auto. + (* overlap *) + eapply load_store_overlap'; eauto with mem. + rewrite size_type_chunk; auto. + rewrite size_type_chunk; auto. + (* extends *) + split. eapply store_outside_extends; eauto. + left. rewrite size_type_chunk. omega. + (* bound *) + omega. +Qed. + +(** Agreement is preserved by stores within blocks other than the + one pointed to by [sp], or to the low 24 bytes + of the [sp] block. *) + +Lemma frame_match_store_other: + forall fr sp base mm ms chunk b ofs v ms', + frame_match fr sp base mm ms -> + store chunk ms b ofs v = Some ms' -> + sp <> b \/ ofs + size_chunk chunk <= fr_low fr + 24 -> + frame_match fr sp base mm ms'. +Proof. + intros. inv H. + generalize (low_bound_store _ _ _ _ _ _ H0 sp). intro LB. + generalize (high_bound_store _ _ _ _ _ _ H0 sp). intro HB. + apply frame_match_intro; auto. + eauto with mem. + congruence. + congruence. + intros. rewrite <- H9; auto. + eapply load_store_other; eauto. + elim H1; intro. auto. right. rewrite size_type_chunk. omega. +Qed. + +Lemma frame_match_store: + forall fr sp base mm ms chunk b ofs v mm' ms', + frame_match fr sp base mm ms -> + store chunk mm b ofs v = Some mm' -> + store chunk ms b ofs v = Some ms' -> + frame_match fr sp base mm' ms'. +Proof. + intros. inv H. + generalize (low_bound_store _ _ _ _ _ _ H0 sp). intro LBm. + generalize (low_bound_store _ _ _ _ _ _ H1 sp). intro LBs. + generalize (high_bound_store _ _ _ _ _ _ H0 sp). intro HBm. + generalize (high_bound_store _ _ _ _ _ _ H1 sp). intro HBs. + apply frame_match_intro; auto. + eauto with mem. + congruence. congruence. congruence. + intros. rewrite <- H9; auto. eapply load_store_other; eauto. + destruct (zeq sp b). subst b. right. + rewrite size_type_chunk. + assert (valid_access mm chunk sp ofs) by eauto with mem. + inv H10. left. omega. + auto. +Qed. + +(** The low 24 bytes of a frame are preserved by a parallel + store in the two memory states. *) + +Lemma frame_match_store_link_invariant: + forall fr sp base mm ms chunk b ofs v mm' ms' ofs', + frame_match fr sp base mm ms -> + store chunk mm b ofs v = Some mm' -> + store chunk ms b ofs v = Some ms' -> + ofs' <= fr_low fr + 20 -> + load Mint32 ms' sp ofs' = load Mint32 ms sp ofs'. +Proof. + intros. inv H. + eapply load_store_other; eauto. + destruct (eq_block sp b). subst b. + right; left. change (size_chunk Mint32) with 4. + assert (valid_access mm chunk sp ofs) by eauto with mem. + inv H. omega. + auto. +Qed. + +(** Memory allocation of the Cminor stack data block (in the abstract + semantics) and of the whole activation record (in the concrete + semantics) return memory states that agree according to [frame_match]. + Moreover, [frame_match] relations over already allocated blocks + remain true. *) + +Lemma frame_match_new: + forall mm ms mm' ms' sp sp' f, + mm.(nextblock) = ms.(nextblock) -> + alloc mm 0 f.(fn_stacksize) = (mm', sp) -> + alloc ms (- f.(fn_framesize)) (align_16_top (- f.(fn_framesize)) f.(fn_stacksize)) = (ms', sp') -> + f.(fn_framesize) >= 24 -> + f.(fn_framesize) <= -Int.min_signed -> + sp = sp' /\ + frame_match (init_frame f) sp (Int.repr (-f.(fn_framesize))) mm' ms'. +Proof. + intros. + assert (sp = sp'). + exploit alloc_result. eexact H0. exploit alloc_result. eexact H1. + congruence. + subst sp'. split. auto. + generalize (low_bound_alloc_same _ _ _ _ _ H0). intro LBm. + generalize (low_bound_alloc_same _ _ _ _ _ H1). intro LBs. + generalize (high_bound_alloc_same _ _ _ _ _ H0). intro HBm. + generalize (high_bound_alloc_same _ _ _ _ _ H1). intro HBs. + constructor; simpl; eauto with mem. + rewrite HBs. apply Zle_ge. apply align_16_top_pos. + omega. omega. + intros. + eapply load_alloc_same'; eauto. omega. + rewrite size_type_chunk. apply Zle_trans with 0. auto. + apply align_16_top_pos. +Qed. + +Lemma frame_match_alloc: + forall mm ms fr sp base lom him los his mm' ms' bm bs, + mm.(nextblock) = ms.(nextblock) -> + frame_match fr sp base mm ms -> + alloc mm lom him = (mm', bm) -> + alloc ms los his = (ms', bs) -> + frame_match fr sp base mm' ms'. +Proof. + intros. inversion H0. + assert (valid_block mm sp). red. rewrite H. auto. + exploit low_bound_alloc_other. eexact H1. eexact H11. intro LBm. + exploit high_bound_alloc_other. eexact H1. eexact H11. intro HBm. + exploit low_bound_alloc_other. eexact H2. eexact H3. intro LBs. + exploit high_bound_alloc_other. eexact H2. eexact H3. intro HBs. + apply frame_match_intro. + eapply valid_block_alloc; eauto. + congruence. congruence. congruence. auto. auto. auto. + intros. eapply load_alloc_other; eauto. +Qed. + +(** [frame_match] relations are preserved by freeing a block + other than the one pointed to by [sp]. *) + +Lemma frame_match_free: + forall fr sp base mm ms b, + frame_match fr sp base mm ms -> + sp <> b -> + frame_match fr sp base (free mm b) (free ms b). +Proof. + intros. inversion H. + generalize (low_bound_free mm _ _ H0); intro LBm. + generalize (low_bound_free ms _ _ H0); intro LBs. + generalize (high_bound_free mm _ _ H0); intro HBm. + generalize (high_bound_free ms _ _ H0); intro HBs. + apply frame_match_intro; auto. + congruence. congruence. congruence. + intros. rewrite <- H8; auto. apply load_free. auto. +Qed. + +(** ** Invariant for stacks *) + +Section SIMULATION. + +Variable p: program. +Let ge := Genv.globalenv p. + +(** The [match_stacks] predicate relates a Machabstr call stack + with the corresponding Machconcr stack. In addition to enforcing + the [frame_match] predicate for each stack frame, we also enforce: +- Proper chaining of activation record on the Machconcr side. +- Preservation of the return address stored at the bottom of the + activation record. +- Separation between the memory blocks holding the activation records: + their addresses increase strictly from caller to callee. +*) + +Inductive match_stacks: + list Machabstr.stackframe -> list Machconcr.stackframe -> + block -> int -> mem -> mem -> Prop := + | match_stacks_nil: forall sp base mm ms, + load Mint32 ms sp (Int.signed base) = Some (Vptr Mem.nullptr Int.zero) -> + load Mint32 ms sp (Int.signed base + 12) = Some Vzero -> + match_stacks nil nil sp base mm ms + | match_stacks_cons: forall f sp' base' c fr s fb ra ts sp base mm ms, + frame_match fr sp' base' mm ms -> + sp' < sp -> + load Mint32 ms sp (Int.signed base) = Some (Vptr sp' base') -> + load Mint32 ms sp (Int.signed base + 12) = Some ra -> + Genv.find_funct_ptr ge fb = Some (Internal f) -> + match_stacks s ts sp' base' mm ms -> + match_stacks (Machabstr.Stackframe f (Vptr sp' base') c fr :: s) + (Machconcr.Stackframe fb (Vptr sp' base') ra c :: ts) + sp base mm ms. + +Remark frame_match_base_eq: + forall fr sp base mm ms, + frame_match fr sp base mm ms -> Int.signed base = fr_low fr. +Proof. + intros. inv H. apply Int.signed_repr. split; auto. + apply Zle_trans with (-24); auto. compute; congruence. +Qed. + +(** If [match_stacks] holds, a lookup in the parent frame in the + Machabstr semantics corresponds to two memory loads in the + Machconcr semantics, one to load the pointer to the parent's + activation record, the second to read within this record. *) + +Lemma match_stacks_get_parent: + forall s ts sp base mm ms ty ofs v, + match_stacks s ts sp base mm ms -> + get_slot (parent_frame s) ty (Int.signed ofs) v -> + exists parent, + load_stack ms (Vptr sp base) Tint (Int.repr 0) = Some parent + /\ load_stack ms parent ty ofs = Some v. +Proof. + intros. inv H; simpl in H0. + inv H0. simpl in H3. elimtype False. generalize (AST.typesize_pos ty). omega. + exists (Vptr sp' base'); split. + unfold load_stack. simpl. rewrite Int.add_zero. auto. + eapply frame_match_get_slot; eauto. +Qed. + +(** If [match_stacks] holds, reading memory at offsets 0 and 12 + from the stack pointer returns the stack pointer and return + address of the caller, respectively. *) + +Lemma match_stacks_load_links: + forall fr s ts sp base mm ms, + frame_match fr sp base mm ms -> + match_stacks s ts sp base mm ms -> + load_stack ms (Vptr sp base) Tint (Int.repr 0) = Some (parent_sp ts) /\ + load_stack ms (Vptr sp base) Tint (Int.repr 12) = Some (parent_ra ts). +Proof. + intros. unfold load_stack. simpl. rewrite Int.add_zero. + replace (Int.signed (Int.add base (Int.repr 12))) + with (Int.signed base + 12). + inv H0; simpl; auto. + inv H. rewrite Int.add_signed. + change (Int.signed (Int.repr 12)) with 12. + repeat rewrite Int.signed_repr. auto. + split. omega. apply Zle_trans with (-12). omega. compute; congruence. + split. auto. apply Zle_trans with (-24). auto. compute; congruence. +Qed. + +(** The [match_stacks] invariant is preserved by memory stores + outside the 24-byte reserved area at the bottom of activation records. +*) + +Lemma match_stacks_store_other: + forall s ts sp base ms mm, + match_stacks s ts sp base mm ms -> + forall chunk b ofs v ms', + store chunk ms b ofs v = Some ms' -> + sp < b -> + match_stacks s ts sp base mm ms'. +Proof. + induction 1; intros. + assert (sp <> b). unfold block; omega. + constructor. + rewrite <- H. eapply load_store_other; eauto. + rewrite <- H0. eapply load_store_other; eauto. + assert (sp <> b). unfold block; omega. + econstructor; eauto. + eapply frame_match_store_other; eauto. + left. unfold block; omega. + rewrite <- H1. eapply load_store_other; eauto. + rewrite <- H2. eapply load_store_other; eauto. + eapply IHmatch_stacks; eauto. omega. +Qed. + +Lemma match_stacks_store_slot: + forall s ts sp base ms mm, + match_stacks s ts sp base mm ms -> + forall ty ofs v ms', + store_stack ms (Vptr sp base) ty ofs v = Some ms' -> + Int.signed base + 24 <= Int.signed (Int.add base ofs) -> + match_stacks s ts sp base mm ms'. +Proof. + intros. + unfold store_stack in H0. simpl in H0. + assert (load Mint32 ms' sp (Int.signed base) = load Mint32 ms sp (Int.signed base)). + eapply load_store_other; eauto. + right; left. change (size_chunk Mint32) with 4; omega. + assert (load Mint32 ms' sp (Int.signed base + 12) = load Mint32 ms sp (Int.signed base + 12)). + eapply load_store_other; eauto. + right; left. change (size_chunk Mint32) with 4; omega. + inv H. + constructor; congruence. + constructor; auto. + eapply frame_match_store_other; eauto. + left; unfold block; omega. + congruence. congruence. + eapply match_stacks_store_other; eauto. +Qed. + +Lemma match_stacks_store: + forall s ts sp base ms mm, + match_stacks s ts sp base mm ms -> + forall fr chunk b ofs v mm' ms', + frame_match fr sp base mm ms -> + store chunk mm b ofs v = Some mm' -> + store chunk ms b ofs v = Some ms' -> + match_stacks s ts sp base mm' ms'. +Proof. + induction 1; intros. + assert (Int.signed base = fr_low fr) by (eapply frame_match_base_eq; eauto). + constructor. + rewrite <- H. eapply frame_match_store_link_invariant; eauto. omega. + rewrite <- H0. eapply frame_match_store_link_invariant; eauto. omega. + assert (Int.signed base = fr_low fr0) by (eapply frame_match_base_eq; eauto). + econstructor; eauto. + eapply frame_match_store; eauto. + rewrite <- H1. eapply frame_match_store_link_invariant; eauto. omega. + rewrite <- H2. eapply frame_match_store_link_invariant; eauto. omega. +Qed. + +Lemma match_stacks_alloc: + forall s ts sp base ms mm, + match_stacks s ts sp base mm ms -> + forall lom him mm' bm los his ms' bs, + mm.(nextblock) = ms.(nextblock) -> + alloc mm lom him = (mm', bm) -> + alloc ms los his = (ms', bs) -> + match_stacks s ts sp base mm' ms'. +Proof. + induction 1; intros. + constructor. + rewrite <- H; eapply load_alloc_unchanged; eauto with mem. + rewrite <- H0; eapply load_alloc_unchanged; eauto with mem. + econstructor; eauto. + eapply frame_match_alloc; eauto. + rewrite <- H1; eapply load_alloc_unchanged; eauto with mem. + rewrite <- H2; eapply load_alloc_unchanged; eauto with mem. +Qed. + +Lemma match_stacks_free: + forall s ts sp base ms mm, + match_stacks s ts sp base mm ms -> + forall b, + sp < b -> + match_stacks s ts sp base (Mem.free mm b) (Mem.free ms b). +Proof. + induction 1; intros. + assert (sp <> b). unfold block; omega. + constructor. + rewrite <- H. apply load_free; auto. + rewrite <- H0. apply load_free; auto. + assert (sp <> b). unfold block; omega. + econstructor; eauto. + eapply frame_match_free; eauto. unfold block; omega. + rewrite <- H1. apply load_free; auto. + rewrite <- H2. apply load_free; auto. + eapply IHmatch_stacks; eauto. omega. +Qed. + +(** Invocation of a function temporarily violates the [mach_stacks] + invariant: the return address and back link are not yet stored + in the appropriate parts of the activation record. + The following [match_stacks_partial] predicate is a weaker version + of [match_stacks] that captures this situation. *) + +Inductive match_stacks_partial: + list Machabstr.stackframe -> list Machconcr.stackframe -> + mem -> mem -> Prop := + | match_stacks_partial_nil: forall mm ms, + match_stacks_partial nil nil mm ms + | match_stacks_partial_cons: forall f sp base c fr s fb ra ts mm ms, + frame_match fr sp base mm ms -> + sp < ms.(nextblock) -> + Genv.find_funct_ptr ge fb = Some (Internal f) -> + match_stacks s ts sp base mm ms -> + Val.has_type ra Tint -> + match_stacks_partial (Machabstr.Stackframe f (Vptr sp base) c fr :: s) + (Machconcr.Stackframe fb (Vptr sp base) ra c :: ts) + mm ms. + +Lemma match_stacks_match_stacks_partial: + forall s ts sp base mm ms, + match_stacks s ts sp base mm ms -> + match_stacks_partial s ts (free mm sp) (free ms sp). +Proof. + intros. inv H. constructor. + econstructor. + eapply frame_match_free; eauto. unfold block; omega. + simpl. inv H0; auto. + auto. + apply match_stacks_free; auto. + generalize (Mem.load_inv _ _ _ _ _ H3). intros [A B]. + rewrite B. + destruct (getN (pred_size_chunk Mint32) (Int.signed base + 12) + (contents (blocks ms sp))); exact I. +Qed. + +Lemma match_stacks_function_entry: + forall s ts mm ms lom him mm' los his ms' stk ms'' ms''' base, + match_stacks_partial s ts mm ms -> + alloc mm lom him = (mm', stk) -> + alloc ms los his = (ms', stk) -> + store Mint32 ms' stk (Int.signed base) (parent_sp ts) = Some ms'' -> + store Mint32 ms'' stk (Int.signed base + 12) (parent_ra ts) = Some ms''' -> + match_stacks s ts stk base mm' ms'''. +Proof. + intros. + assert (WT_SP: Val.has_type (parent_sp ts) Tint). + inv H; simpl; auto. + assert (WT_RA: Val.has_type (parent_ra ts) Tint). + inv H; simpl; auto. + assert (load Mint32 ms''' stk (Int.signed base) = Some (parent_sp ts)). + transitivity (load Mint32 ms'' stk (Int.signed base)). + eapply load_store_other; eauto. right; left. simpl. omega. + transitivity (Some (Val.load_result (chunk_of_type Tint) (parent_sp ts))). + simpl chunk_of_type. eapply load_store_same; eauto. + decEq. apply load_result_ty. auto. + assert (load Mint32 ms''' stk (Int.signed base + 12) = Some (parent_ra ts)). + transitivity (Some (Val.load_result (chunk_of_type Tint) (parent_ra ts))). + simpl chunk_of_type. eapply load_store_same; eauto. + decEq. apply load_result_ty. auto. + inv H; simpl in *. + constructor; auto. + assert (sp < stk). rewrite (alloc_result _ _ _ _ _ H1). auto. + assert (sp <> stk). unfold block; omega. + assert (nextblock mm = nextblock ms). + rewrite <- (alloc_result _ _ _ _ _ H0). + rewrite <- (alloc_result _ _ _ _ _ H1). auto. + econstructor; eauto. + eapply frame_match_store_other; eauto. + eapply frame_match_store_other; eauto. + eapply frame_match_alloc with (mm := mm) (ms := ms); eauto. + eapply match_stacks_store_other; eauto. + eapply match_stacks_store_other; eauto. + eapply match_stacks_alloc with (mm := mm) (ms := ms); eauto. + Qed. + +(** ** Invariant between states. *) + +(** The [match_state] predicate relates a Machabstr state with + a Machconcr state. In addition to [match_stacks] between the + stacks, we ask that +- The Machabstr frame is properly stored in the activation record, + as characterized by [frame_match]. +- The Machconcr memory state extends the Machabstr memory state, + in the sense of the [Mem.extends] relation defined in module [Mem]. *) + +Inductive match_states: + Machabstr.state -> Machconcr.state -> Prop := + | match_states_intro: + forall s f sp base c rs fr mm ts fb ms + (STACKS: match_stacks s ts sp base mm ms) + (FM: frame_match fr sp base mm ms) + (MEXT: Mem.extends mm ms) + (FIND: Genv.find_funct_ptr ge fb = Some (Internal f)), + match_states (Machabstr.State s f (Vptr sp base) c rs fr mm) + (Machconcr.State ts fb (Vptr sp base) c rs ms) + | match_states_call: + forall s f rs mm ts fb ms + (STACKS: match_stacks_partial s ts mm ms) + (MEXT: Mem.extends mm ms) + (FIND: Genv.find_funct_ptr ge fb = Some f), + match_states (Machabstr.Callstate s f rs mm) + (Machconcr.Callstate ts fb rs ms) + | match_states_return: + forall s rs mm ts ms + (STACKS: match_stacks_partial s ts mm ms) + (MEXT: Mem.extends mm ms), + match_states (Machabstr.Returnstate s rs mm) + (Machconcr.Returnstate ts rs ms). + + +(** * The proof of simulation *) + +(** The proof of simulation relies on diagrams of the following form: +<< + st1 --------------- st2 + | | + t| |t + | | + v v + st1'--------------- st2' +>> + The precondition is matching between the initial states [st1] and + [st2], as usual, plus the fact that [st1] is well-typed + in the sense of predicate [wt_state] from module [Machtyping]. + The postcondition is matching between the final states [st1'] + and [st2']. The well-typedness of [st2] is not part of the + postcondition, since it follows from that of [st1] if the + program is well-typed. (See the subject reduction property + in module [Machtyping].) +*) + +Lemma find_function_find_function_ptr: + forall ros rs f', + find_function ge ros rs = Some f' -> + exists fb', Genv.find_funct_ptr ge fb' = Some f' /\ find_function_ptr ge ros rs = Some fb'. +Proof. + intros until f'. destruct ros; simpl. + intro. exploit Genv.find_funct_inv; eauto. intros [fb' EQ]. + rewrite EQ in H. rewrite Genv.find_funct_find_funct_ptr in H. + exists fb'; split. auto. rewrite EQ. simpl. auto. + destruct (Genv.find_symbol ge i); intro. + exists b; auto. congruence. +Qed. + +(** Preservation of arguments to external functions. *) + +Lemma transl_extcall_arguments: + forall rs s sg args ts m ms, + Machabstr.extcall_arguments rs (parent_frame s) sg args -> + match_stacks_partial s ts m ms -> + extcall_arguments rs ms (parent_sp ts) sg args. +Proof. + unfold Machabstr.extcall_arguments, extcall_arguments; intros. + assert (forall ty ofs v, + get_slot (parent_frame s) ty (Int.signed ofs) v -> + load_stack ms (parent_sp ts) ty ofs = Some v). + inv H0; simpl; intros. + inv H0. simpl in H2. elimtype False. generalize (AST.typesize_pos ty). omega. + eapply frame_match_get_slot; eauto. + assert (forall locs vals, + Machabstr.extcall_args rs (parent_frame s) locs vals -> + extcall_args rs ms (parent_sp ts) locs vals). + induction locs; intros; inversion H2; subst; clear H2. + constructor. + constructor; auto. + inversion H7; subst; clear H7. + constructor. + constructor. auto. + auto. +Qed. + +Theorem step_equiv: + forall s1 t s2, Machabstr.step ge s1 t s2 -> + forall s1' (MS: match_states s1 s1') (WTS: wt_state s1), + exists s2', Machconcr.step ge s1' t s2' /\ match_states s2 s2'. +Proof. + induction 1; intros; inv MS. + + (* Mlabel *) + econstructor; split. + apply exec_Mlabel; auto. + econstructor; eauto with coqlib. + + (* Mgetstack *) + exists (State ts fb (Vptr sp0 base) c (rs#dst <- v) ms); split. + apply exec_Mgetstack; auto. eapply frame_match_get_slot; eauto. + econstructor; eauto with coqlib. + + (* Msetstack *) + assert (Val.has_type (rs src) ty). + inv WTS. + generalize (wt_function_instrs _ WTF _ (is_tail_in TAIL)); intro WTI. + inv WTI. apply WTRS. + exploit frame_match_set_slot; eauto. + intros [ms' [STORE [FM' [EXT' BOUND]]]]. + exists (State ts fb (Vptr sp0 base) c rs ms'); split. + apply exec_Msetstack; auto. + econstructor; eauto. + eapply match_stacks_store_slot; eauto. + + (* Mgetparam *) + exploit match_stacks_get_parent; eauto. + intros [parent [LOAD1 LOAD2]]. + exists (State ts fb (Vptr sp0 base) c (rs#dst <- v) ms); split. + eapply exec_Mgetparam; eauto. + econstructor; eauto with coqlib. + + (* Mop *) + exists (State ts fb (Vptr sp0 base) c (rs#res <- v) ms); split. + apply exec_Mop; auto. + eapply eval_operation_change_mem with (m := m); eauto. + intros. eapply Mem.valid_pointer_extends; eauto. + econstructor; eauto with coqlib. + + (* Mload *) + exists (State ts fb (Vptr sp0 base) c (rs#dst <- v) ms); split. + eapply exec_Mload; eauto. + destruct a; simpl in H0; try discriminate. + simpl. eapply Mem.load_extends; eauto. + econstructor; eauto with coqlib. + + (* Mstore *) + destruct a; simpl in H0; try discriminate. + exploit Mem.store_within_extends; eauto. intros [ms' [STORE MEXT']]. + exists (State ts fb (Vptr sp0 base) c rs ms'); split. + eapply exec_Mstore; eauto. + econstructor; eauto with coqlib. + eapply match_stacks_store; eauto. + eapply frame_match_store; eauto. + + (* Mcall *) + exploit find_function_find_function_ptr; eauto. + intros [fb' [FIND' FINDFUNCT]]. + assert (exists ra', return_address_offset f c ra'). + apply return_address_exists. + inv WTS. eapply is_tail_cons_left; eauto. + destruct H0 as [ra' RETADDR]. + econstructor; split. + eapply exec_Mcall; eauto. + econstructor; eauto. + econstructor; eauto. inv FM; auto. exact I. + + (* Mtailcall *) + exploit find_function_find_function_ptr; eauto. + intros [fb' [FIND' FINDFUNCT]]. + exploit match_stacks_load_links; eauto. intros [LOAD1 LOAD2]. + econstructor; split. + eapply exec_Mtailcall; eauto. + econstructor; eauto. + eapply match_stacks_match_stacks_partial; eauto. + apply free_extends; auto. + + (* Malloc *) + caseEq (alloc ms 0 (Int.signed sz)). intros ms' blk' ALLOC. + exploit alloc_extends; eauto. omega. omega. intros [EQ MEXT']. subst blk'. + exists (State ts fb (Vptr sp0 base) c (rs#Conventions.loc_alloc_result <- (Vptr blk Int.zero)) ms'); split. + eapply exec_Malloc; eauto. + econstructor; eauto. + eapply match_stacks_alloc; eauto. inv MEXT; auto. + eapply frame_match_alloc with (mm := m) (ms := ms); eauto. inv MEXT; auto. + + (* Mgoto *) + econstructor; split. + eapply exec_Mgoto; eauto. + econstructor; eauto. + + (* Mcond *) + econstructor; split. + eapply exec_Mcond_true; eauto. + eapply eval_condition_change_mem with (m := m); eauto. + intros. eapply Mem.valid_pointer_extends; eauto. + econstructor; eauto. + econstructor; split. + eapply exec_Mcond_false; eauto. + eapply eval_condition_change_mem with (m := m); eauto. + intros. eapply Mem.valid_pointer_extends; eauto. + econstructor; eauto. + + (* Mreturn *) + exploit match_stacks_load_links; eauto. intros [LOAD1 LOAD2]. + econstructor; split. + eapply exec_Mreturn; eauto. + econstructor; eauto. + eapply match_stacks_match_stacks_partial; eauto. + apply free_extends; auto. + + (* internal function *) + assert (WTF: wt_function f). inv WTS. inv H5. auto. inv WTF. + caseEq (alloc ms (- f.(fn_framesize)) + (align_16_top (- f.(fn_framesize)) f.(fn_stacksize))). + intros ms' stk' ALLOC. + exploit (alloc_extends m ms m' ms' 0 (fn_stacksize f) + (- fn_framesize f) + (align_16_top (- fn_framesize f) (fn_stacksize f))); eauto. + omega. apply align_16_top_ge. + intros [EQ EXT']. subst stk'. + exploit (frame_match_new m ms); eauto. inv MEXT; auto. + intros [EQ FM]. clear EQ. + set (sp := Vptr stk (Int.repr (- fn_framesize f))). + assert (exists ms'', store Mint32 ms' stk (- fn_framesize f) (parent_sp ts) = Some ms''). + apply valid_access_store. constructor. + eauto with mem. + rewrite (low_bound_alloc_same _ _ _ _ _ ALLOC). omega. + rewrite (high_bound_alloc_same _ _ _ _ _ ALLOC). + change (size_chunk Mint32) with 4. + apply Zle_trans with 0. omega. apply align_16_top_pos. + destruct H0 as [ms'' STORE1]. + assert (exists ms''', store Mint32 ms'' stk (- fn_framesize f + 12) (parent_ra ts) = Some ms'''). + apply valid_access_store. constructor. + eauto with mem. + rewrite (low_bound_store _ _ _ _ _ _ STORE1 stk). + rewrite (low_bound_alloc_same _ _ _ _ _ ALLOC). omega. + rewrite (high_bound_store _ _ _ _ _ _ STORE1 stk). + rewrite (high_bound_alloc_same _ _ _ _ _ ALLOC). + change (size_chunk Mint32) with 4. + apply Zle_trans with 0. omega. apply align_16_top_pos. + destruct H0 as [ms''' STORE2]. + assert (RANGE1: Int.min_signed <= - fn_framesize f <= Int.max_signed). + split. omega. apply Zle_trans with (-24). omega. compute;congruence. + assert (RANGE2: Int.min_signed <= - fn_framesize f + 12 <= Int.max_signed). + split. omega. apply Zle_trans with (-12). omega. compute;congruence. + econstructor; split. + eapply exec_function_internal; eauto. + unfold store_stack. simpl. rewrite Int.add_zero. + rewrite Int.signed_repr. eauto. auto. + unfold store_stack. simpl. rewrite Int.add_signed. + change (Int.signed (Int.repr 12)) with 12. + repeat rewrite Int.signed_repr; eauto. + (* match states *) + unfold sp; econstructor; eauto. + eapply match_stacks_function_entry; eauto. + rewrite Int.signed_repr; eauto. + rewrite Int.signed_repr; eauto. + eapply frame_match_store_other with (ms := ms''); eauto. + eapply frame_match_store_other with (ms := ms'); eauto. + simpl. right; omega. simpl. right; omega. + eapply store_outside_extends with (m2 := ms''); eauto. + eapply store_outside_extends with (m2 := ms'); eauto. + rewrite (low_bound_alloc_same _ _ _ _ _ H). simpl; omega. + rewrite (low_bound_alloc_same _ _ _ _ _ H). simpl; omega. + + (* external function *) + econstructor; split. + eapply exec_function_external; eauto. + eapply transl_extcall_arguments; eauto. + econstructor; eauto. + + (* return *) + inv STACKS. + econstructor; split. + eapply exec_return. + econstructor; eauto. +Qed. + +Hypothesis wt_prog: wt_program p. + +Lemma equiv_initial_states: + forall st1, Machabstr.initial_state p st1 -> + exists st2, Machconcr.initial_state p st2 /\ match_states st1 st2 /\ wt_state st1. +Proof. + intros. inversion H. + econstructor; split. + econstructor. eauto. + split. econstructor. constructor. apply Mem.extends_refl. auto. + econstructor. simpl; intros; contradiction. + eapply Genv.find_funct_ptr_prop; eauto. + red; intros; exact I. +Qed. + +Lemma equiv_final_states: + forall st1 st2 r, + match_states st1 st2 /\ wt_state st1 -> Machabstr.final_state st1 r -> Machconcr.final_state st2 r. +Proof. + intros. inv H0. destruct H. inv H. inv STACKS. + constructor; auto. +Qed. + +Theorem exec_program_equiv: + forall (beh: program_behavior), + Machabstr.exec_program p beh -> Machconcr.exec_program p beh. +Proof. + unfold Machconcr.exec_program, Machabstr.exec_program; intros. + eapply simulation_step_preservation with + (step1 := Machabstr.step) + (step2 := Machconcr.step) + (match_states := fun st1 st2 => match_states st1 st2 /\ wt_state st1). + eexact equiv_initial_states. + eexact equiv_final_states. + intros. destruct H1. exploit step_equiv; eauto. + intros [st2' [A B]]. exists st2'; split. auto. split. auto. + eapply Machtyping.subject_reduction; eauto. + auto. +Qed. + +End SIMULATION. diff --git a/backend/Machabstr2mach.v b/backend/Machabstr2mach.v deleted file mode 100644 index 8a2b01dd..00000000 --- a/backend/Machabstr2mach.v +++ /dev/null @@ -1,1185 +0,0 @@ -(** Simulation between the two semantics for the Mach language. *) - -Require Import Coqlib. -Require Import Maps. -Require Import AST. -Require Import Integers. -Require Import Values. -Require Import Mem. -Require Import Events. -Require Import Globalenvs. -Require Import Op. -Require Import Locations. -Require Import Machabstr. -Require Import Mach. -Require Import Machtyping. -Require Import Stackingproof. - -(** Two semantics were defined for the Mach intermediate language: -- The concrete semantics (file [Mach]), where the whole activation - record resides in memory and the [Mgetstack], [Msetstack] and - [Mgetparent] are interpreted as [sp]-relative memory accesses. -- The abstract semantics (file [Machabstr]), where the activation - record is split in two parts: the Cminor stack data, resident in - memory, and the frame information, residing not in memory but - in additional evaluation environments. - - In this file, we show a simulation result between these - semantics: if a program executes to some result [r] in the - abstract semantics, it also executes to the same result in - the concrete semantics. This result bridges the correctness proof - in file [Stackingproof] (which uses the abstract Mach semantics - as output) and that in file [PPCgenproof] (which uses the concrete - Mach semantics as input). -*) - -Remark align_16_top_ge: - forall lo hi, - hi <= align_16_top lo hi. -Proof. - intros. unfold align_16_top. apply Zmax_bound_r. - assert (forall x, x <= (x + 15) / 16 * 16). - intro. assert (16 > 0). omega. - generalize (Z_div_mod_eq (x + 15) 16 H). intro. - replace ((x + 15) / 16 * 16) with ((x + 15) - (x + 15) mod 16). - generalize (Z_mod_lt (x + 15) 16 H). omega. - rewrite Zmult_comm. omega. - generalize (H (hi - lo)). omega. -Qed. - -Remark align_16_top_pos: - forall lo hi, - 0 <= align_16_top lo hi. -Proof. - intros. unfold align_16_top. apply Zmax_bound_l. omega. -Qed. - -Remark size_mem_pos: - forall sz, size_mem sz > 0. -Proof. - destruct sz; simpl; compute; auto. -Qed. - -Remark size_type_chunk: - forall ty, size_chunk (chunk_of_type ty) = 4 * typesize ty. -Proof. - destruct ty; reflexivity. -Qed. - -Remark mem_chunk_type: - forall ty, mem_chunk (chunk_of_type ty) = mem_type ty. -Proof. - destruct ty; reflexivity. -Qed. - -Remark size_mem_type: - forall ty, size_mem (mem_type ty) = 4 * typesize ty. -Proof. - destruct ty; reflexivity. -Qed. - -(** * Agreement between frames and memory-resident activation records *) - -(** ** Agreement for one frame *) - -(** The core idea of the simulation proof is that for all active - functions, the memory-allocated activation record, in the concrete - semantics, contains the same data as the Cminor stack block - (at positive offsets) and the frame of the function (at negative - offsets) in the abstract semantics. - - This intuition (activation record = Cminor stack data + frame) - is formalized by the following predicate [frame_match fr sp base mm ms]. - [fr] is a frame and [mm] the current memory state in the abstract - semantics. [ms] is the current memory state in the concrete semantics. - The stack pointer is [Vptr sp base] in both semantics. *) - -Inductive frame_match: frame -> block -> int -> mem -> mem -> Prop := - frame_match_intro: - forall fr sp base mm ms, - valid_block ms sp -> - low_bound mm sp = 0 -> - low_bound ms sp = fr.(low) -> - high_bound ms sp = align_16_top fr.(low) (high_bound mm sp) -> - fr.(low) <= 0 -> - Int.min_signed <= fr.(low) -> - base = Int.repr fr.(low) -> - block_contents_agree fr.(low) 0 fr (ms.(blocks) sp) -> - block_contents_agree 0 (high_bound ms sp) - (mm.(blocks) sp) (ms.(blocks) sp) -> - frame_match fr sp base mm ms. - -(** [frame_match], while presented as a relation for convenience, - is actually a function: it fully determines the contents of the - activation record [ms.(blocks) sp]. *) - -Lemma frame_match_exten: - forall fr sp base mm ms1 ms2, - frame_match fr sp base mm ms1 -> - frame_match fr sp base mm ms2 -> - ms1.(blocks) sp = ms2.(blocks) sp. -Proof. - intros. inversion H. inversion H0. - unfold low_bound, high_bound in *. - apply block_contents_exten. - congruence. - congruence. - hnf; intros. - elim H29. rewrite H3; rewrite H4; intros. - case (zlt ofs 0); intro. - assert (low fr <= ofs < 0). tauto. - transitivity (contents fr ofs). - symmetry. apply H8; auto. - apply H22; auto. - transitivity (contents (blocks mm sp) ofs). - symmetry. apply H9. rewrite H4. omega. - apply H23. rewrite H18. omega. -Qed. - -(** The following two innocuous-looking lemmas are the key results - showing that [sp]-relative memory accesses in the concrete - semantics behave like the direct frame accesses in the abstract - semantics. First, a value [v] that has type [ty] is preserved - when stored in memory with chunk [chunk_of_type ty], then read - back with the same chunk. The typing hypothesis is crucial here: - for instance, a float value reads back as [Vundef] when stored - and load with chunk [Mint32]. *) - -Lemma load_result_ty: - forall v ty, - Val.has_type v ty -> Val.load_result (chunk_of_type ty) v = v. -Proof. - destruct v; destruct ty; simpl; contradiction || reflexivity. -Qed. - -(** Second, computations of [sp]-relative offsets using machine - arithmetic (as done in the concrete semantics) never overflows - and behaves identically to the offset computations using exact - arithmetic (as done in the abstract semantics). *) - -Lemma int_add_no_overflow: - forall x y, - Int.min_signed <= Int.signed x + Int.signed y <= Int.max_signed -> - Int.signed (Int.add x y) = Int.signed x + Int.signed y. -Proof. - intros. rewrite Int.add_signed. rewrite Int.signed_repr. auto. auto. -Qed. - -(** Given matching frames and activation records, loading from the - activation record (in the concrete semantics) behaves identically - to reading the corresponding slot from the frame - (in the abstract semantics). *) - -Lemma frame_match_get_slot: - forall fr sp base mm ms ty ofs v, - frame_match fr sp base mm ms -> - get_slot fr ty (Int.signed ofs) v -> - Val.has_type v ty -> - load_stack ms (Vptr sp base) ty ofs = Some v. -Proof. - intros. inversion H. inversion H0. subst v. - unfold load_stack, Val.add, loadv. - assert (Int.signed base = low fr). - rewrite H8. apply Int.signed_repr. - split. auto. apply Zle_trans with 0. auto. compute; congruence. - assert (Int.signed (Int.add base ofs) = low fr + Int.signed ofs). - rewrite int_add_no_overflow. rewrite H18. auto. - rewrite H18. split. omega. apply Zle_trans with 0. - generalize (typesize_pos ty). omega. compute. congruence. - rewrite H23. - assert (BND1: low_bound ms sp <= low fr + Int.signed ofs). - omega. - assert (BND2: (low fr + Int.signed ofs) + size_chunk (chunk_of_type ty) <= high_bound ms sp). - rewrite size_type_chunk. apply Zle_trans with 0. - assumption. rewrite H5. apply align_16_top_pos. - generalize (load_in_bounds (chunk_of_type ty) ms sp (low fr + Int.signed ofs) H2 BND1 BND2). - intros [v' LOAD]. - generalize (load_inv _ _ _ _ _ LOAD). - intros [A [B [C D]]]. - rewrite LOAD. rewrite <- D. - decEq. rewrite mem_chunk_type. - rewrite <- size_mem_type in H17. - assert (low fr <= low fr + Int.signed ofs). omega. - generalize (load_contentmap_agree _ _ _ _ _ _ H9 H24 H17). - intro. rewrite H25. - apply load_result_ty. - assumption. -Qed. - -(** Loads from [sp], corresponding to accesses to Cminor stack data - in the abstract semantics, give the same results in the concrete - semantics. This is because the offset from [sp] must be positive or - null for the original load to succeed, and because the part - of the activation record at positive offsets matches the Cminor - stack data block. *) - -Lemma frame_match_load: - forall fr sp base mm ms chunk ofs v, - frame_match fr sp base mm ms -> - load chunk mm sp ofs = Some v -> - load chunk ms sp ofs = Some v. -Proof. - intros. inversion H. - generalize (load_inv _ _ _ _ _ H0). intros [A [B [C D]]]. - change (low (blocks mm sp)) with (low_bound mm sp) in B. - change (high (blocks mm sp)) with (high_bound mm sp) in C. - unfold load. rewrite zlt_true; auto. - rewrite in_bounds_holds. - rewrite <- D. decEq. decEq. eapply load_contentmap_agree. - red in H9. eexact H9. - omega. - unfold size_chunk in C. rewrite H4. - apply Zle_trans with (high_bound mm sp). auto. - apply align_16_top_ge. - change (low (blocks ms sp)) with (low_bound ms sp). - rewrite H3. omega. - change (high (blocks ms sp)) with (high_bound ms sp). - rewrite H4. apply Zle_trans with (high_bound mm sp). auto. - apply align_16_top_ge. -Qed. - -(** Assigning a value to a frame slot (in the abstract semantics) - corresponds to storing this value in the activation record - (in the concrete semantics). Moreover, agreement between frames - and activation records is preserved. *) - -Lemma frame_match_set_slot: - forall fr sp base mm ms ty ofs v fr', - frame_match fr sp base mm ms -> - set_slot fr ty (Int.signed ofs) v fr' -> - exists ms', - store_stack ms (Vptr sp base) ty ofs v = Some ms' /\ - frame_match fr' sp base mm ms'. -Proof. - intros. inversion H. inversion H0. subst ty0. - unfold store_stack, Val.add, storev. - assert (Int.signed base = low fr). - rewrite H7. apply Int.signed_repr. - split. auto. apply Zle_trans with 0. auto. compute; congruence. - assert (Int.signed (Int.add base ofs) = low fr + Int.signed ofs). - rewrite int_add_no_overflow. rewrite H16. auto. - rewrite H16. split. omega. apply Zle_trans with 0. - generalize (typesize_pos ty). omega. compute. congruence. - rewrite H20. - assert (BND1: low_bound ms sp <= low fr + Int.signed ofs). - omega. - assert (BND2: (low fr + Int.signed ofs) + size_chunk (chunk_of_type ty) <= high_bound ms sp). - rewrite size_type_chunk. rewrite H4. - apply Zle_trans with 0. subst ofs0. auto. apply align_16_top_pos. - generalize (store_in_bounds _ _ _ _ v H1 BND1 BND2). - intros [ms' STORE]. - generalize (store_inv _ _ _ _ _ _ STORE). intros [P [Q [R [S [x T]]]]]. - generalize (low_bound_store _ _ _ _ sp _ _ STORE). intro LB. - generalize (high_bound_store _ _ _ _ sp _ _ STORE). intro HB. - exists ms'. - split. exact STORE. - apply frame_match_intro; auto. - eapply valid_block_store; eauto. - rewrite LB. auto. - rewrite HB. auto. - red. rewrite T; rewrite update_s; simpl. - rewrite mem_chunk_type. - subst ofs0. eapply store_contentmap_agree; eauto. - rewrite HB; rewrite T; rewrite update_s. - red. simpl. apply store_contentmap_outside_agree. - assumption. left. rewrite mem_chunk_type. - rewrite size_mem_type. subst ofs0. auto. -Qed. - -(** Agreement is preserved by stores within blocks other than the - one pointed to by [sp]. *) - -Lemma frame_match_store_stack_other: - forall fr sp base mm ms sp' base' ty ofs v ms', - frame_match fr sp base mm ms -> - store_stack ms (Vptr sp' base') ty ofs v = Some ms' -> - sp <> sp' -> - frame_match fr sp base mm ms'. -Proof. - unfold store_stack, Val.add, storev. intros. inversion H. - generalize (store_inv _ _ _ _ _ _ H0). intros [P [Q [R [S [x T]]]]]. - generalize (low_bound_store _ _ _ _ sp _ _ H0). intro LB. - generalize (high_bound_store _ _ _ _ sp _ _ H0). intro HB. - apply frame_match_intro; auto. - eapply valid_block_store; eauto. - rewrite LB; auto. - rewrite HB; auto. - rewrite T; rewrite update_o; auto. - rewrite HB; rewrite T; rewrite update_o; auto. -Qed. - -(** Stores relative to [sp], corresponding to accesses to Cminor stack data - in the abstract semantics, give the same results in the concrete - semantics. Moreover, agreement between frames and activation - records is preserved. *) - -Lemma frame_match_store_ok: - forall fr sp base mm ms chunk ofs v mm', - frame_match fr sp base mm ms -> - store chunk mm sp ofs v = Some mm' -> - exists ms', store chunk ms sp ofs v = Some ms'. -Proof. - intros. inversion H. - generalize (store_inv _ _ _ _ _ _ H0). intros [P [Q [R [S [x T]]]]]. - change (low (blocks mm sp)) with (low_bound mm sp) in Q. - change (high (blocks mm sp)) with (high_bound mm sp) in R. - apply store_in_bounds. - auto. - omega. - apply Zle_trans with (high_bound mm sp). - auto. rewrite H4. apply align_16_top_ge. -Qed. - -Lemma frame_match_store: - forall fr sp base mm ms chunk b ofs v mm' ms', - frame_match fr sp base mm ms -> - store chunk mm b ofs v = Some mm' -> - store chunk ms b ofs v = Some ms' -> - frame_match fr sp base mm' ms'. -Proof. - intros. inversion H. - generalize (store_inv _ _ _ _ _ _ H1). intros [A [B [C [D [x1 E]]]]]. - generalize (store_inv _ _ _ _ _ _ H0). intros [I [J [K [L [x2 M]]]]]. - generalize (low_bound_store _ _ _ _ sp _ _ H0). intro LBm. - generalize (low_bound_store _ _ _ _ sp _ _ H1). intro LBs. - generalize (high_bound_store _ _ _ _ sp _ _ H0). intro HBm. - generalize (high_bound_store _ _ _ _ sp _ _ H1). intro HBs. - apply frame_match_intro; auto. - eapply valid_block_store; eauto. - congruence. congruence. congruence. - rewrite E. unfold update. case (zeq sp b); intro. - subst b. red; simpl. - apply store_contentmap_outside_agree; auto. - right. unfold low_bound in H3. omega. - assumption. - rewrite HBs; rewrite E; rewrite M; unfold update. - case (zeq sp b); intro. - subst b. red; simpl. - apply store_contentmap_agree; auto. - assumption. -Qed. - -(** Memory allocation of the Cminor stack data block (in the abstract - semantics) and of the whole activation record (in the concrete - semantics) return memory states that agree according to [frame_match]. - Moreover, [frame_match] relations over already allocated blocks - remain true. *) - -Lemma frame_match_new: - forall mm ms mm' ms' sp sp' f, - mm.(nextblock) = ms.(nextblock) -> - alloc mm 0 f.(fn_stacksize) = (mm', sp) -> - alloc ms (- f.(fn_framesize)) (align_16_top (- f.(fn_framesize)) f.(fn_stacksize)) = (ms', sp') -> - f.(fn_framesize) >= 0 -> - f.(fn_framesize) <= -Int.min_signed -> - frame_match (init_frame f) sp (Int.repr (-f.(fn_framesize))) mm' ms'. -Proof. - intros. - injection H0; intros. injection H1; intros. - assert (sp = sp'). congruence. rewrite <- H8 in H6. subst sp'. - generalize (low_bound_alloc _ _ sp _ _ _ H0). rewrite zeq_true. intro LBm. - generalize (low_bound_alloc _ _ sp _ _ _ H1). rewrite zeq_true. intro LBs. - generalize (high_bound_alloc _ _ sp _ _ _ H0). rewrite zeq_true. intro HBm. - generalize (high_bound_alloc _ _ sp _ _ _ H1). rewrite zeq_true. intro HBs. - apply frame_match_intro; auto. - eapply valid_new_block; eauto. - simpl. congruence. - simpl. omega. - simpl. omega. - rewrite <- H7. simpl. rewrite H6; simpl. rewrite update_s. - hnf; simpl; auto. - rewrite HBs; rewrite <- H5; simpl; rewrite H4; rewrite <- H7; simpl; rewrite H6; simpl; - repeat (rewrite update_s). - hnf; simpl; auto. -Qed. - -Lemma frame_match_alloc: - forall mm ms fr sp base lom him los his mm' ms' bm bs, - mm.(nextblock) = ms.(nextblock) -> - frame_match fr sp base mm ms -> - alloc mm lom him = (mm', bm) -> - alloc ms los his = (ms', bs) -> - frame_match fr sp base mm' ms'. -Proof. - intros. inversion H0. - assert (sp <> bm). - apply valid_not_valid_diff with mm. - red. rewrite H. exact H3. - eapply fresh_block_alloc; eauto. - assert (sp <> bs). - apply valid_not_valid_diff with ms. auto. - eapply fresh_block_alloc; eauto. - generalize (low_bound_alloc _ _ sp _ _ _ H1). - rewrite zeq_false; auto; intro LBm. - generalize (low_bound_alloc _ _ sp _ _ _ H2). - rewrite zeq_false; auto; intro LBs. - generalize (high_bound_alloc _ _ sp _ _ _ H1). - rewrite zeq_false; auto; intro HBm. - generalize (high_bound_alloc _ _ sp _ _ _ H2). - rewrite zeq_false; auto; intro HBs. - apply frame_match_intro. - eapply valid_block_alloc; eauto. - congruence. congruence. congruence. auto. auto. auto. - injection H2; intros. rewrite <- H20; simpl; rewrite H19; simpl. - rewrite update_o; auto. - rewrite HBs; - injection H2; intros. rewrite <- H20; simpl; rewrite H19; simpl. - injection H1; intros. rewrite <- H22; simpl; rewrite H21; simpl. - repeat (rewrite update_o; auto). -Qed. - -(** [frame_match] relations are preserved by freeing a block - other than the one pointed to by [sp]. *) - -Lemma frame_match_free: - forall fr sp base mm ms b, - frame_match fr sp base mm ms -> - sp <> b -> - frame_match fr sp base (free mm b) (free ms b). -Proof. - intros. inversion H. - generalize (low_bound_free mm _ _ H0); intro LBm. - generalize (low_bound_free ms _ _ H0); intro LBs. - generalize (high_bound_free mm _ _ H0); intro HBm. - generalize (high_bound_free ms _ _ H0); intro HBs. - apply frame_match_intro; auto. - congruence. congruence. congruence. - unfold free; simpl. rewrite update_o; auto. - rewrite HBs. - unfold free; simpl. repeat (rewrite update_o; auto). -Qed. - -(** ** Agreement for all the frames in a call stack *) - -(** We need to reason about all the frames and activation records - active at any given time during the executions: not just - about those for the currently executing function, but also - those for the callers. These collections of - active frames are called ``call stacks''. They are lists - of triples representing a frame and a stack pointer - (reference and offset) in the abstract semantics. *) - -Definition callstack : Set := list (frame * block * int). - -(** The correct linking of frames (each frame contains a pointer - to the frame of its caller at the lowest offset) is captured - by the following predicate. *) - -Inductive callstack_linked: callstack -> Prop := - | callstack_linked_nil: - callstack_linked nil - | callstack_linked_one: - forall fr1 sp1 base1, - callstack_linked ((fr1, sp1, base1) :: nil) - | callstack_linked_cons: - forall fr1 sp1 base1 fr2 base2 sp2 cs, - get_slot fr1 Tint 0 (Vptr sp2 base2) -> - callstack_linked ((fr2, sp2, base2) :: cs) -> - callstack_linked ((fr1, sp1, base1) :: (fr2, sp2, base2) :: cs). - -(** [callstack_dom cs b] (read: call stack [cs] is ``dominated'' - by block reference [b]) means that the stack pointers in [cs] - strictly decrease and are all below [b]. This ensures that - the stack block for a function was allocated after that for its - callers. A consequence is that no two active functions share - the same stack block. *) - -Inductive callstack_dom: callstack -> block -> Prop := - | callstack_dom_nil: - forall b, callstack_dom nil b - | callstack_dom_cons: - forall fr sp base cs b, - sp < b -> - callstack_dom cs sp -> - callstack_dom ((fr, sp, base) :: cs) b. - -Lemma callstack_dom_less: - forall cs b, callstack_dom cs b -> - forall fr sp base, In (fr, sp, base) cs -> sp < b. -Proof. - induction 1. simpl. tauto. - simpl. intros fr0 sp0 base0 [A|B]. - injection A; intros; subst fr0; subst sp0; subst base0. auto. - apply Zlt_trans with sp. eapply IHcallstack_dom; eauto. auto. -Qed. - -Lemma callstack_dom_diff: - forall cs b, callstack_dom cs b -> - forall fr sp base, In (fr, sp, base) cs -> sp <> b. -Proof. - intros. apply Zlt_not_eq. eapply callstack_dom_less; eauto. -Qed. - -Lemma callstack_dom_incr: - forall cs b, callstack_dom cs b -> - forall b', b < b' -> callstack_dom cs b'. -Proof. - induction 1; intros. - apply callstack_dom_nil. - apply callstack_dom_cons. omega. auto. -Qed. - -(** Every block reference is either ``in'' a call stack (that is, - refers to the stack block of one of the calls) or ``not in'' - a call stack (that is, differs from all the stack blocks). *) - -Inductive notin_callstack: block -> callstack -> Prop := - | notin_callstack_nil: - forall b, notin_callstack b nil - | notin_callstack_cons: - forall b fr sp base cs, - b <> sp -> - notin_callstack b cs -> - notin_callstack b ((fr, sp, base) :: cs). - -Lemma in_or_notin_callstack: - forall b cs, - (exists fr, exists base, In (fr, b, base) cs) \/ notin_callstack b cs. -Proof. - induction cs. - right; constructor. - elim IHcs. - intros [fr [base IN]]. left. exists fr; exists base; auto with coqlib. - intro NOTIN. destruct a. destruct p. case (eq_block b b0); intro. - left. exists f; exists i. subst b0. auto with coqlib. - right. apply notin_callstack_cons; auto. -Qed. - -(** [callstack_invariant cs mm ms] relates the memory state [mm] - from the abstract semantics with the memory state [ms] from the - concrete semantics, relative to the current call stack [cs]. - Five conditions are enforced: -- All frames in [cs] agree with the corresponding activation records - (in the sense of [frame_match]). -- The frames in the call stack are properly linked. -- Memory blocks that are not activation records for active function - calls are exactly identical in [mm] and [ms]. -- The allocation pointers are the same in [mm] and [ms]. -- The call stack [cs] is ``dominated'' by this allocation pointer, - implying that all activation records are valid, allocated blocks, - pairwise disjoint, and they were allocated in the order implied - by [cs]. *) - -Record callstack_invariant (cs: callstack) (mm ms: mem) : Prop := - mk_callstack_invariant { - cs_frame: - forall fr sp base, - In (fr, sp, base) cs -> frame_match fr sp base mm ms; - cs_linked: - callstack_linked cs; - cs_others: - forall b, notin_callstack b cs -> - mm.(blocks) b = ms.(blocks) b; - cs_next: - mm.(nextblock) = ms.(nextblock); - cs_dom: - callstack_dom cs ms.(nextblock) - }. - -(** Again, while [callstack_invariant] is presented as a relation, - it actually fully determines the concrete memory state [ms] - from the abstract memory state [mm] and the call stack [cs]. *) - -Lemma callstack_exten: - forall cs mm ms1 ms2, - callstack_invariant cs mm ms1 -> - callstack_invariant cs mm ms2 -> - ms1 = ms2. -Proof. - intros. inversion H; inversion H0. - apply mem_exten. - congruence. - intros. elim (in_or_notin_callstack b cs). - intros [fr [base FM]]. apply frame_match_exten with fr base mm; auto. - intro. transitivity (blocks mm b). - symmetry. auto. auto. -Qed. - -(** The following properties of [callstack_invariant] are the - building blocks for the proof of simulation. First, a [get_slot] - operation in the abstract semantics corresponds to a [sp]-relative - memory load in the concrete semantics. *) - -Lemma callstack_get_slot: - forall fr sp base cs mm ms ty ofs v, - callstack_invariant ((fr, sp, base) :: cs) mm ms -> - get_slot fr ty (Int.signed ofs) v -> - Val.has_type v ty -> - load_stack ms (Vptr sp base) ty ofs = Some v. -Proof. - intros. inversion H. - apply frame_match_get_slot with fr mm. - apply cs_frame0. apply in_eq. - auto. auto. -Qed. - -(** Similarly, a [get_parent] operation corresponds to loading - the back-link from the current activation record, then loading - from this back-link. *) - -Lemma callstack_get_parent: - forall fr1 sp1 base1 fr2 sp2 base2 cs mm ms ty ofs v, - callstack_invariant ((fr1, sp1, base1) :: (fr2, sp2, base2) :: cs) mm ms -> - get_slot fr2 ty (Int.signed ofs) v -> - Val.has_type v ty -> - load_stack ms (Vptr sp1 base1) Tint (Int.repr 0) = Some (Vptr sp2 base2) /\ - load_stack ms (Vptr sp2 base2) ty ofs = Some v. -Proof. - intros. inversion H. split. - inversion cs_linked0. - apply frame_match_get_slot with fr1 mm. - apply cs_frame0. auto with coqlib. - rewrite Int.signed_repr. auto. compute. intuition congruence. - exact I. - apply frame_match_get_slot with fr2 mm. - apply cs_frame0. auto with coqlib. - auto. auto. -Qed. - -(** A memory load valid in the abstract semantics can also be performed - in the concrete semantics. *) - -Lemma callstack_load: - forall cs chunk mm ms a v, - callstack_invariant cs mm ms -> - loadv chunk mm a = Some v -> - loadv chunk ms a = Some v. -Proof. - unfold loadv. intros. destruct a; try discriminate. - inversion H. - elim (in_or_notin_callstack b cs). - intros [fr [base IN]]. apply frame_match_load with fr base mm; auto. - intro. rewrite <- H0. unfold load. - rewrite (cs_others0 b H1). rewrite cs_next0. reflexivity. -Qed. - -(** A [set_slot] operation in the abstract semantics corresponds - to a [sp]-relative memory store in the concrete semantics. - Moreover, the property [callstack_invariant] still holds for - the final call stacks and memory states. *) - -Lemma callstack_set_slot: - forall fr sp base cs mm ms ty ofs v fr', - callstack_invariant ((fr, sp, base) :: cs) mm ms -> - set_slot fr ty (Int.signed ofs) v fr' -> - 4 <= Int.signed ofs -> - exists ms', - store_stack ms (Vptr sp base) ty ofs v = Some ms' /\ - callstack_invariant ((fr', sp, base) :: cs) mm ms'. -Proof. - intros. inversion H. - assert (frame_match fr sp base mm ms). apply cs_frame0. apply in_eq. - generalize (frame_match_set_slot _ _ _ _ _ _ _ _ _ H2 H0). - intros [ms' [SS FM]]. - generalize (store_inv _ _ _ _ _ _ SS). intros [A [B [C [D [x E]]]]]. - exists ms'. - split. auto. - constructor. - (* cs_frame *) - intros. elim H3; intros. - injection H4; intros; clear H4. - subst fr0; subst sp0; subst base0. auto. - apply frame_match_store_stack_other with ms sp base ty ofs v. - apply cs_frame0. auto with coqlib. auto. - apply callstack_dom_diff with cs fr0 base0. inversion cs_dom0; auto. auto. - (* cs_linked *) - inversion cs_linked0. apply callstack_linked_one. - apply callstack_linked_cons. - eapply slot_gso; eauto. - auto. - (* cs_others *) - intros. inversion H3. - rewrite E; simpl. rewrite update_o; auto. apply cs_others0. - constructor; auto. - (* cs_next *) - congruence. - (* cs_dom *) - inversion cs_dom0. constructor. rewrite D; auto. auto. -Qed. - -(** A memory store in the abstract semantics can also be performed - in the concrete semantics. Moreover, the property - [callstack_invariant] is preserved. *) - -Lemma callstack_store_aux: - forall cs mm ms chunk b ofs v mm' ms', - callstack_invariant cs mm ms -> - store chunk mm b ofs v = Some mm' -> - store chunk ms b ofs v = Some ms' -> - callstack_invariant cs mm' ms'. -Proof. - intros. inversion H. - generalize (store_inv _ _ _ _ _ _ H0). intros [A [B [C [D [x E]]]]]. - generalize (store_inv _ _ _ _ _ _ H1). intros [P [Q [R [S [y T]]]]]. - constructor; auto. - (* cs_frame *) - intros. eapply frame_match_store; eauto. - (* cs_others *) - intros. generalize (cs_others0 b0 H2); intro. - rewrite E; rewrite T; unfold update. - case (zeq b0 b); intro. - subst b0. - generalize x; generalize y. rewrite H3. - intros. replace y0 with x0. reflexivity. apply proof_irrelevance. - auto. - (* cs_nextblock *) - congruence. - (* cs_dom *) - rewrite S. auto. -Qed. - -Lemma callstack_store_ok: - forall cs mm ms chunk b ofs v mm', - callstack_invariant cs mm ms -> - store chunk mm b ofs v = Some mm' -> - exists ms', store chunk ms b ofs v = Some ms'. -Proof. - intros. inversion H. - elim (in_or_notin_callstack b cs). - intros [fr [base IN]]. - apply frame_match_store_ok with fr base mm mm'; auto. - intro. generalize (cs_others0 b H1). intro. - generalize (store_inv _ _ _ _ _ _ H0). - rewrite cs_next0; rewrite H2. intros [A [B [C [D [x E]]]]]. - apply store_in_bounds; auto. -Qed. - -Lemma callstack_store: - forall cs mm ms chunk a v mm', - callstack_invariant cs mm ms -> - storev chunk mm a v = Some mm' -> - exists ms', - storev chunk ms a v = Some ms' /\ - callstack_invariant cs mm' ms'. -Proof. - unfold storev; intros. destruct a; try discriminate. - generalize (callstack_store_ok _ _ _ _ _ _ _ _ H H0). - intros [ms' STORE]. - exists ms'. split. auto. eapply callstack_store_aux; eauto. -Qed. - -(** Allocations of heap blocks can be performed in parallel in - both semantics, preserving [callstack_invariant]. *) - -Lemma callstack_alloc: - forall cs mm ms lo hi mm' blk, - callstack_invariant cs mm ms -> - Mem.alloc mm lo hi = (mm', blk) -> - exists ms', - Mem.alloc ms lo hi = (ms', blk) /\ - callstack_invariant cs mm' ms'. -Proof. - intros. inversion H. - caseEq (alloc ms lo hi). intros ms' blk' ALLOC'. - injection H0; intros. injection ALLOC'; intros. - assert (blk' = blk). congruence. rewrite H5 in H3. rewrite H5. - exists ms'; split. auto. - constructor. - (* frame *) - intros; eapply frame_match_alloc; eauto. - (* linked *) - auto. - (* others *) - intros. rewrite <- H2; rewrite <- H4; simpl. - rewrite H1; rewrite H3. unfold update. case (zeq b blk); auto. - (* next *) - rewrite <- H2; rewrite <- H4; simpl; congruence. - (* dom *) - eapply callstack_dom_incr; eauto. rewrite <- H4; simpl. omega. -Qed. - -(** At function entry, a new frame is pushed on the call stack, - and memory blocks are allocated in both semantics. Moreover, - the back link to the caller's activation record is set up - in the concrete semantics. All this preserves [callstack_invariant]. *) - -Lemma callstack_function_entry: - forall fr0 sp0 base0 cs mm ms f fr mm' sp ms' sp', - callstack_invariant ((fr0, sp0, base0) :: cs) mm ms -> - alloc mm 0 f.(fn_stacksize) = (mm', sp) -> - alloc ms (- f.(fn_framesize)) (align_16_top (- f.(fn_framesize)) f.(fn_stacksize)) = (ms', sp') -> - f.(fn_framesize) >= 0 -> - f.(fn_framesize) <= -Int.min_signed -> - set_slot (init_frame f) Tint 0 (Vptr sp0 base0) fr -> - let base := Int.repr (-f.(fn_framesize)) in - exists ms'', - store_stack ms' (Vptr sp base) Tint (Int.repr 0) (Vptr sp0 base0) = Some ms'' - /\ callstack_invariant ((fr, sp, base) :: (fr0, sp0, base0) :: cs) mm' ms'' - /\ sp' = sp. -Proof. - assert (ZERO: 0 = Int.signed (Int.repr 0)). - rewrite Int.signed_repr. auto. compute; intuition congruence. - intros. inversion H. - injection H0; intros. injection H1; intros. - assert (sp' = sp). congruence. rewrite H9 in H7. subst sp'. - assert (frame_match (init_frame f) sp base mm' ms'). - unfold base. eapply frame_match_new; eauto. - rewrite ZERO in H4. - generalize (frame_match_set_slot _ _ _ _ _ _ _ _ _ H9 H4). - intros [ms'' [SS FM]]. - generalize (store_inv _ _ _ _ _ _ SS). - intros [A [B [C [D [x E]]]]]. - exists ms''. split; auto. split. - constructor. - (* cs_frame *) - intros. elim H10; intro. - injection H11; intros; clear H11. - subst fr1; subst sp1; subst base1. auto. - eapply frame_match_store_stack_other; eauto. - eapply frame_match_alloc; [idtac|idtac|eexact H0|eexact H1]. - congruence. eapply cs_frame; eauto with coqlib. - rewrite <- H7. eapply callstack_dom_diff; eauto with coqlib. - (* cs_linked *) - constructor. rewrite ZERO. eapply slot_gss; eauto. auto. - (* cs_others *) - intros. inversion H10. - rewrite E; rewrite update_o; auto. - rewrite <- H6; rewrite <- H8; simpl; rewrite H5; rewrite H7; simpl. - repeat (rewrite update_o; auto). - (* cs_next *) - rewrite D. rewrite <- H6; rewrite <- H8; simpl. congruence. - (* cs_dom *) - constructor. rewrite D; auto. rewrite <- H7. auto. - auto. -Qed. - -(** At function return, the memory blocks corresponding to Cminor - stack data and activation record for the function are freed. - This preserves [callstack_invariant]. *) - -Lemma callstack_function_return: - forall fr sp base cs mm ms, - callstack_invariant ((fr, sp, base) :: cs) mm ms -> - callstack_invariant cs (free mm sp) (free ms sp). -Proof. - intros. inversion H. inversion cs_dom0. - constructor. - (* cs_frame *) - intros. apply frame_match_free. apply cs_frame0; auto with coqlib. - apply callstack_dom_diff with cs fr1 base1. auto. auto. - (* cs_linked *) - inversion cs_linked0. apply callstack_linked_nil. auto. - (* cs_others *) - intros. - unfold free; simpl; unfold update. - case (zeq b0 sp); intro. - auto. - apply cs_others0. apply notin_callstack_cons; auto. - (* cs_nextblock *) - simpl. auto. - (* cs_dom *) - simpl. apply callstack_dom_incr with sp; auto. -Qed. - -(** Finally, [callstack_invariant] holds for the initial memory states - in the two semantics. *) - -Lemma callstack_init: - forall (p: program), - callstack_invariant ((empty_frame, nullptr, Int.zero) :: nil) - (Genv.init_mem p) (Genv.init_mem p). -Proof. - intros. - generalize (Genv.initmem_nullptr p). intros [A B]. - constructor. - (* cs_frame *) - intros. elim H; intro. - injection H0; intros; subst fr; subst sp; subst base. - constructor. - assumption. - unfold low_bound. rewrite B. reflexivity. - unfold low_bound, empty_frame. rewrite B. reflexivity. - unfold high_bound. rewrite B. reflexivity. - simpl. omega. - simpl. compute. intuition congruence. - reflexivity. - rewrite B. unfold empty_frame. simpl. hnf. auto. - rewrite B. hnf. auto. - elim H0. - (* cs_linked *) - apply callstack_linked_one. - (* cs_others *) - auto. - (* cs_nextblock *) - reflexivity. - (* cs_dom *) - constructor. exact A. constructor. -Qed. - -(** Preservation of arguments to external functions. *) - -Lemma transl_extcall_arguments: - forall rs fr sg args stk base cs m ms, - Machabstr.extcall_arguments rs fr sg args -> - callstack_invariant ((fr, stk, base) :: cs) m ms -> - wt_frame fr -> - extcall_arguments rs ms (Vptr stk base) sg args. -Proof. - unfold Machabstr.extcall_arguments, extcall_arguments; intros. - assert (forall locs vals, - Machabstr.extcall_args rs fr locs vals -> - extcall_args rs ms (Vptr stk base) locs vals). - induction locs; intros; inversion H2; subst; clear H2. - constructor. - constructor; auto. - inversion H7; subst; clear H7. - constructor. - constructor. eapply callstack_get_slot; eauto. - eapply wt_get_slot; eauto. - auto. -Qed. - -(** * The proof of simulation *) - -Section SIMULATION. - -Variable p: program. -Hypothesis wt_p: wt_program p. -Let ge := Genv.globalenv p. - -(** The proof of simulation relies on diagrams of the following form: -<< - sp, parent, c, rs, fr, mm ----------- sp, c, rs, ms - | | - | | - v v - sp, parent, c', rs', fr', mm' -------- sp, c', rs', ms' ->> - The left vertical arrow is a transition in the abstract semantics. - The right vertical arrow is a transition in the concrete semantics. - The precondition (top horizontal line) is the appropriate - [callstack_invariant] property between the initial memory states - [mm] and [ms] and any call stack with [fr] as top frame and - [parent] as second frame. In addition, well-typedness conditions - over the code [c], the register [rs] and the frame [fr] are demanded. - The postcondition (bottom horizontal line) is [callstack_invariant] - between the final memory states [mm'] and [ms'] and the final - call stack. -*) - -Definition exec_instr_prop - (f: function) (sp: val) (parent: frame) - (c: code) (rs: regset) (fr: frame) (mm: mem) (t: trace) - (c': code) (rs': regset) (fr': frame) (mm': mem) : Prop := - forall ms stk base pstk pbase cs - (WTF: wt_function f) - (INCL: incl c f.(fn_code)) - (WTRS: wt_regset rs) - (WTFR: wt_frame fr) - (WTPA: wt_frame parent) - (CSI: callstack_invariant ((fr, stk, base) :: (parent, pstk, pbase) :: cs) mm ms) - (SP: sp = Vptr stk base), - exists ms', - exec_instr ge f sp c rs ms t c' rs' ms' /\ - callstack_invariant ((fr', stk, base) :: (parent, pstk, pbase) :: cs) mm' ms'. - -Definition exec_instrs_prop - (f: function) (sp: val) (parent: frame) - (c: code) (rs: regset) (fr: frame) (mm: mem) (t: trace) - (c': code) (rs': regset) (fr': frame) (mm': mem) : Prop := - forall ms stk base pstk pbase cs - (WTF: wt_function f) - (INCL: incl c f.(fn_code)) - (WTRS: wt_regset rs) - (WTFR: wt_frame fr) - (WTPA: wt_frame parent) - (CSI: callstack_invariant ((fr, stk, base) :: (parent, pstk, pbase) :: cs) mm ms) - (SP: sp = Vptr stk base), - exists ms', - exec_instrs ge f sp c rs ms t c' rs' ms' /\ - callstack_invariant ((fr', stk, base) :: (parent, pstk, pbase) :: cs) mm' ms'. - -Definition exec_function_body_prop - (f: function) (parent: frame) (link ra: val) - (rs: regset) (mm: mem) (t: trace) - (rs': regset) (mm': mem) : Prop := - forall ms pstk pbase cs - (WTF: wt_function f) - (WTRS: wt_regset rs) - (WTPA: wt_frame parent) - (WTRA: Val.has_type ra Tint) - (LINK: link = Vptr pstk pbase) - (CSI: callstack_invariant ((parent, pstk, pbase) :: cs) mm ms), - exists ms', - exec_function_body ge f (Vptr pstk pbase) ra rs ms t rs' ms' /\ - callstack_invariant ((parent, pstk, pbase) :: cs) mm' ms'. - -Definition exec_function_prop - (f: fundef) (parent: frame) - (rs: regset) (mm: mem) (t: trace) - (rs': regset) (mm': mem) : Prop := - forall ms pstk pbase cs - (WTF: wt_fundef f) - (WTRS: wt_regset rs) - (WTPA: wt_frame parent) - (CSI: callstack_invariant ((parent, pstk, pbase) :: cs) mm ms), - exists ms', - exec_function ge f (Vptr pstk pbase) rs ms t rs' ms' /\ - callstack_invariant ((parent, pstk, pbase) :: cs) mm' ms'. - -Lemma exec_function_equiv: - forall f parent rs mm t rs' mm', - Machabstr.exec_function ge f parent rs mm t rs' mm' -> - exec_function_prop f parent rs mm t rs' mm'. -Proof. - apply (Machabstr.exec_function_ind4 ge - exec_instr_prop - exec_instrs_prop - exec_function_body_prop - exec_function_prop); - intros; red; intros. - - (* Mlabel *) - exists ms. split. constructor. auto. - (* Mgetstack *) - exists ms. split. - constructor. rewrite SP. eapply callstack_get_slot; eauto. - apply wt_get_slot with fr (Int.signed ofs); auto. - auto. - (* Msetstack *) - generalize (wt_function_instrs f WTF _ (INCL _ (in_eq _ _))). - intro WTI. inversion WTI. - assert (4 <= Int.signed ofs). omega. - generalize (callstack_set_slot _ _ _ _ _ _ _ _ _ _ CSI H H5). - intros [ms' [STO CSI']]. - exists ms'. split. constructor. rewrite SP. auto. auto. - (* Mgetparam *) - exists ms. split. - assert (WTV: Val.has_type v ty). eapply wt_get_slot; eauto. - generalize (callstack_get_parent _ _ _ _ _ _ _ _ _ _ _ _ - CSI H WTV). - intros [L1 L2]. - eapply exec_Mgetparam. rewrite SP; eexact L1. eexact L2. - auto. - (* Mop *) - exists ms. split. constructor. auto. auto. - (* Mload *) - exists ms. split. econstructor. eauto. eapply callstack_load; eauto. - auto. - (* Mstore *) - generalize (callstack_store _ _ _ _ _ _ _ CSI H0). - intros [ms' [STO CSI']]. - exists ms'. split. econstructor. eauto. auto. - auto. - (* Mcall *) - red in H1. - assert (WTF': wt_fundef f'). - destruct ros; simpl in H. - apply (Genv.find_funct_prop wt_fundef wt_p H). - destruct (Genv.find_symbol ge i); try discriminate. - apply (Genv.find_funct_ptr_prop wt_fundef wt_p H). - generalize (H1 _ _ _ _ WTF' WTRS WTFR CSI). - intros [ms' [EXF CSI']]. - exists ms'. split. apply exec_Mcall with f'; auto. - rewrite SP. auto. - auto. - (* Malloc *) - generalize (callstack_alloc _ _ _ _ _ _ _ CSI H0). - intros [ms' [ALLOC' CSI']]. - exists ms'; split. - eapply exec_Malloc; eauto. - auto. - (* Mgoto *) - exists ms. split. constructor; auto. auto. - (* Mcond *) - exists ms. split. apply exec_Mcond_true; auto. auto. - exists ms. split. apply exec_Mcond_false; auto. auto. - - (* refl *) - exists ms. split. apply exec_refl. auto. - (* one *) - generalize (H0 _ _ _ _ _ _ WTF INCL WTRS WTFR WTPA CSI SP). - intros [ms' [EX CSI']]. - exists ms'. split. apply exec_one; auto. auto. - (* trans *) - generalize (subject_reduction_instrs p wt_p - _ _ _ _ _ _ _ _ _ _ _ _ H WTF INCL WTRS WTFR WTPA). - intros [INCL2 [WTRS2 WTFR2]]. - generalize (H0 _ _ _ _ _ _ WTF INCL WTRS WTFR WTPA CSI SP). - intros [ms1 [EX1 CSI1]]. - generalize (H2 _ _ _ _ _ _ WTF INCL2 WTRS2 WTFR2 WTPA CSI1 SP). - intros [ms2 [EX2 CSI2]]. - exists ms2. split. eapply exec_trans; eauto. auto. - - (* function body *) - caseEq (alloc ms (- f.(fn_framesize)) - (align_16_top (- f.(fn_framesize)) f.(fn_stacksize))). - intros ms1 stk1 ALL. - subst link. - assert (FS: f.(fn_framesize) >= 0). - generalize (wt_function_framesize f WTF). omega. - generalize (callstack_function_entry _ _ _ _ _ _ _ _ _ _ _ _ - CSI H ALL FS - (wt_function_no_overflow f WTF) H0). - intros [ms2 [STORELINK [CSI2 EQ]]]. - subst stk1. - assert (ZERO: Int.signed (Int.repr 0) = 0). reflexivity. - assert (TWELVE: Int.signed (Int.repr 12) = 12). reflexivity. - assert (BND: 4 <= Int.signed (Int.repr 12)). - rewrite TWELVE; omega. - rewrite <- TWELVE in H1. - generalize (callstack_set_slot _ _ _ _ _ _ _ _ _ _ - CSI2 H1 BND). - intros [ms3 [STORERA CSI3]]. - assert (WTFR2: wt_frame fr2). - eapply wt_set_slot; eauto. eapply wt_set_slot; eauto. - red. intros. simpl. auto. - exact I. - red in H3. - generalize (H3 _ _ _ _ _ _ WTF (incl_refl _) WTRS WTFR2 WTPA - CSI3 (refl_equal _)). - intros [ms4 [EXEC CSI4]]. - generalize (exec_instrs_link_invariant _ _ _ _ _ _ _ _ _ _ _ _ _ - H2 WTF (incl_refl _)). - intros [INCL LINKINV]. - exists (free ms4 stk). split. - eapply exec_funct_body; eauto. - eapply callstack_get_slot. eexact CSI4. - apply LINKINV. rewrite ZERO. omega. - eapply slot_gso; eauto. rewrite ZERO. eapply slot_gss; eauto. - exact I. - eapply callstack_get_slot. eexact CSI4. - apply LINKINV. rewrite TWELVE. omega. eapply slot_gss; eauto. auto. - eapply callstack_function_return; eauto. - - (* internal function *) - inversion WTF. subst f0. - generalize (H0 (Vptr pstk pbase) Vzero I I - ms pstk pbase cs H2 WTRS WTPA I (refl_equal _) CSI). - intros [ms' [EXEC CSI']]. - exists ms'. split. constructor. intros. - generalize (H0 (Vptr pstk pbase) ra I H1 - ms pstk pbase cs H2 WTRS WTPA H1 (refl_equal _) CSI). - intros [ms1 [EXEC1 CSI1]]. - rewrite (callstack_exten _ _ _ _ CSI' CSI1). auto. - auto. - - (* external function *) - exists ms; split. econstructor; eauto. - eapply transl_extcall_arguments; eauto. - auto. -Qed. - -End SIMULATION. - -Theorem exec_program_equiv: - forall p t r, - wt_program p -> - Machabstr.exec_program p t r -> - Mach.exec_program p t r. -Proof. - intros p t r WTP [fptr [f [rs [mm [FINDPTR [FINDF [EXEC RES]]]]]]]. - assert (WTF: wt_fundef f). - apply (Genv.find_funct_ptr_prop wt_fundef WTP FINDF). - assert (WTRS: wt_regset (Regmap.init Vundef)). - red; intros. rewrite Regmap.gi; simpl; auto. - assert (WTFR: wt_frame empty_frame). - red; intros. simpl. auto. - generalize (exec_function_equiv p WTP - f empty_frame - (Regmap.init Vundef) (Genv.init_mem p) t rs mm - EXEC (Genv.init_mem p) nullptr Int.zero nil - WTF WTRS WTFR (callstack_init p)). - intros [ms' [EXEC' CSI]]. - red. exists fptr; exists f; exists rs; exists ms'. tauto. -Qed. diff --git a/backend/Machconcr.v b/backend/Machconcr.v new file mode 100644 index 00000000..fe9a7d90 --- /dev/null +++ b/backend/Machconcr.v @@ -0,0 +1,250 @@ +(** The Mach intermediate language: concrete semantics. *) + +Require Import Coqlib. +Require Import Maps. +Require Import AST. +Require Import Integers. +Require Import Values. +Require Import Mem. +Require Import Events. +Require Import Globalenvs. +Require Import Smallstep. +Require Import Op. +Require Import Locations. +Require Conventions. +Require Import Mach. +Require PPCgenretaddr. + +(** In the concrete semantics for Mach, the three stack-related Mach + instructions are interpreted as memory accesses relative to the + stack pointer. More precisely: +- [Mgetstack ofs ty r] is a memory load at offset [ofs * 4] relative + to the stack pointer. +- [Msetstack r ofs ty] is a memory store at offset [ofs * 4] relative + to the stack pointer. +- [Mgetparam ofs ty r] is a memory load at offset [ofs * 4] + relative to the pointer found at offset 0 from the stack pointer. + The semantics maintain a linked structure of activation records, + with the current record containing a pointer to the record of the + caller function at offset 0. + +In addition to this linking of activation records, the concrete +semantics also make provisions for storing a return address +at offset 12 from the stack pointer. This stack location will +be used by the PPC code generated by [PPCgen] to save the return +address into the caller at the beginning of a function, then restore +it and jump to it at the end of a function. The Mach concrete +semantics does not attach any particular meaning to the pointer +stored in this reserved location, but makes sure that it is preserved +during execution of a function. The [return_address_offset] predicate +from module [PPCgenretaddr] is used to guess the value of the return +address that the PPC code generated later will store in the +reserved location. +*) + +Definition chunk_of_type (ty: typ) := + match ty with Tint => Mint32 | Tfloat => Mfloat64 end. + +Definition load_stack (m: mem) (sp: val) (ty: typ) (ofs: int) := + Mem.loadv (chunk_of_type ty) m (Val.add sp (Vint ofs)). + +Definition store_stack (m: mem) (sp: val) (ty: typ) (ofs: int) (v: val) := + Mem.storev (chunk_of_type ty) m (Val.add sp (Vint ofs)) v. + +(** Extract the values of the arguments of an external call. *) + +Inductive extcall_arg: regset -> mem -> val -> loc -> val -> Prop := + | extcall_arg_reg: forall rs m sp r, + extcall_arg rs m sp (R r) (rs r) + | extcall_arg_stack: forall rs m sp ofs ty v, + load_stack m sp ty (Int.repr (4 * ofs)) = Some v -> + extcall_arg rs m sp (S (Outgoing ofs ty)) v. + +Inductive extcall_args: regset -> mem -> val -> list loc -> list val -> Prop := + | extcall_args_nil: forall rs m sp, + extcall_args rs m sp nil nil + | extcall_args_cons: forall rs m sp l1 ll v1 vl, + extcall_arg rs m sp l1 v1 -> extcall_args rs m sp ll vl -> + extcall_args rs m sp (l1 :: ll) (v1 :: vl). + +Definition extcall_arguments + (rs: regset) (m: mem) (sp: val) (sg: signature) (args: list val) : Prop := + extcall_args rs m sp (Conventions.loc_arguments sg) args. + +(** The components of an execution state are: + +- [State cs f sp c rs m]: [f] is the block reference corresponding + to the function currently executing. [sp] is the stack pointer. + [c] is the list of instructions that remain to be executed. + [rs] assigns values to registers. [m] is the memory state. +- [Callstate cs f rs m]: [f] is the block reference corresponding + to the function being called. [rs] is the current values of registers, + and [m] the current memory state. +- [Returnstate cs rs m]: [rs] is the current values of registers, + and [m] the current memory state. + +[cs] is a list of stack frames [Stackframe f sp retaddr c], +where [f] is the block reference for the calling function, +[c] the code within this function that follows the call instruction, +[sp] its stack pointer, and [retaddr] the return address predicted +by [PPCgenretaddr.return_address_offset]. +*) + +Inductive stackframe: Set := + | Stackframe: + forall (f: block) (sp retaddr: val) (c: code), + stackframe. + +Inductive state: Set := + | State: + forall (stack: list stackframe) (f: block) (sp: val) + (c: code) (rs: regset) (m: mem), + state + | Callstate: + forall (stack: list stackframe) (f: block) (rs: regset) (m: mem), + state + | Returnstate: + forall (stack: list stackframe) (rs: regset) (m: mem), + state. + +Definition parent_sp (s: list stackframe) : val := + match s with + | nil => Vptr Mem.nullptr Int.zero + | Stackframe f sp ra c :: s' => sp + end. + +Definition parent_ra (s: list stackframe) : val := + match s with + | nil => Vzero + | Stackframe f sp ra c :: s' => ra + end. + +Section RELSEM. + +Variable ge: genv. + +Inductive step: state -> trace -> state -> Prop := + | exec_Mlabel: + forall s f sp lbl c rs m, + step (State s f sp (Mlabel lbl :: c) rs m) + E0 (State s f sp c rs m) + | exec_Mgetstack: + forall s f sp ofs ty dst c rs m v, + load_stack m sp ty ofs = Some v -> + step (State s f sp (Mgetstack ofs ty dst :: c) rs m) + E0 (State s f sp c (rs#dst <- v) m) + | exec_Msetstack: + forall s f sp src ofs ty c rs m m', + store_stack m sp ty ofs (rs src) = Some m' -> + step (State s f sp (Msetstack src ofs ty :: c) rs m) + E0 (State s f sp c rs m') + | exec_Mgetparam: + forall s f sp parent ofs ty dst c rs m v, + load_stack m sp Tint (Int.repr 0) = Some parent -> + load_stack m parent ty ofs = Some v -> + step (State s f sp (Mgetparam ofs ty dst :: c) rs m) + E0 (State s f sp c (rs#dst <- v) m) + | exec_Mop: + forall s f sp op args res c rs m v, + eval_operation ge sp op rs##args m = Some v -> + step (State s f sp (Mop op args res :: c) rs m) + E0 (State s f sp c (rs#res <- v) m) + | exec_Mload: + forall s f sp chunk addr args dst c rs m a v, + eval_addressing ge sp addr rs##args = Some a -> + Mem.loadv chunk m a = Some v -> + step (State s f sp (Mload chunk addr args dst :: c) rs m) + E0 (State s f sp c (rs#dst <- v) m) + | exec_Mstore: + forall s f sp chunk addr args src c rs m m' a, + eval_addressing ge sp addr rs##args = Some a -> + Mem.storev chunk m a (rs src) = Some m' -> + step (State s f sp (Mstore chunk addr args src :: c) rs m) + E0 (State s f sp c rs m') + | exec_Mcall: + forall s fb sp sig ros c rs m f f' ra, + find_function_ptr ge ros rs = Some f' -> + Genv.find_funct_ptr ge fb = Some (Internal f) -> + PPCgenretaddr.return_address_offset f c ra -> + step (State s fb sp (Mcall sig ros :: c) rs m) + E0 (Callstate (Stackframe fb sp (Vptr fb ra) c :: s) + f' rs m) + | exec_Mtailcall: + forall s fb stk soff sig ros c rs m f', + find_function_ptr ge ros rs = Some f' -> + load_stack m (Vptr stk soff) Tint (Int.repr 0) = Some (parent_sp s) -> + load_stack m (Vptr stk soff) Tint (Int.repr 12) = Some (parent_ra s) -> + step (State s fb (Vptr stk soff) (Mtailcall sig ros :: c) rs m) + E0 (Callstate s f' rs (Mem.free m stk)) + | exec_Malloc: + forall s f sp c rs m sz m' blk, + rs (Conventions.loc_alloc_argument) = Vint sz -> + Mem.alloc m 0 (Int.signed sz) = (m', blk) -> + step (State s f sp (Malloc :: c) rs m) + E0 (State s f sp c + (rs#Conventions.loc_alloc_result <- (Vptr blk Int.zero)) + m') + | exec_Mgoto: + forall s fb f sp lbl c rs m c', + Genv.find_funct_ptr ge fb = Some (Internal f) -> + find_label lbl f.(fn_code) = Some c' -> + step (State s fb sp (Mgoto lbl :: c) rs m) + E0 (State s fb sp c' rs m) + | exec_Mcond_true: + forall s fb f sp cond args lbl c rs m c', + eval_condition cond rs##args m = Some true -> + Genv.find_funct_ptr ge fb = Some (Internal f) -> + find_label lbl f.(fn_code) = Some c' -> + step (State s fb sp (Mcond cond args lbl :: c) rs m) + E0 (State s fb sp c' rs m) + | exec_Mcond_false: + forall s f sp cond args lbl c rs m, + eval_condition cond rs##args m = Some false -> + step (State s f sp (Mcond cond args lbl :: c) rs m) + E0 (State s f sp c rs m) + | exec_Mreturn: + forall s f stk soff c rs m, + load_stack m (Vptr stk soff) Tint (Int.repr 0) = Some (parent_sp s) -> + load_stack m (Vptr stk soff) Tint (Int.repr 12) = Some (parent_ra s) -> + step (State s f (Vptr stk soff) (Mreturn :: c) rs m) + E0 (Returnstate s rs (Mem.free m stk)) + | exec_function_internal: + forall s fb rs m f m1 m2 m3 stk, + Genv.find_funct_ptr ge fb = Some (Internal f) -> + Mem.alloc m (- f.(fn_framesize)) + (align_16_top (- f.(fn_framesize)) f.(fn_stacksize)) + = (m1, stk) -> + let sp := Vptr stk (Int.repr (-f.(fn_framesize))) in + store_stack m1 sp Tint (Int.repr 0) (parent_sp s) = Some m2 -> + store_stack m2 sp Tint (Int.repr 12) (parent_ra s) = Some m3 -> + step (Callstate s fb rs m) + E0 (State s fb sp f.(fn_code) rs m3) + | exec_function_external: + forall s fb rs m t rs' ef args res, + Genv.find_funct_ptr ge fb = Some (External ef) -> + event_match ef args t res -> + extcall_arguments rs m (parent_sp s) ef.(ef_sig) args -> + rs' = (rs#(Conventions.loc_result ef.(ef_sig)) <- res) -> + step (Callstate s fb rs m) + t (Returnstate s rs' m) + | exec_return: + forall s f sp ra c rs m, + step (Returnstate (Stackframe f sp ra c :: s) rs m) + E0 (State s f sp c rs m). + +End RELSEM. + +Inductive initial_state (p: program): state -> Prop := + | initial_state_intro: forall fb, + let ge := Genv.globalenv p in + let m0 := Genv.init_mem p in + Genv.find_symbol ge p.(prog_main) = Some fb -> + initial_state p (Callstate nil fb (Regmap.init Vundef) m0). + +Inductive final_state: state -> int -> Prop := + | final_state_intro: forall rs m r, + rs R3 = Vint r -> + final_state (Returnstate nil rs m) r. + +Definition exec_program (p: program) (beh: program_behavior) : Prop := + program_behaves step (initial_state p) final_state (Genv.globalenv p) beh. diff --git a/backend/Machtyping.v b/backend/Machtyping.v index ad3ee886..28037cec 100644 --- a/backend/Machtyping.v +++ b/backend/Machtyping.v @@ -26,7 +26,7 @@ Inductive wt_instr : instruction -> Prop := wt_instr (Mgetstack ofs ty r) | wt_Msetstack: forall ofs ty r, - mreg_type r = ty -> 24 <= Int.signed ofs -> + mreg_type r = ty -> wt_instr (Msetstack r ofs ty) | wt_Mgetparam: forall ofs ty r, @@ -36,12 +36,9 @@ Inductive wt_instr : instruction -> Prop := forall r1 r, mreg_type r1 = mreg_type r -> wt_instr (Mop Omove (r1 :: nil) r) - | wt_Mopundef: - forall r, - wt_instr (Mop Oundef nil r) | wt_Mop: forall op args res, - op <> Omove -> op <> Oundef -> + op <> Omove -> (List.map mreg_type args, mreg_type res) = type_of_operation op -> wt_instr (Mop op args res) | wt_Mload: @@ -58,6 +55,11 @@ Inductive wt_instr : instruction -> Prop := forall sig ros, match ros with inl r => mreg_type r = Tint | inr s => True end -> wt_instr (Mcall sig ros) + | wt_Mtailcall: + forall sig ros, + Conventions.tailcall_possible sig -> + match ros with inl r => mreg_type r = Tint | inr s => True end -> + wt_instr (Mtailcall sig ros) | wt_Malloc: wt_instr Malloc | wt_Mgoto: @@ -95,27 +97,20 @@ Definition wt_program (p: program) : Prop := Require Import Machabstr. -(** We show a weak type soundness result for the alternate semantics +(** We show a weak type soundness result for the abstract semantics of Mach: for a well-typed Mach program, if a transition is taken from a state where registers hold values of their static types, registers in the final state hold values of their static types as well. This is a subject reduction theorem for our type system. It is used in the proof of implication from the abstract Mach - semantics to the concrete Mach semantics (file [Machabstr2mach]). + semantics to the concrete Mach semantics (file [Machabstr2concr]). *) Definition wt_regset (rs: regset) : Prop := forall r, Val.has_type (rs r) (mreg_type r). -Definition wt_content (c: content) : Prop := - match c with - | Datum32 v => Val.has_type v Tint - | Datum64 v => Val.has_type v Tfloat - | _ => True - end. - Definition wt_frame (fr: frame) : Prop := - forall ofs, wt_content (fr.(contents) ofs). + forall ty ofs, Val.has_type (fr.(fr_contents) ty ofs) ty. Lemma wt_setreg: forall (rs: regset) (r: mreg) (v: val), @@ -134,17 +129,8 @@ Lemma wt_get_slot: wt_frame fr -> Val.has_type v ty. Proof. - induction 1; intro. subst v. - set (pos := low fr + ofs). - case ty; simpl. - unfold getN. case (check_cont 3 (pos + 1) (contents fr)). - generalize (H2 pos). unfold wt_content. - destruct (contents fr pos); simpl; tauto. - simpl; auto. - unfold getN. case (check_cont 7 (pos + 1) (contents fr)). - generalize (H2 pos). unfold wt_content. - destruct (contents fr pos); simpl; tauto. - simpl; auto. + induction 1; intros. + subst v. apply H2. Qed. Lemma wt_set_slot: @@ -154,43 +140,37 @@ Lemma wt_set_slot: Val.has_type v ty -> wt_frame fr'. Proof. - intros. induction H. - set (i := low fr + ofs). - red; intro j; simpl. - assert (forall n ofs c, - let c' := set_cont n ofs c in - forall k, c' k = c k \/ c' k = Cont). - induction n; simpl; intros. - left; auto. - unfold update. case (zeq k ofs0); intro. - right; auto. - apply IHn. - destruct ty; simpl; unfold store_contents; unfold setN; - unfold update; case (zeq j i); intro. - red. assumption. - elim (H 3%nat (i + 1) (contents fr) j); intro; rewrite H2. - apply H0. red; auto. - red. assumption. - elim (H 7%nat (i + 1) (contents fr) j); intro; rewrite H2. - apply H0. red; auto. + intros. induction H. subst fr'; red; intros; simpl. + destruct (zeq (fr_low fr + ofs) ofs0). + destruct (typ_eq ty ty0). congruence. exact I. + destruct (zle (ofs0 + AST.typesize ty0) (fr_low fr + ofs)). + apply H0. + destruct (zle (fr_low fr + ofs + AST.typesize ty) ofs0). + apply H0. + exact I. +Qed. + +Lemma wt_empty_frame: + wt_frame empty_frame. +Proof. + intros; red; intros; exact I. Qed. Lemma wt_init_frame: forall f, wt_frame (init_frame f). Proof. - intros. unfold init_frame. - red; intros. simpl. exact I. + intros; red; intros; exact I. Qed. -Lemma incl_find_label: - forall lbl c c', find_label lbl c = Some c' -> incl c' c. +Lemma is_tail_find_label: + forall lbl c c', find_label lbl c = Some c' -> is_tail c' c. Proof. induction c; simpl. intros; discriminate. case (is_label lbl a); intros. - injection H; intro; subst c'; apply incl_tl; apply incl_refl. - apply incl_tl; auto. + injection H; intro; subst c'. constructor. constructor. + constructor; auto. Qed. Lemma wt_event_match: @@ -203,193 +183,115 @@ Qed. Section SUBJECT_REDUCTION. +Inductive wt_stackframe: stackframe -> Prop := + | wt_stackframe_intro: forall f sp c fr, + wt_function f -> + Val.has_type sp Tint -> + is_tail c f.(fn_code) -> + wt_frame fr -> + wt_stackframe (Stackframe f sp c fr). + +Inductive wt_state: state -> Prop := + | wt_state_intro: forall stk f sp c rs fr m + (STK: forall s, In s stk -> wt_stackframe s) + (WTF: wt_function f) + (WTSP: Val.has_type sp Tint) + (TAIL: is_tail c f.(fn_code)) + (WTRS: wt_regset rs) + (WTFR: wt_frame fr), + wt_state (State stk f sp c rs fr m) + | wt_state_call: forall stk f rs m, + (forall s, In s stk -> wt_stackframe s) -> + wt_fundef f -> + wt_regset rs -> + wt_state (Callstate stk f rs m) + | wt_state_return: forall stk rs m, + (forall s, In s stk -> wt_stackframe s) -> + wt_regset rs -> + wt_state (Returnstate stk rs m). + Variable p: program. Hypothesis wt_p: wt_program p. Let ge := Genv.globalenv p. -Definition exec_instr_prop - (f: function) (sp: val) (parent: frame) - (c1: code) (rs1: regset) (fr1: frame) (m1: mem) (t: trace) - (c2: code) (rs2: regset) (fr2: frame) (m2: mem) := - forall (WTF: wt_function f) - (INCL: incl c1 f.(fn_code)) - (WTRS: wt_regset rs1) - (WTFR: wt_frame fr1) - (WTPA: wt_frame parent), - incl c2 f.(fn_code) /\ wt_regset rs2 /\ wt_frame fr2. -Definition exec_function_body_prop - (f: function) (parent: frame) (link ra: val) - (rs1: regset) (m1: mem) (t: trace) (rs2: regset) (m2: mem) := - forall (WTF: wt_function f) - (WTRS: wt_regset rs1) - (WTPA: wt_frame parent) - (WTLINK: Val.has_type link Tint) - (WTRA: Val.has_type ra Tint), - wt_regset rs2. -Definition exec_function_prop - (f: fundef) (parent: frame) - (rs1: regset) (m1: mem) (t: trace) (rs2: regset) (m2: mem) := - forall (WTF: wt_fundef f) - (WTRS: wt_regset rs1) - (WTPA: wt_frame parent), - wt_regset rs2. - Lemma subject_reduction: - (forall f sp parent c1 rs1 fr1 m1 t c2 rs2 fr2 m2, - exec_instr ge f sp parent c1 rs1 fr1 m1 t c2 rs2 fr2 m2 -> - exec_instr_prop f sp parent c1 rs1 fr1 m1 t c2 rs2 fr2 m2) -/\ (forall f sp parent c1 rs1 fr1 m1 t c2 rs2 fr2 m2, - exec_instrs ge f sp parent c1 rs1 fr1 m1 t c2 rs2 fr2 m2 -> - exec_instr_prop f sp parent c1 rs1 fr1 m1 t c2 rs2 fr2 m2) -/\ (forall f parent link ra rs1 m1 t rs2 m2, - exec_function_body ge f parent link ra rs1 m1 t rs2 m2 -> - exec_function_body_prop f parent link ra rs1 m1 t rs2 m2) -/\ (forall f parent rs1 m1 t rs2 m2, - exec_function ge f parent rs1 m1 t rs2 m2 -> - exec_function_prop f parent rs1 m1 t rs2 m2). + forall s1 t s2, step ge s1 t s2 -> + forall (WTS: wt_state s1), wt_state s2. Proof. - apply exec_mutual_induction; red; intros; - try (generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))); intro; - intuition eauto with coqlib). + induction 1; intros; inv WTS; + try (generalize (wt_function_instrs _ WTF _ (is_tail_in TAIL)); intro; + eapply wt_state_intro; eauto with coqlib). apply wt_setreg; auto. inversion H0. rewrite H2. apply wt_get_slot with fr (Int.signed ofs); auto. inversion H0. eapply wt_set_slot; eauto. - rewrite <- H3. apply WTRS. + rewrite <- H2. apply WTRS. + assert (wt_frame (parent_frame s)). + destruct s; simpl. apply wt_empty_frame. + generalize (STK s (in_eq _ _)); intro. inv H1. auto. inversion H0. apply wt_setreg; auto. - rewrite H2. apply wt_get_slot with parent (Int.signed ofs); auto. + rewrite H3. apply wt_get_slot with (parent_frame s) (Int.signed ofs); auto. - apply wt_setreg; auto. inversion H0. - simpl. subst args; subst op. simpl in H. + apply wt_setreg; auto. inv H0. + simpl in H. rewrite <- H2. replace v with (rs r1). apply WTRS. congruence. - subst args; subst op. simpl in H. - replace v with Vundef. simpl; auto. congruence. replace (mreg_type res) with (snd (type_of_operation op)). - apply type_of_operation_sound with fundef ge rs##args sp; auto. - rewrite <- H6; reflexivity. + apply type_of_operation_sound with fundef ge rs##args sp m; auto. + rewrite <- H5; reflexivity. apply wt_setreg; auto. inversion H1. rewrite H7. eapply type_of_chunk_correct; eauto. - apply H1; auto. - destruct ros; simpl in H. - apply (Genv.find_funct_prop wt_fundef wt_p H). - destruct (Genv.find_symbol ge i). - apply (Genv.find_funct_ptr_prop wt_fundef wt_p H). - discriminate. + assert (WTFD: wt_fundef f'). + destruct ros; simpl in H. + apply (Genv.find_funct_prop wt_fundef wt_p H). + destruct (Genv.find_symbol ge i); try discriminate. + apply (Genv.find_funct_ptr_prop wt_fundef wt_p H). + econstructor; eauto. + intros. elim H0; intro. subst s0. econstructor; eauto with coqlib. + auto. + + assert (WTFD: wt_fundef f'). + destruct ros; simpl in H. + apply (Genv.find_funct_prop wt_fundef wt_p H). + destruct (Genv.find_symbol ge i); try discriminate. + apply (Genv.find_funct_ptr_prop wt_fundef wt_p H). + econstructor; eauto. apply wt_setreg; auto. exact I. - apply incl_find_label with lbl; auto. - apply incl_find_label with lbl; auto. + apply is_tail_find_label with lbl; congruence. + apply is_tail_find_label with lbl; congruence. - tauto. - apply H0; auto. - generalize (H0 WTF INCL WTRS WTFR WTPA). intros [A [B C]]. - apply H2; auto. + econstructor; eauto. - assert (WTFR2: wt_frame fr2). - eapply wt_set_slot; eauto. - eapply wt_set_slot; eauto. - apply wt_init_frame. - generalize (H3 WTF (incl_refl _) WTRS WTFR2 WTPA). - tauto. + econstructor; eauto with coqlib. inv H5; auto. exact I. + apply wt_init_frame. - apply (H0 Vzero Vzero). exact I. exact I. - inversion WTF; auto. auto. auto. - exact I. exact I. - - rewrite H1. apply wt_setreg; auto. + econstructor; eauto. apply wt_setreg; auto. generalize (wt_event_match _ _ _ _ H). unfold proj_sig_res, Conventions.loc_result. destruct (sig_res (ef_sig ef)). - destruct t; simpl; auto. + destruct t0; simpl; auto. simpl; auto. -Qed. - -Lemma subject_reduction_instr: - forall f sp parent c1 rs1 fr1 m1 t c2 rs2 fr2 m2, - exec_instr ge f sp parent c1 rs1 fr1 m1 t c2 rs2 fr2 m2 -> - exec_instr_prop f sp parent c1 rs1 fr1 m1 t c2 rs2 fr2 m2. -Proof (proj1 subject_reduction). - -Lemma subject_reduction_instrs: - forall f sp parent c1 rs1 fr1 m1 t c2 rs2 fr2 m2, - exec_instrs ge f sp parent c1 rs1 fr1 m1 t c2 rs2 fr2 m2 -> - exec_instr_prop f sp parent c1 rs1 fr1 m1 t c2 rs2 fr2 m2. -Proof (proj1 (proj2 subject_reduction)). -Lemma subject_reduction_function: - forall f parent rs1 m1 t rs2 m2, - exec_function ge f parent rs1 m1 t rs2 m2 -> - exec_function_prop f parent rs1 m1 t rs2 m2. -Proof (proj2 (proj2 (proj2 subject_reduction))). - -End SUBJECT_REDUCTION. - -(** * Preservation of the reserved frame slots during execution *) - -(** We now show another result useful for the proof of implication - between the two Mach semantics: well-typed functions do not - change the values of the back link and return address fields - of the frame slot (at offsets 0 and 12) during their execution. - Actually, we show that the whole reserved part of the frame - (between offsets 0 and 24) does not change. *) - -Definition link_invariant (fr1 fr2: frame) : Prop := - forall pos v, - 0 <= pos < 20 -> - get_slot fr1 Tint pos v -> get_slot fr2 Tint pos v. - -Remark link_invariant_refl: - forall fr, link_invariant fr fr. -Proof. - intros; red; auto. + generalize (H1 _ (in_eq _ _)); intro. inv H. + econstructor; eauto. + eauto with coqlib. Qed. - -Lemma set_slot_link_invariant: - forall fr ty ofs v fr', - set_slot fr ty ofs v fr' -> - 24 <= ofs -> - link_invariant fr fr'. -Proof. - induction 1. intros; red; intros. - inversion H1. constructor. auto. exact H3. - simpl contents. simpl low. symmetry. rewrite H4. - apply load_store_contents_other. simpl. simpl in H3. - omega. -Qed. - -Lemma exec_instr_link_invariant: - forall ge f sp parent c1 rs1 fr1 m1 t c2 rs2 fr2 m2, - exec_instr ge f sp parent c1 rs1 fr1 m1 t c2 rs2 fr2 m2 -> - wt_function f -> - incl c1 f.(fn_code) -> - incl c2 f.(fn_code) /\ link_invariant fr1 fr2. -Proof. - induction 1; intros; - (split; [eauto with coqlib | try (apply link_invariant_refl)]). - eapply set_slot_link_invariant; eauto. - generalize (wt_function_instrs _ H0 _ (H1 _ (in_eq _ _))); intro. - inversion H2. auto. - eapply incl_find_label; eauto. - eapply incl_find_label; eauto. -Qed. - -Lemma exec_instrs_link_invariant: - forall ge f sp parent c1 rs1 fr1 m1 t c2 rs2 fr2 m2, - exec_instrs ge f sp parent c1 rs1 fr1 m1 t c2 rs2 fr2 m2 -> - wt_function f -> - incl c1 f.(fn_code) -> - incl c2 f.(fn_code) /\ link_invariant fr1 fr2. +(* +Lemma subject_reduction_2: + forall s1 t s2, step ge s1 t s2 -> + forall (WTS: wt_state s1), wt_state s2. Proof. induction 1; intros. - split. auto. apply link_invariant_refl. - eapply exec_instr_link_invariant; eauto. - generalize (IHexec_instrs1 H2 H3); intros [A B]. - generalize (IHexec_instrs2 H2 A); intros [C D]. - split. auto. red; auto. + auto. + eapply subject_reduction; eauto. + auto. Qed. +*) + +End SUBJECT_REDUCTION. diff --git a/backend/Op.v b/backend/Op.v index efd0d9ce..698b433c 100644 --- a/backend/Op.v +++ b/backend/Op.v @@ -1,5 +1,5 @@ (** Operators and addressing modes. The abstract syntax and dynamic - semantics for the Cminor, RTL, LTL and Mach languages depend on the + semantics for the CminorSel, RTL, LTL and Mach languages depend on the following types, defined in this library: - [condition]: boolean conditions for conditional branches; - [operation]: arithmetic and logical operations; @@ -9,7 +9,7 @@ processor can compute in one instruction. In other terms, these types reflect the state of the program after instruction selection. For a processor-independent set of operations, see the abstract - syntax and dynamic semantics of the Csharpminor input language. + syntax and dynamic semantics of the Cminor language. *) Require Import Coqlib. @@ -43,7 +43,6 @@ Inductive operation : Set := | Ofloatconst: float -> operation (**r [rd] is set to the given float constant *) | Oaddrsymbol: ident -> int -> operation (**r [rd] is set to the the address of the symbol plus the offset *) | Oaddrstack: int -> operation (**r [rd] is set to the stack pointer plus the given offset *) - | Oundef: operation (**r set [rd] to undefined value *) (*c Integer arithmetic: *) | Ocast8signed: operation (**r [rd] is 8-bit sign extension of [r1] *) | Ocast8unsigned: operation (**r [rd] is 8-bit zero extension of [r1] *) @@ -110,32 +109,28 @@ Definition eval_compare_null (c: comparison) (n: int) : option bool := then match c with Ceq => Some false | Cne => Some true | _ => None end else None. -Definition eval_condition (cond: condition) (vl: list val) : option bool := +Definition eval_condition (cond: condition) (vl: list val) (m: mem): + option bool := match cond, vl with | Ccomp c, Vint n1 :: Vint n2 :: nil => Some (Int.cmp c n1 n2) | Ccomp c, Vptr b1 n1 :: Vptr b2 n2 :: nil => - if eq_block b1 b2 then Some (Int.cmp c n1 n2) else None + if valid_pointer m b1 (Int.signed n1) + && valid_pointer m b2 (Int.signed n2) then + if eq_block b1 b2 then Some (Int.cmp c n1 n2) else None + else None | Ccomp c, Vptr b1 n1 :: Vint n2 :: nil => eval_compare_null c n2 | Ccomp c, Vint n1 :: Vptr b2 n2 :: nil => eval_compare_null c n1 | Ccompu c, Vint n1 :: Vint n2 :: nil => Some (Int.cmpu c n1 n2) - | Ccompu c, Vptr b1 n1 :: Vptr b2 n2 :: nil => - if eq_block b1 b2 then Some (Int.cmpu c n1 n2) else None - | Ccompu c, Vptr b1 n1 :: Vint n2 :: nil => - eval_compare_null c n2 - | Ccompu c, Vint n1 :: Vptr b2 n2 :: nil => - eval_compare_null c n1 | Ccompimm c n, Vint n1 :: nil => Some (Int.cmp c n1 n) | Ccompimm c n, Vptr b1 n1 :: nil => eval_compare_null c n | Ccompuimm c n, Vint n1 :: nil => Some (Int.cmpu c n1 n) - | Ccompuimm c n, Vptr b1 n1 :: nil => - eval_compare_null c n | Ccompf c, Vfloat f1 :: Vfloat f2 :: nil => Some (Float.cmp c f1 f2) | Cnotcompf c, Vfloat f1 :: Vfloat f2 :: nil => @@ -156,7 +151,7 @@ Definition offset_sp (sp: val) (delta: int) : option val := Definition eval_operation (F: Set) (genv: Genv.t F) (sp: val) - (op: operation) (vl: list val) : option val := + (op: operation) (vl: list val) (m: mem): option val := match op, vl with | Omove, v1::nil => Some v1 | Ointconst n, nil => Some (Vint n) @@ -167,7 +162,6 @@ Definition eval_operation | Some b => Some (Vptr b ofs) end | Oaddrstack ofs, nil => offset_sp sp ofs - | Oundef, nil => Some Vundef | Ocast8signed, v1 :: nil => Some (Val.cast8signed v1) | Ocast8unsigned, v1 :: nil => Some (Val.cast8unsigned v1) | Ocast16signed, v1 :: nil => Some (Val.cast16signed v1) @@ -228,7 +222,7 @@ Definition eval_operation | Ofloatofintu, Vint n1 :: nil => Some (Vfloat (Float.floatofintu n1)) | Ocmp c, _ => - match eval_condition c vl with + match eval_condition c vl m with | None => None | Some false => Some Vfalse | Some true => Some Vtrue @@ -297,26 +291,23 @@ Proof. Qed. Lemma eval_negate_condition: - forall (cond: condition) (vl: list val) (b: bool), - eval_condition cond vl = Some b -> - eval_condition (negate_condition cond) vl = Some (negb b). + forall (cond: condition) (vl: list val) (b: bool) (m: mem), + eval_condition cond vl m = Some b -> + eval_condition (negate_condition cond) vl m = Some (negb b). Proof. intros. destruct cond; simpl in H; FuncInv; try subst b; simpl. rewrite Int.negate_cmp. auto. apply eval_negate_compare_null; auto. apply eval_negate_compare_null; auto. + destruct (valid_pointer m b0 (Int.signed i) && + valid_pointer m b1 (Int.signed i0)). destruct (eq_block b0 b1). rewrite Int.negate_cmp. congruence. - discriminate. + discriminate. discriminate. rewrite Int.negate_cmpu. auto. - apply eval_negate_compare_null; auto. - apply eval_negate_compare_null; auto. - destruct (eq_block b0 b1). rewrite Int.negate_cmpu. congruence. - discriminate. rewrite Int.negate_cmp. auto. apply eval_negate_compare_null; auto. rewrite Int.negate_cmpu. auto. - apply eval_negate_compare_null; auto. auto. rewrite negb_elim. auto. auto. @@ -337,8 +328,8 @@ Hypothesis agree_on_symbols: forall (s: ident), Genv.find_symbol ge2 s = Genv.find_symbol ge1 s. Lemma eval_operation_preserved: - forall sp op vl, - eval_operation ge2 sp op vl = eval_operation ge1 sp op vl. + forall sp op vl m, + eval_operation ge2 sp op vl m = eval_operation ge1 sp op vl m. Proof. intros. unfold eval_operation; destruct op; try rewrite agree_on_symbols; @@ -356,6 +347,74 @@ Qed. End GENV_TRANSF. +(** [eval_condition] and [eval_operation] depend on a memory store + (to check pointer validity in pointer comparisons). + We show that their results are preserved by a change of + memory if this change preserves pointer validity. + In particular, this holds in case of a memory allocation + or a memory store. *) + +Lemma eval_condition_change_mem: + forall m m' c args b, + (forall b ofs, valid_pointer m b ofs = true -> valid_pointer m' b ofs = true) -> + eval_condition c args m = Some b -> eval_condition c args m' = Some b. +Proof. + intros until b. intro INV. destruct c; simpl; auto. + destruct args; auto. destruct v; auto. destruct args; auto. + destruct v; auto. destruct args; auto. + caseEq (valid_pointer m b0 (Int.signed i)); intro. + caseEq (valid_pointer m b1 (Int.signed i0)); intro. + simpl. rewrite (INV _ _ H). rewrite (INV _ _ H0). auto. + simpl; congruence. simpl; congruence. +Qed. + +Lemma eval_operation_change_mem: + forall (F: Set) m m' (ge: Genv.t F) sp op args v, + (forall b ofs, valid_pointer m b ofs = true -> valid_pointer m' b ofs = true) -> + eval_operation ge sp op args m = Some v -> eval_operation ge sp op args m' = Some v. +Proof. + intros until v; intro INV. destruct op; simpl; auto. + caseEq (eval_condition c args m); intros. + rewrite (eval_condition_change_mem _ _ _ _ INV H). auto. + discriminate. +Qed. + +Lemma eval_condition_alloc: + forall m lo hi m' b c args v, + Mem.alloc m lo hi = (m', b) -> + eval_condition c args m = Some v -> eval_condition c args m' = Some v. +Proof. + intros. apply eval_condition_change_mem with m; auto. + intros. eapply valid_pointer_alloc; eauto. +Qed. + +Lemma eval_operation_alloc: + forall (F: Set) m lo hi m' b (ge: Genv.t F) sp op args v, + Mem.alloc m lo hi = (m', b) -> + eval_operation ge sp op args m = Some v -> eval_operation ge sp op args m' = Some v. +Proof. + intros. apply eval_operation_change_mem with m; auto. + intros. eapply valid_pointer_alloc; eauto. +Qed. + +Lemma eval_condition_store: + forall chunk m b ofs v' m' c args v, + Mem.store chunk m b ofs v' = Some m' -> + eval_condition c args m = Some v -> eval_condition c args m' = Some v. +Proof. + intros. apply eval_condition_change_mem with m; auto. + intros. eapply valid_pointer_store; eauto. +Qed. + +Lemma eval_operation_store: + forall (F: Set) chunk m b ofs v' m' (ge: Genv.t F) sp op args v, + Mem.store chunk m b ofs v' = Some m' -> + eval_operation ge sp op args m = Some v -> eval_operation ge sp op args m' = Some v. +Proof. + intros. apply eval_operation_change_mem with m; auto. + intros. eapply valid_pointer_store; eauto. +Qed. + (** Recognition of move operations. *) Definition is_move_operation @@ -398,7 +457,6 @@ Definition type_of_operation (op: operation) : list typ * typ := | Ofloatconst _ => (nil, Tfloat) | Oaddrsymbol _ _ => (nil, Tint) | Oaddrstack _ => (nil, Tint) - | Oundef => (nil, Tint) (* treated specially *) | Ocast8signed => (Tint :: nil, Tint) | Ocast8unsigned => (Tint :: nil, Tint) | Ocast16signed => (Tint :: nil, Tint) @@ -471,40 +529,40 @@ Variable A: Set. Variable genv: Genv.t A. Lemma type_of_operation_sound: - forall op vl sp v, - op <> Omove -> op <> Oundef -> - eval_operation genv sp op vl = Some v -> + forall op vl sp v m, + op <> Omove -> + eval_operation genv sp op vl m = Some v -> Val.has_type v (snd (type_of_operation op)). Proof. intros. - destruct op; simpl in H1; FuncInv; try subst v; try exact I. + destruct op; simpl in H0; FuncInv; try subst v; try exact I. congruence. - destruct (Genv.find_symbol genv i); simplify_eq H1; intro; subst v; exact I. - simpl. unfold offset_sp in H1. destruct sp; try discriminate. - inversion H1. exact I. + destruct (Genv.find_symbol genv i); simplify_eq H0; intro; subst v; exact I. + simpl. unfold offset_sp in H0. destruct sp; try discriminate. + inversion H0. exact I. destruct v0; exact I. destruct v0; exact I. destruct v0; exact I. destruct v0; exact I. - destruct (eq_block b b0). injection H1; intro; subst v; exact I. + destruct (eq_block b b0). injection H0; intro; subst v; exact I. discriminate. destruct (Int.eq i0 Int.zero). discriminate. - injection H1; intro; subst v; exact I. + injection H0; intro; subst v; exact I. destruct (Int.eq i0 Int.zero). discriminate. - injection H1; intro; subst v; exact I. + injection H0; intro; subst v; exact I. destruct (Int.ltu i0 (Int.repr 32)). - injection H1; intro; subst v; exact I. discriminate. + injection H0; intro; subst v; exact I. discriminate. destruct (Int.ltu i0 (Int.repr 32)). - injection H1; intro; subst v; exact I. discriminate. + injection H0; intro; subst v; exact I. discriminate. destruct (Int.ltu i (Int.repr 32)). - injection H1; intro; subst v; exact I. discriminate. + injection H0; intro; subst v; exact I. discriminate. destruct (Int.ltu i (Int.repr 32)). - injection H1; intro; subst v; exact I. discriminate. + injection H0; intro; subst v; exact I. discriminate. destruct (Int.ltu i0 (Int.repr 32)). - injection H1; intro; subst v; exact I. discriminate. + injection H0; intro; subst v; exact I. discriminate. destruct v0; exact I. destruct (eval_condition c vl). - destruct b; injection H1; intro; subst v; exact I. + destruct b; injection H0; intro; subst v; exact I. discriminate. Qed. @@ -519,7 +577,7 @@ Proof. intros until v. unfold Mem.loadv. destruct addr; intros; try discriminate. generalize (Mem.load_inv _ _ _ _ _ H0). - intros [X [Y [Z W]]]. subst v. apply H. + intros [X Y]. subst v. apply H. Qed. End SOUNDNESS. @@ -559,7 +617,6 @@ Definition eval_operation_total (sp: val) (op: operation) (vl: list val) : val : | Ofloatconst n, nil => Vfloat n | Oaddrsymbol s ofs, nil => find_symbol_offset s ofs | Oaddrstack ofs, nil => Val.add sp (Vint ofs) - | Oundef, nil => Vundef | Ocast8signed, v1::nil => Val.cast8signed v1 | Ocast8unsigned, v1::nil => Val.cast8unsigned v1 | Ocast16signed, v1::nil => Val.cast16signed v1 @@ -625,23 +682,25 @@ Proof. Qed. Lemma eval_condition_weaken: - forall c vl b, - eval_condition c vl = Some b -> + forall c vl m b, + eval_condition c vl m = Some b -> eval_condition_total c vl = Val.of_bool b. Proof. intros. unfold eval_condition in H; destruct c; FuncInv; try subst b; try reflexivity; simpl; try (apply eval_compare_null_weaken; auto). + destruct (valid_pointer m b0 (Int.signed i) && + valid_pointer m b1 (Int.signed i0)). unfold eq_block in H. destruct (zeq b0 b1); congruence. - unfold eq_block in H. destruct (zeq b0 b1); congruence. + discriminate. symmetry. apply Val.notbool_negb_1. symmetry. apply Val.notbool_negb_1. Qed. Lemma eval_operation_weaken: - forall sp op vl v, - eval_operation genv sp op vl = Some v -> + forall sp op vl m v, + eval_operation genv sp op vl m = Some v -> eval_operation_total sp op vl = v. Proof. intros. @@ -660,9 +719,9 @@ Proof. destruct (Int.ltu i (Int.repr 32)); congruence. destruct (Int.ltu i (Int.repr 32)); congruence. destruct (Int.ltu i0 (Int.repr 32)); congruence. - caseEq (eval_condition c vl); intros; rewrite H0 in H. + caseEq (eval_condition c vl m); intros; rewrite H0 in H. replace v with (Val.of_bool b). - apply eval_condition_weaken; auto. + eapply eval_condition_weaken; eauto. destruct b; simpl; congruence. discriminate. Qed. @@ -702,3 +761,95 @@ Proof. Qed. End EVAL_OP_TOTAL. + +(** Compatibility of the evaluation functions with the + ``is less defined'' relation over values and memory states. *) + +Section EVAL_LESSDEF. + +Variable F: Set. +Variable genv: Genv.t F. +Variables m1 m2: mem. +Hypothesis MEM: Mem.lessdef m1 m2. + +Ltac InvLessdef := + match goal with + | [ H: Val.lessdef (Vint _) _ |- _ ] => + inv H; InvLessdef + | [ H: Val.lessdef (Vfloat _) _ |- _ ] => + inv H; InvLessdef + | [ H: Val.lessdef (Vptr _ _) _ |- _ ] => + inv H; InvLessdef + | [ H: Val.lessdef_list nil _ |- _ ] => + inv H; InvLessdef + | [ H: Val.lessdef_list (_ :: _) _ |- _ ] => + inv H; InvLessdef + | _ => idtac + end. + +Lemma eval_condition_lessdef: + forall cond vl1 vl2 b, + Val.lessdef_list vl1 vl2 -> + eval_condition cond vl1 m1 = Some b -> + eval_condition cond vl2 m2 = Some b. +Proof. + intros. destruct cond; simpl in *; FuncInv; InvLessdef; auto. + generalize H0. + caseEq (valid_pointer m1 b0 (Int.signed i)); intro; simpl; try congruence. + caseEq (valid_pointer m1 b1 (Int.signed i0)); intro; simpl; try congruence. + destruct (eq_block b0 b1); try congruence. + intro. inv H2. + rewrite (Mem.valid_pointer_lessdef _ _ _ _ MEM H1). + rewrite (Mem.valid_pointer_lessdef _ _ _ _ MEM H). + auto. +Qed. + +Ltac TrivialExists := + match goal with + | [ |- exists v2, Some ?v1 = Some v2 /\ Val.lessdef ?v1 v2 ] => + exists v1; split; [auto | constructor] + | _ => idtac + end. + +Lemma eval_operation_lessdef: + forall sp op vl1 vl2 v1, + Val.lessdef_list vl1 vl2 -> + eval_operation genv sp op vl1 m1 = Some v1 -> + exists v2, eval_operation genv sp op vl2 m2 = Some v2 /\ Val.lessdef v1 v2. +Proof. + intros. destruct op; simpl in *; FuncInv; InvLessdef; TrivialExists. + exists v2; auto. + destruct (Genv.find_symbol genv i); inv H0. TrivialExists. + exists v1; auto. + exists (Val.cast8signed v2); split. auto. apply Val.cast8signed_lessdef; auto. + exists (Val.cast8unsigned v2); split. auto. apply Val.cast8unsigned_lessdef; auto. + exists (Val.cast16signed v2); split. auto. apply Val.cast16signed_lessdef; auto. + exists (Val.cast16unsigned v2); split. auto. apply Val.cast16unsigned_lessdef; auto. + destruct (eq_block b b0); inv H0. TrivialExists. + destruct (Int.eq i0 Int.zero); inv H0; TrivialExists. + destruct (Int.eq i0 Int.zero); inv H0; TrivialExists. + destruct (Int.ltu i0 (Int.repr 32)); inv H0; TrivialExists. + destruct (Int.ltu i0 (Int.repr 32)); inv H0; TrivialExists. + destruct (Int.ltu i (Int.repr 32)); inv H0; TrivialExists. + destruct (Int.ltu i (Int.repr 32)); inv H0; TrivialExists. + destruct (Int.ltu i0 (Int.repr 32)); inv H0; TrivialExists. + exists (Val.singleoffloat v2); split. auto. apply Val.singleoffloat_lessdef; auto. + caseEq (eval_condition c vl1 m1); intros. rewrite H1 in H0. + rewrite (eval_condition_lessdef c H H1). + destruct b; inv H0; TrivialExists. + rewrite H1 in H0. discriminate. +Qed. + +Lemma eval_addressing_lessdef: + forall sp addr vl1 vl2 v1, + Val.lessdef_list vl1 vl2 -> + eval_addressing genv sp addr vl1 = Some v1 -> + exists v2, eval_addressing genv sp addr vl2 = Some v2 /\ Val.lessdef v1 v2. +Proof. + intros. destruct addr; simpl in *; FuncInv; InvLessdef; TrivialExists. + destruct (Genv.find_symbol genv i); inv H0. TrivialExists. + destruct (Genv.find_symbol genv i); inv H0. TrivialExists. + exists v1; auto. +Qed. + +End EVAL_LESSDEF. diff --git a/backend/PPC.v b/backend/PPC.v index ba645d02..66d96c29 100644 --- a/backend/PPC.v +++ b/backend/PPC.v @@ -9,6 +9,7 @@ Require Import Values. Require Import Mem. Require Import Events. Require Import Globalenvs. +Require Import Smallstep. (** * Abstract syntax *) @@ -97,7 +98,8 @@ Inductive instruction : Set := | Pbctrl: instruction (**r branch to contents of CTR and link *) | Pbf: crbit -> label -> instruction (**r branch if false *) | Pbl: ident -> instruction (**r branch and link *) - | Pblr: instruction (**r branch to contents: register LR *) + | Pbs: ident -> instruction (**r branch to symbol *) + | Pblr: instruction (**r branch to contents of register LR *) | Pbt: crbit -> label -> instruction (**r branch if true *) | Pcmplw: ireg -> ireg -> instruction (**r unsigned integer comparison *) | Pcmplwi: ireg -> constant -> instruction (**r same, with immediate argument *) @@ -170,14 +172,11 @@ Inductive instruction : Set := | Pxor: ireg -> ireg -> ireg -> instruction (**r bitwise xor *) | Pxori: ireg -> ireg -> constant -> instruction (**r bitwise xor with immediate *) | Pxoris: ireg -> ireg -> constant -> instruction (**r bitwise xor with immediate high *) - | Piundef: ireg -> instruction (**r set int reg to [Vundef] *) - | Pfundef: freg -> instruction (**r set float reg to [Vundef] *) | Plabel: label -> instruction. (**r define a code label *) (** The pseudo-instructions are the following: - [Plabel]: define a code label at the current program point - - [Plfi]: load a floating-point constant in a float register. Expands to a float load [lfd] from an address in the constant data section initialized with the floating-point constant: @@ -190,7 +189,6 @@ lbl: .double floatcst >> Initialized data in the constant data section are not modeled here, which is why we use a pseudo-instruction for this purpose. - - [Pfcti]: convert a float to an integer. This requires a transfer via memory of a 32-bit integer from a float register to an int register, which our memory model cannot express. Expands to: @@ -200,7 +198,6 @@ lbl: .double floatcst lwz rdst, 4(r1) addi r1, r1, 8 >> - - [Pictf]: convert a signed integer to a float. This requires complicated bit-level manipulations of IEEE floats through mixed float and integer arithmetic over a memory word, which our memory model and axiomatization @@ -221,7 +218,6 @@ lbl: .long 0x43300000, 0x80000000 >> (Don't worry if you do not understand this instruction sequence: intimate knowledge of IEEE float arithmetic is necessary.) - - [Piuctf]: convert an unsigned integer to a float. The expansion is close to that [Pictf], and equally obscure. << @@ -237,7 +233,6 @@ lbl: .long 0x43300000, 0x80000000 lbl: .long 0x43300000, 0x00000000 .text >> - - [Pallocframe lo hi]: in the formal semantics, this pseudo-instruction allocates a memory block with bounds [lo] and [hi], stores the value of register [r1] (the stack pointer, by convention) at the bottom @@ -250,7 +245,6 @@ lbl: .long 0x43300000, 0x00000000 This cannot be expressed in our memory model, which does not reflect the fact that stack frames are adjacent and allocated/freed following a stack discipline. - - [Pfreeframe]: in the formal semantics, this pseudo-instruction reads the bottom word of the block pointed by [r1] (the stack pointer), frees this block, and sets [r1] to the value of the bottom word. @@ -261,27 +255,11 @@ lbl: .long 0x43300000, 0x00000000 >> Again, our memory model cannot comprehend that this operation frees (logically) the current stack frame. - - [Pallocheap]: in the formal semantics, this pseudo-instruction allocates a heap block of size the contents of [GPR3], and leaves a pointer to this block in [GPR3]. In the generated assembly code, it is turned into a call to the allocation function of the run-time system. - -- [Piundef] and [Pfundef]: set an integer or float register (respectively) - to the [Vundef] value. Expand to nothing, as the PowerPC processor has - no notion of ``undefined value''. These two pseudo-instructions are used - to ensure that the generated PowerPC code computes exactly the same values - as predicted by the semantics of Cminor, which explicitly set uninitialized - local variables to the [Vundef] value. A general property of our semantics, - not yet formally proved, is that they are monotone with respect to the - partial ordering [Vundef <= v] over values. Consequently, if a program - evaluates to a non-[Vundef] result [r] from an initial state that contains - [Vundef] values, it will also evaluate to [r] if arbitrary values are put - in the initial state instead of the [Vundef] values. This justifies - treating [Piundef] and [Pfundef] as no-operations, leaving in the target - register whatever value was already there instead of setting it to [Vundef]. - The formal proof of this result remains to be done, however. *) Definition code := list instruction. @@ -588,6 +566,8 @@ Definition exec_instr (c: code) (i: instruction) (rs: regset) (m: mem) : outcome end | Pbl ident => OK (rs#LR <- (Val.add rs#PC Vone) #PC <- (symbol_offset ident Int.zero)) m + | Pbs ident => + OK (rs#PC <- (symbol_offset ident Int.zero)) m | Pblr => OK (rs#PC <- (rs#LR)) m | Pbt bit lbl => @@ -744,10 +724,6 @@ Definition exec_instr (c: code) (i: instruction) (rs: regset) (m: mem) : outcome OK (nextinstr (rs#rd <- (Val.xor rs#r1 (const_low cst)))) m | Pxoris rd r1 cst => OK (nextinstr (rs#rd <- (Val.xor rs#r1 (const_high cst)))) m - | Piundef rd => - OK (nextinstr (rs#rd <- Vundef)) m - | Pfundef rd => - OK (nextinstr (rs#rd <- Vundef)) m | Plabel lbl => OK (nextinstr rs) m end. @@ -762,7 +738,7 @@ Inductive extcall_args (rs: regset) (m: mem): extcall_args rs m nil irl frl ofs nil | extcall_args_int_reg: forall tyl ir1 irl frl ofs v1 vl, v1 = rs (IR ir1) -> - extcall_args rs m tyl irl frl (ofs + 4) vl -> + extcall_args rs m tyl irl frl ofs vl -> extcall_args rs m (Tint :: tyl) (ir1 :: irl) frl ofs (v1 :: vl) | extcall_args_int_stack: forall tyl frl ofs v1 vl, Mem.loadv Mint32 m (Val.add (rs (IR GPR1)) (Vint (Int.repr ofs))) = Some v1 -> @@ -770,11 +746,11 @@ Inductive extcall_args (rs: regset) (m: mem): extcall_args rs m (Tint :: tyl) nil frl ofs (v1 :: vl) | extcall_args_float_reg: forall tyl irl fr1 frl ofs v1 vl, v1 = rs (FR fr1) -> - extcall_args rs m tyl (list_drop2 irl) frl (ofs + 8) vl -> + extcall_args rs m tyl (list_drop2 irl) frl ofs vl -> extcall_args rs m (Tfloat :: tyl) irl (fr1 :: frl) ofs (v1 :: vl) | extcall_args_float_stack: forall tyl irl ofs v1 vl, Mem.loadv Mfloat64 m (Val.add (rs (IR GPR1)) (Vint (Int.repr ofs))) = Some v1 -> - extcall_args rs m tyl (list_drop2 irl) nil (ofs + 8) vl -> + extcall_args rs m tyl irl nil (ofs + 8) vl -> extcall_args rs m (Tfloat :: tyl) irl nil ofs (v1 :: vl). Definition extcall_arguments @@ -783,7 +759,7 @@ Definition extcall_arguments sg.(sig_args) (GPR3 :: GPR4 :: GPR5 :: GPR6 :: GPR7 :: GPR8 :: GPR9 :: GPR10 :: nil) (FPR1 :: FPR2 :: FPR3 :: FPR4 :: FPR5 :: FPR6 :: FPR7 :: FPR8 :: FPR9 :: FPR10 :: nil) - 24 args. + 56 args. Definition loc_external_result (s: signature) : preg := match s.(sig_res) with @@ -794,14 +770,17 @@ Definition loc_external_result (s: signature) : preg := (** Execution of the instruction at [rs#PC]. *) -Inductive exec_step: regset -> mem -> trace -> regset -> mem -> Prop := +Inductive state: Set := + | State: regset -> mem -> state. + +Inductive step: state -> trace -> state -> Prop := | exec_step_internal: forall b ofs c i rs m rs' m', rs PC = Vptr b ofs -> Genv.find_funct_ptr ge b = Some (Internal c) -> find_instr (Int.unsigned ofs) c = Some i -> exec_instr c i rs m = OK rs' m' -> - exec_step rs m E0 rs' m' + step (State rs m) E0 (State rs' m') | exec_step_external: forall b ef args res rs m t rs', rs PC = Vptr b Int.zero -> @@ -810,33 +789,26 @@ Inductive exec_step: regset -> mem -> trace -> regset -> mem -> Prop := extcall_arguments rs m ef.(ef_sig) args -> rs' = (rs#(loc_external_result ef.(ef_sig)) <- res #PC <- (rs LR)) -> - exec_step rs m t rs' m. - -(** Execution of zero, one or several instructions starting at [rs#PC]. *) - -Inductive exec_steps: regset -> mem -> trace -> regset -> mem -> Prop := - | exec_refl: - forall rs m, - exec_steps rs m E0 rs m - | exec_one: - forall rs m t rs' m', - exec_step rs m t rs' m' -> - exec_steps rs m t rs' m' - | exec_trans: - forall rs1 m1 t1 rs2 m2 t2 rs3 m3 t3, - exec_steps rs1 m1 t1 rs2 m2 -> - exec_steps rs2 m2 t2 rs3 m3 -> - t3 = t1 ** t2 -> - exec_steps rs1 m1 t3 rs3 m3. + step (State rs m) t (State rs' m). End RELSEM. -Definition exec_program (p: program) (t: trace) (r: val) : Prop := - let ge := Genv.globalenv p in - let m0 := Genv.init_mem p in - let rs0 := - (Pregmap.init Vundef) # PC <- (symbol_offset ge p.(prog_main) Int.zero) - # LR <- Vzero - # GPR1 <- (Vptr Mem.nullptr Int.zero) in - exists rs, exists m, - exec_steps ge rs0 m0 t rs m /\ rs#PC = Vzero /\ rs#GPR3 = r. +Inductive initial_state (p: program): state -> Prop := + | initial_state_intro: + let ge := Genv.globalenv p in + let m0 := Genv.init_mem p in + let rs0 := + (Pregmap.init Vundef) + # PC <- (symbol_offset ge p.(prog_main) Int.zero) + # LR <- Vzero + # GPR1 <- (Vptr Mem.nullptr Int.zero) in + initial_state p (State rs0 m0). + +Inductive final_state: state -> int -> Prop := + | final_state_intro: forall rs m r, + rs#PC = Vzero -> + rs#GPR3 = Vint r -> + final_state (State rs m) r. + +Definition exec_program (p: program) (beh: program_behavior) : Prop := + program_behaves step (initial_state p) final_state (Genv.globalenv p) beh. diff --git a/backend/PPCgen.v b/backend/PPCgen.v index ba8ea285..d7a83b0b 100644 --- a/backend/PPCgen.v +++ b/backend/PPCgen.v @@ -2,6 +2,7 @@ Require Import Coqlib. Require Import Maps. +Require Import Errors. Require Import AST. Require Import Integers. Require Import Floats. @@ -268,11 +269,6 @@ Definition transl_op Pori (ireg_of r) (ireg_of r) (Csymbol_low_unsigned s ofs) :: k | Oaddrstack n, nil => addimm (ireg_of r) GPR1 n k - | Oundef, nil => - match mreg_type r with - | Tint => Piundef (ireg_of r) :: k - | Tfloat => Pfundef (freg_of r) :: k - end | Ocast8signed, a1 :: nil => Pextsb (ireg_of r) (ireg_of a1) :: k | Ocast8unsigned, a1 :: nil => @@ -474,6 +470,17 @@ Definition transl_instr (i: Mach.instruction) (k: code) := Pmtctr (ireg_of r) :: Pbctrl :: k | Mcall sig (inr symb) => Pbl symb :: k + | Mtailcall sig (inl r) => + Pmtctr (ireg_of r) :: + Plwz GPR2 (Cint (Int.repr 12)) GPR1 :: + Pmtlr GPR2 :: + Pfreeframe :: + Pbctr :: k + | Mtailcall sig (inr symb) => + Plwz GPR2 (Cint (Int.repr 12)) GPR1 :: + Pmtlr GPR2 :: + Pfreeframe :: + Pbs symb :: k | Malloc => Pallocblock :: k | Mlabel lbl => @@ -510,14 +517,17 @@ Fixpoint code_size (c: code) : Z := | instr :: c' => code_size c' + 1 end. -Definition transf_function (f: Mach.function) : option PPC.code := +Open Local Scope string_scope. + +Definition transf_function (f: Mach.function) : res PPC.code := let c := transl_function f in if zlt Int.max_unsigned (code_size c) - then None - else Some c. + then Errors.Error (msg "code size exceeded") + else Errors.OK c. -Definition transf_fundef (f: Mach.fundef) : option PPC.fundef := +Definition transf_fundef (f: Mach.fundef) : res PPC.fundef := transf_partial_fundef transf_function f. -Definition transf_program (p: Mach.program) : option PPC.program := +Definition transf_program (p: Mach.program) : res PPC.program := transform_partial_program transf_fundef p. + diff --git a/backend/PPCgenproof.v b/backend/PPCgenproof.v index f1ee9f22..8d6d9342 100644 --- a/backend/PPCgenproof.v +++ b/backend/PPCgenproof.v @@ -2,6 +2,7 @@ Require Import Coqlib. Require Import Maps. +Require Import Errors. Require Import AST. Require Import Integers. Require Import Floats. @@ -9,19 +10,22 @@ Require Import Values. Require Import Mem. Require Import Events. Require Import Globalenvs. +Require Import Smallstep. Require Import Op. Require Import Locations. Require Import Mach. +Require Import Machconcr. Require Import Machtyping. Require Import PPC. Require Import PPCgen. +Require Import PPCgenretaddr. Require Import PPCgenproof1. Section PRESERVATION. Variable prog: Mach.program. Variable tprog: PPC.program. -Hypothesis TRANSF: transf_program prog = Some tprog. +Hypothesis TRANSF: transf_program prog = Errors.OK tprog. Let ge := Genv.globalenv prog. Let tge := Genv.globalenv tprog. @@ -35,16 +39,11 @@ Proof. Qed. Lemma functions_translated: - forall f b, + forall b f, Genv.find_funct_ptr ge b = Some f -> - exists tf, Genv.find_funct_ptr tge b = Some tf /\ transf_fundef f = Some tf. -Proof. - intros. - generalize (Genv.find_funct_ptr_transf_partial transf_fundef TRANSF H). - case (transf_fundef f). - intros f' [A B]. exists f'; split. assumption. auto. - tauto. -Qed. + 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). Lemma functions_transl: forall f b, @@ -54,8 +53,8 @@ Proof. intros. destruct (functions_translated _ _ H) as [tf [A B]]. rewrite A. generalize B. unfold transf_fundef, transf_partial_fundef, transf_function. - case (zlt Int.max_unsigned (code_size (transl_function f))); intro. - congruence. auto. + case (zlt Int.max_unsigned (code_size (transl_function f))); simpl; intro. + congruence. intro. inv B0. auto. Qed. Lemma functions_transl_no_overflow: @@ -66,7 +65,7 @@ Proof. intros. destruct (functions_translated _ _ H) as [tf [A B]]. generalize B. unfold transf_fundef, transf_partial_fundef, transf_function. - case (zlt Int.max_unsigned (code_size (transl_function f))); intro. + case (zlt Int.max_unsigned (code_size (transl_function f))); simpl; intro. congruence. intro; omega. Qed. @@ -81,23 +80,17 @@ Proof. left; congruence. right; eauto. Qed. -(** The ``code tail'' of an instruction list [c] is the list of instructions - starting at PC [pos]. *) - -Fixpoint code_tail (pos: Z) (c: code) {struct c} : code := - match c with - | nil => nil - | i :: il => if zeq pos 0 then c else code_tail (pos - 1) il - end. - Lemma find_instr_tail: - forall c pos, - find_instr pos c = - match code_tail pos c with nil => None | i1 :: il => Some i1 end. + forall c1 i c2 pos, + code_tail pos c1 (i :: c2) -> + find_instr pos c1 = Some i. Proof. - induction c; simpl; intros. - auto. - case (zeq pos 0); auto. + induction c1; simpl; intros. + inv H. + destruct (zeq pos 0). subst pos. + inv H. auto. generalize (code_tail_pos _ _ _ H4). intro. omegaContradiction. + inv H. congruence. replace (pos0 + 1 - 1) with pos0 by omega. + eauto. Qed. Remark code_size_pos: @@ -108,60 +101,39 @@ Qed. Remark code_tail_bounds: forall fn ofs i c, - code_tail ofs fn = i :: c -> 0 <= ofs < code_size fn. -Proof. - induction fn; simpl. - intros; discriminate. - intros until c. case (zeq ofs 0); intros. - generalize (code_size_pos fn). omega. - generalize (IHfn _ _ _ H). omega. -Qed. - -Remark code_tail_unfold: - forall ofs i c, - ofs >= 0 -> - code_tail (ofs + 1) (i :: c) = code_tail ofs c. -Proof. - intros. simpl. case (zeq (ofs + 1) 0); intros. - omegaContradiction. - replace (ofs + 1 - 1) with ofs. auto. omega. -Qed. - -Remark code_tail_zero: - forall fn, code_tail 0 fn = fn. + code_tail ofs fn (i :: c) -> 0 <= ofs < code_size fn. Proof. - intros. destruct fn; simpl. auto. auto. + assert (forall ofs fn c, code_tail ofs fn c -> + forall i c', c = i :: c' -> 0 <= ofs < code_size fn). + induction 1; intros; simpl. + rewrite H. simpl. generalize (code_size_pos c'). omega. + generalize (IHcode_tail _ _ H0). omega. + eauto. Qed. Lemma code_tail_next: forall fn ofs i c, - code_tail ofs fn = i :: c -> - code_tail (ofs + 1) fn = c. + code_tail ofs fn (i :: c) -> + code_tail (ofs + 1) fn c. Proof. - induction fn. - simpl; intros; discriminate. - intros until c. case (zeq ofs 0); intro. - subst ofs. intros. rewrite code_tail_zero in H. injection H. - intros. subst c. rewrite code_tail_unfold. apply code_tail_zero. - omega. - intro; generalize (code_tail_bounds _ _ _ _ H); intros [A B]. - assert (ofs = (ofs - 1) + 1). omega. - rewrite H0 in H. rewrite code_tail_unfold in H. - rewrite code_tail_unfold. rewrite H0. eauto. - omega. omega. + assert (forall ofs fn c, code_tail ofs fn c -> + forall i c', c = i :: c' -> code_tail (ofs + 1) fn c'). + induction 1; intros. + subst c. constructor. constructor. + constructor. eauto. + eauto. Qed. Lemma code_tail_next_int: forall fn ofs i c, code_size fn <= Int.max_unsigned -> - code_tail (Int.unsigned ofs) fn = i :: c -> - code_tail (Int.unsigned (Int.add ofs Int.one)) fn = c. + code_tail (Int.unsigned ofs) fn (i :: c) -> + code_tail (Int.unsigned (Int.add ofs Int.one)) fn c. Proof. - intros. rewrite Int.add_unsigned. unfold Int.one. - repeat rewrite Int.unsigned_repr. apply code_tail_next with i; auto. - compute; intuition congruence. + intros. rewrite Int.add_unsigned. + change (Int.unsigned Int.one) with 1. + rewrite Int.unsigned_repr. apply code_tail_next with i; auto. generalize (code_tail_bounds _ _ _ _ H0). omega. - compute; intuition congruence. Qed. (** [transl_code_at_pc pc fn c] holds if the code pointer [pc] points @@ -169,12 +141,12 @@ Qed. and [c] is the tail of the generated code at the position corresponding to the code pointer [pc]. *) -Inductive transl_code_at_pc: val -> Mach.function -> Mach.code -> Prop := +Inductive transl_code_at_pc: val -> block -> Mach.function -> Mach.code -> Prop := transl_code_at_pc_intro: forall b ofs f c, Genv.find_funct_ptr ge b = Some (Internal f) -> - code_tail (Int.unsigned ofs) (transl_function f) = transl_code c -> - transl_code_at_pc (Vptr b ofs) f c. + code_tail (Int.unsigned ofs) (transl_function f) (transl_code c) -> + transl_code_at_pc (Vptr b ofs) b f c. (** The following lemmas show that straight-line executions (predicate [exec_straight]) correspond to correct PPC executions @@ -187,14 +159,16 @@ Lemma exec_straight_steps_1: forall b ofs, rs#PC = Vptr b ofs -> Genv.find_funct_ptr tge b = Some (Internal fn) -> - code_tail (Int.unsigned ofs) fn = c -> - exec_steps tge rs m E0 rs' m'. + code_tail (Int.unsigned ofs) fn c -> + plus step tge (State rs m) E0 (State rs' m'). Proof. - induction 1. - intros. apply exec_refl. - intros. apply exec_trans with E0 rs2 m2 E0. - apply exec_one; econstructor; eauto. - rewrite find_instr_tail. rewrite H5. auto. + induction 1; intros. + apply plus_one. + econstructor; eauto. + eapply find_instr_tail. eauto. + eapply plus_left'. + econstructor; eauto. + eapply find_instr_tail. eauto. apply IHexec_straight with b (Int.add ofs Int.one). auto. rewrite H0. rewrite H3. reflexivity. auto. @@ -209,35 +183,79 @@ Lemma exec_straight_steps_2: forall b ofs, rs#PC = Vptr b ofs -> Genv.find_funct_ptr tge b = Some (Internal fn) -> - code_tail (Int.unsigned ofs) fn = c -> + code_tail (Int.unsigned ofs) fn c -> exists ofs', rs'#PC = Vptr b ofs' - /\ code_tail (Int.unsigned ofs') fn = c'. + /\ code_tail (Int.unsigned ofs') fn c'. Proof. induction 1; intros. - exists ofs. split. auto. auto. + exists (Int.add ofs Int.one). split. + rewrite H0. rewrite H2. auto. + apply code_tail_next_int with i1; auto. apply IHexec_straight with (Int.add ofs Int.one). auto. rewrite H0. rewrite H3. reflexivity. auto. apply code_tail_next_int with i; auto. Qed. -Lemma exec_straight_steps: - forall f c c' rs m rs' m', - transl_code_at_pc (rs PC) f c -> +Lemma exec_straight_exec: + forall fb f c c' rs m rs' m', + transl_code_at_pc (rs PC) fb f c -> + exec_straight tge (transl_function f) + (transl_code c) rs m c' rs' m' -> + plus step tge (State rs m) E0 (State rs' m'). +Proof. + intros. inversion H. subst. + eapply exec_straight_steps_1; eauto. + eapply functions_transl_no_overflow; eauto. + eapply functions_transl; eauto. +Qed. + +Lemma exec_straight_at: + forall fb f c c' rs m rs' m', + transl_code_at_pc (rs PC) fb f c -> exec_straight tge (transl_function f) (transl_code c) rs m (transl_code c') rs' m' -> - exec_steps tge rs m E0 rs' m' /\ transl_code_at_pc (rs' PC) f c'. + transl_code_at_pc (rs' PC) fb f c'. Proof. - intros. inversion H. + intros. inversion H. subst. generalize (functions_transl_no_overflow _ _ H2). intro. generalize (functions_transl _ _ H2). intro. - split. eapply exec_straight_steps_1; eauto. generalize (exec_straight_steps_2 _ _ _ _ _ _ _ - H0 H6 _ _ (sym_equal H1) H7 H3). + H0 H4 _ _ (sym_equal H1) H5 H3). intros [ofs' [PC' CT']]. rewrite PC'. constructor; auto. Qed. +(** Correctness of the return addresses predicted by + [PPCgen.return_address_offset]. *) + +Remark code_tail_no_bigger: + forall pos c1 c2, code_tail pos c1 c2 -> (length c2 <= length c1)%nat. +Proof. + induction 1; simpl; omega. +Qed. + +Remark code_tail_unique: + forall fn c pos pos', + code_tail pos fn c -> code_tail pos' fn c -> pos = pos'. +Proof. + induction fn; intros until pos'; intros ITA CT; inv ITA; inv CT; auto. + generalize (code_tail_no_bigger _ _ _ H3); simpl; intro; omega. + generalize (code_tail_no_bigger _ _ _ H3); simpl; intro; omega. + f_equal. eauto. +Qed. + +Lemma return_address_offset_correct: + forall b ofs fb f c ofs', + transl_code_at_pc (Vptr b ofs) fb f c -> + return_address_offset f c ofs' -> + ofs' = ofs. +Proof. + intros. inv H0. inv H. + generalize (code_tail_unique _ _ _ _ H1 H7). intro. rewrite H. + apply Int.repr_unsigned. +Qed. + (** The [find_label] function returns the code tail starting at the given label. A connection with [code_tail] is then established. *) @@ -253,7 +271,7 @@ Lemma label_pos_code_tail: find_label lbl c = Some c' -> exists pos', label_pos lbl pos c = Some pos' - /\ code_tail (pos' - pos) c = c' + /\ code_tail (pos' - pos) c c' /\ pos < pos' <= pos + code_size c. Proof. induction c. @@ -262,13 +280,13 @@ Proof. case (is_label lbl a). intro EQ; injection EQ; intro; subst c'. exists (pos + 1). split. auto. split. - rewrite zeq_false. replace (pos + 1 - pos - 1) with 0. - apply code_tail_zero. omega. omega. + replace (pos + 1 - pos) with (0 + 1) by omega. constructor. constructor. generalize (code_size_pos c). omega. intros. generalize (IHc (pos + 1) c' H). intros [pos' [A [B C]]]. exists pos'. split. auto. split. - rewrite zeq_false. replace (pos' - pos - 1) with (pos' - (pos + 1)). - auto. omega. omega. omega. + replace (pos' - pos) with ((pos' - (pos + 1)) + 1) by omega. + constructor. auto. + omega. Qed. (** The following lemmas show that the translation from Mach to PPC @@ -409,7 +427,6 @@ Proof. destruct op; destruct args; try (destruct args); try (destruct args); try (destruct args); try reflexivity; autorewrite with labels; try reflexivity. case (mreg_type m); reflexivity. - case (mreg_type r); reflexivity. case (Int.eq (high_s i) Int.zero); autorewrite with labels; reflexivity. case (Int.eq (high_s i) Int.zero); autorewrite with labels; reflexivity. case (snd (crbit_for_cond c)); reflexivity. @@ -453,6 +470,7 @@ Proof. destruct m; rewrite transl_load_store_label; intros; reflexivity. destruct m; rewrite transl_load_store_label; intros; reflexivity. destruct s0; reflexivity. + destruct s0; reflexivity. rewrite peq_false. auto. congruence. case (snd (crbit_for_cond c)); reflexivity. Qed. @@ -488,7 +506,7 @@ Lemma find_label_goto_label: Mach.find_label lbl f.(fn_code) = Some c' -> exists rs', goto_label (transl_function f) lbl rs m = OK rs' m - /\ transl_code_at_pc (rs' PC) f c' + /\ transl_code_at_pc (rs' PC) b f c' /\ forall r, r <> PC -> rs'#r = rs#r. Proof. intros. @@ -499,13 +517,13 @@ Proof. intros [pos' [A [B C]]]. exists (rs#PC <- (Vptr b (Int.repr pos'))). split. unfold goto_label. rewrite A. rewrite H0. auto. - split. rewrite Pregmap.gss. constructor. auto. + split. rewrite Pregmap.gss. constructor; auto. rewrite Int.unsigned_repr. replace (pos' - 0) with pos' in B. auto. omega. generalize (functions_transl_no_overflow _ _ H). omega. intros. apply Pregmap.gso; auto. -Qed. +Qed. (** * Memory properties *) @@ -513,22 +531,39 @@ Qed. We show that it can be synthesized as a ``load 8-bit unsigned integer'' followed by a sign extension. *) +Remark valid_access_equiv: + forall chunk1 chunk2 m b ofs, + size_chunk chunk1 = size_chunk chunk2 -> + valid_access m chunk1 b ofs -> + valid_access m chunk2 b ofs. +Proof. + intros. inv H0. rewrite H in H3. constructor; auto. +Qed. + +Remark in_bounds_equiv: + forall chunk1 chunk2 m b ofs (A: Set) (a1 a2: A), + size_chunk chunk1 = size_chunk chunk2 -> + (if in_bounds m chunk1 b ofs then a1 else a2) = + (if in_bounds m chunk2 b ofs then a1 else a2). +Proof. + intros. destruct (in_bounds m chunk1 b ofs). + rewrite in_bounds_true. auto. eapply valid_access_equiv; eauto. + destruct (in_bounds m chunk2 b ofs); auto. + elim n. eapply valid_access_equiv with (chunk1 := chunk2); eauto. +Qed. + Lemma loadv_8_signed_unsigned: forall m a, Mem.loadv Mint8signed m a = option_map Val.cast8signed (Mem.loadv Mint8unsigned m a). Proof. intros. unfold Mem.loadv. destruct a; try reflexivity. - unfold load. case (zlt b (nextblock m)); intro. - change (in_bounds Mint8unsigned (Int.signed i) (blocks m b)) - with (in_bounds Mint8signed (Int.signed i) (blocks m b)). - case (in_bounds Mint8signed (Int.signed i) (blocks m b)). - change (mem_chunk Mint8unsigned) with (mem_chunk Mint8signed). - set (v := (load_contents (mem_chunk Mint8signed) - (contents (blocks m b)) (Int.signed i))). - unfold Val.load_result. destruct v; try reflexivity. + unfold load. rewrite (in_bounds_equiv Mint8signed Mint8unsigned). + destruct (in_bounds m Mint8unsigned b (Int.signed i)); auto. + simpl. + destruct (getN 0 (Int.signed i) (contents (blocks m b))); auto. simpl. rewrite Int.cast8_signed_unsigned. auto. - reflexivity. reflexivity. + auto. Qed. (** Similarly, we show that signed 8- and 16-bit stores can be performed @@ -538,155 +573,201 @@ Lemma storev_8_signed_unsigned: forall m a v, Mem.storev Mint8signed m a v = Mem.storev Mint8unsigned m a v. Proof. - intros. reflexivity. + intros. unfold storev. destruct a; auto. + unfold store. rewrite (in_bounds_equiv Mint8signed Mint8unsigned). + auto. auto. Qed. Lemma storev_16_signed_unsigned: forall m a v, Mem.storev Mint16signed m a v = Mem.storev Mint16unsigned m a v. Proof. - intros. reflexivity. + intros. unfold storev. destruct a; auto. + unfold store. rewrite (in_bounds_equiv Mint16signed Mint16unsigned). + auto. auto. Qed. (** * Proof of semantic preservation *) -(** The invariants for the inductive proof of simulation are as follows. - The simulation diagrams are of the form: +(** Semantic preservation is proved using simulation diagrams + of the following form. << - c1, ms1, m1 --------------------- rs1, m1 - | | - | | - v v - c2, ms2, m2 --------------------- rs2, m2 + st1 --------------- st2 + | | + t| *|t + | | + v v + st1'--------------- st2' >> - Left: execution of one Mach instruction. Right: execution of zero, one - or several instructions. Precondition (top): agreement between - the Mach register set [ms1] and the PPC register set [rs1]; moreover, - [rs1 PC] points to the translation of code [c1]. Postcondition (bottom): - similar. + The invariant is the [match_states] predicate below, which includes: +- The PPC code pointed by the PC register is the translation of + the current Mach code sequence. +- Mach register values and PPC register values agree. *) -Definition exec_instr_prop - (f: Mach.function) (sp: val) - (c1: Mach.code) (ms1: Mach.regset) (m1: mem) (t: trace) - (c2: Mach.code) (ms2: Mach.regset) (m2: mem) := - forall rs1 - (WTF: wt_function f) - (INCL: incl c1 f.(fn_code)) - (AT: transl_code_at_pc (rs1 PC) f c1) - (AG: agree ms1 sp rs1), - exists rs2, - agree ms2 sp rs2 - /\ exec_steps tge rs1 m1 t rs2 m2 - /\ transl_code_at_pc (rs2 PC) f c2. - -Definition exec_function_body_prop - (f: Mach.function) (parent: val) (ra: val) - (ms1: Mach.regset) (m1: mem) (t: trace) - (ms2: Mach.regset) (m2: mem) := - forall rs1 - (WTRA: Val.has_type ra Tint) - (RALR: rs1 LR = ra) - (WTF: wt_function f) - (AT: Genv.find_funct ge (rs1 PC) = Some (Internal f)) - (AG: agree ms1 parent rs1), - exists rs2, - agree ms2 parent rs2 - /\ exec_steps tge rs1 m1 t rs2 m2 - /\ rs2 PC = rs1 LR. - -Definition exec_function_prop - (f: Mach.fundef) (parent: val) - (ms1: Mach.regset) (m1: mem) (t: trace) - (ms2: Mach.regset) (m2: mem) := - forall rs1 - (WTF: wt_fundef f) - (AT: Genv.find_funct ge (rs1 PC) = Some f) - (AG: agree ms1 parent rs1) - (WTRA: Val.has_type (rs1 LR) Tint), - exists rs2, - agree ms2 parent rs2 - /\ exec_steps tge rs1 m1 t rs2 m2 - /\ rs2 PC = rs1 LR. - -(** We show each case of the inductive proof of simulation as a separate - lemma. *) +Inductive match_stack: list Machconcr.stackframe -> Prop := + | match_stack_nil: + match_stack nil + | match_stack_cons: forall fb sp ra c s f, + Genv.find_funct_ptr ge fb = Some (Internal f) -> + wt_function f -> + incl c f.(fn_code) -> + transl_code_at_pc ra fb f c -> + match_stack s -> + match_stack (Stackframe fb sp ra c :: s). + +Inductive match_states: Machconcr.state -> PPC.state -> Prop := + | match_states_intro: + forall s fb sp c ms m rs f + (STACKS: match_stack s) + (FIND: Genv.find_funct_ptr ge fb = Some (Internal f)) + (WTF: wt_function f) + (INCL: incl c f.(fn_code)) + (AT: transl_code_at_pc (rs PC) fb f c) + (AG: agree ms sp rs), + match_states (Machconcr.State s fb sp c ms m) + (PPC.State rs m) + | match_states_call: + forall s fb ms m rs + (STACKS: match_stack s) + (AG: agree ms (parent_sp s) rs) + (ATPC: rs PC = Vptr fb Int.zero) + (ATLR: rs LR = parent_ra s), + match_states (Machconcr.Callstate s fb ms m) + (PPC.State rs m) + | match_states_return: + forall s ms m rs + (STACKS: match_stack s) + (AG: agree ms (parent_sp s) rs) + (ATPC: rs PC = parent_ra s), + match_states (Machconcr.Returnstate s ms m) + (PPC.State rs m). + +Lemma exec_straight_steps: + forall s fb sp m1 f c1 rs1 c2 m2 ms2, + match_stack s -> + Genv.find_funct_ptr ge fb = Some (Internal f) -> + wt_function f -> + incl c2 f.(fn_code) -> + transl_code_at_pc (rs1 PC) fb f c1 -> + (exists rs2, + exec_straight tge (transl_function f) (transl_code c1) rs1 m1 (transl_code c2) rs2 m2 + /\ agree ms2 sp rs2) -> + exists st', + plus step tge (State rs1 m1) E0 st' /\ + match_states (Machconcr.State s fb sp c2 ms2 m2) st'. +Proof. + intros. destruct H4 as [rs2 [A B]]. + exists (State rs2 m2); split. + eapply exec_straight_exec; eauto. + econstructor; eauto. eapply exec_straight_at; eauto. +Qed. + +(** We need to show that, in the simulation diagram, we cannot + take infinitely many Mach transitions that correspond to zero + transitions on the PPC side. Actually, all Mach transitions + correspond to at least one PPC transition, except the + transition from [Machconcr.Returnstate] to [Machconcr.State]. + So, the following integer measure will suffice to rule out + the unwanted behaviour. *) + +Definition measure (s: Machconcr.state) : nat := + match s with + | Machconcr.State _ _ _ _ _ _ => 0%nat + | Machconcr.Callstate _ _ _ _ => 0%nat + | Machconcr.Returnstate _ _ _ => 1%nat + end. + +(** We show the simulation diagram by case analysis on the Mach transition + on the left. Since the proof is large, we break it into one lemma + per transition. *) + +Definition exec_instr_prop (s1: Machconcr.state) (t: trace) (s2: Machconcr.state) : Prop := + forall s1' (MS: match_states s1 s1'), + (exists s2', plus step tge s1' t s2' /\ match_states s2 s2') + \/ (measure s2 < measure s1 /\ t = E0 /\ match_states s2 s1')%nat. + Lemma exec_Mlabel_prop: - forall (f : function) (sp : val) (lbl : Mach.label) - (c : list Mach.instruction) (rs : Mach.regset) (m : mem), - exec_instr_prop f sp (Mlabel lbl :: c) rs m E0 c rs m. + forall (s : list stackframe) (fb : block) (sp : val) + (lbl : Mach.label) (c : list Mach.instruction) (ms : Mach.regset) + (m : mem), + exec_instr_prop (Machconcr.State s fb sp (Mlabel lbl :: c) ms m) E0 + (Machconcr.State s fb sp c ms m). Proof. - intros; red; intros. - assert (exec_straight tge (transl_function f) - (transl_code (Mlabel lbl :: c)) rs1 m - (transl_code c) (nextinstr rs1) m). + intros; red; intros; inv MS. + left; eapply exec_straight_steps; eauto with coqlib. + exists (nextinstr rs); split. simpl. apply exec_straight_one. reflexivity. reflexivity. - exists (nextinstr rs1). split. apply agree_nextinstr; auto. - eapply exec_straight_steps; eauto. + apply agree_nextinstr; auto. Qed. Lemma exec_Mgetstack_prop: - forall (f : function) (sp : val) (ofs : int) (ty : typ) (dst : mreg) - (c : list Mach.instruction) (ms : Mach.regset) (m : mem) (v : val), - load_stack m sp ty ofs = Some v -> - exec_instr_prop f sp (Mgetstack ofs ty dst :: c) ms m E0 c (Regmap.set dst v ms) m. + forall (s : list stackframe) (fb : block) (sp : val) (ofs : int) + (ty : typ) (dst : mreg) (c : list Mach.instruction) + (ms : Mach.regset) (m : mem) (v : val), + load_stack m sp ty ofs = Some v -> + exec_instr_prop (Machconcr.State s fb sp (Mgetstack ofs ty dst :: c) ms m) E0 + (Machconcr.State s fb sp c (Regmap.set dst v ms) m). Proof. - intros; red; intros. + intros; red; intros; inv MS. unfold load_stack in H. generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). intro WTI. inversion WTI. rewrite (sp_val _ _ _ AG) in H. assert (NOTE: GPR1 <> GPR0). congruence. generalize (loadind_correct tge (transl_function f) GPR1 ofs ty - dst (transl_code c) rs1 m v H H1 NOTE). + dst (transl_code c) rs m v H H1 NOTE). intros [rs2 [EX [RES OTH]]]. - exists rs2. split. - apply agree_exten_2 with (rs1#(preg_of dst) <- v). + left; eapply exec_straight_steps; eauto with coqlib. + simpl. exists rs2; split. auto. + apply agree_exten_2 with (rs#(preg_of dst) <- v). auto with ppcgen. intros. case (preg_eq r0 (preg_of dst)); intro. subst r0. rewrite Pregmap.gss. auto. - rewrite Pregmap.gso; auto. - eapply exec_straight_steps; eauto. + rewrite Pregmap.gso; auto. Qed. Lemma exec_Msetstack_prop: - forall (f : function) (sp : val) (src : mreg) (ofs : int) (ty : typ) - (c : list Mach.instruction) (ms : mreg -> val) (m m' : mem), - store_stack m sp ty ofs (ms src) = Some m' -> - exec_instr_prop f sp (Msetstack src ofs ty :: c) ms m E0 c ms m'. + forall (s : list stackframe) (fb : block) (sp : val) (src : mreg) + (ofs : int) (ty : typ) (c : list Mach.instruction) + (ms : mreg -> val) (m m' : mem), + store_stack m sp ty ofs (ms src) = Some m' -> + exec_instr_prop (Machconcr.State s fb sp (Msetstack src ofs ty :: c) ms m) E0 + (Machconcr.State s fb sp c ms m'). Proof. - intros; red; intros. + intros; red; intros; inv MS. unfold store_stack in H. generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). intro WTI. inversion WTI. rewrite (sp_val _ _ _ AG) in H. - rewrite (preg_val ms sp rs1) in H; auto. + rewrite (preg_val ms sp rs) in H; auto. assert (NOTE: GPR1 <> GPR0). congruence. generalize (storeind_correct tge (transl_function f) GPR1 ofs ty - src (transl_code c) rs1 m m' H H2 NOTE). + src (transl_code c) rs m m' H H1 NOTE). intros [rs2 [EX OTH]]. - exists rs2. split. - apply agree_exten_2 with rs1; auto. - eapply exec_straight_steps; eauto. + left; eapply exec_straight_steps; eauto with coqlib. + exists rs2; split; auto. + apply agree_exten_2 with rs; auto. Qed. Lemma exec_Mgetparam_prop: - forall (f : function) (sp parent : val) (ofs : int) (ty : typ) - (dst : mreg) (c : list Mach.instruction) (ms : Mach.regset) - (m : mem) (v : val), - load_stack m sp Tint (Int.repr 0) = Some parent -> - load_stack m parent ty ofs = Some v -> - exec_instr_prop f sp (Mgetparam ofs ty dst :: c) ms m E0 c (Regmap.set dst v ms) m. + forall (s : list stackframe) (fb : block) (sp parent : val) + (ofs : int) (ty : typ) (dst : mreg) (c : list Mach.instruction) + (ms : Mach.regset) (m : mem) (v : val), + load_stack m sp Tint (Int.repr 0) = Some parent -> + load_stack m parent ty ofs = Some v -> + exec_instr_prop (Machconcr.State s fb sp (Mgetparam ofs ty dst :: c) ms m) E0 + (Machconcr.State s fb sp c (Regmap.set dst v ms) m). Proof. - intros; red; intros. - set (rs2 := nextinstr (rs1#GPR2 <- parent)). + intros; red; intros; inv MS. + set (rs2 := nextinstr (rs#GPR2 <- parent)). assert (EX1: exec_straight tge (transl_function f) - (transl_code (Mgetparam ofs ty dst :: c)) rs1 m + (transl_code (Mgetparam ofs ty dst :: c)) rs m (loadind GPR2 ofs ty dst (transl_code c)) rs2 m). simpl. apply exec_straight_one. simpl. unfold load1. rewrite gpr_or_zero_not_zero; auto with ppcgen. - unfold const_low. rewrite <- (sp_val ms sp rs1); auto. + unfold const_low. rewrite <- (sp_val ms sp rs); auto. unfold load_stack in H. simpl chunk_of_type in H. rewrite H. reflexivity. reflexivity. generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). @@ -696,64 +777,48 @@ Proof. generalize (loadind_correct tge (transl_function f) GPR2 ofs ty dst (transl_code c) rs2 m v H0 H2 NOTE). intros [rs3 [EX2 [RES OTH]]]. - exists rs3. split. + left; eapply exec_straight_steps; eauto with coqlib. + exists rs3; split; simpl. + eapply exec_straight_trans; eauto. apply agree_exten_2 with (rs2#(preg_of dst) <- v). unfold rs2; auto with ppcgen. intros. case (preg_eq r0 (preg_of dst)); intro. subst r0. rewrite Pregmap.gss. auto. rewrite Pregmap.gso; auto. - eapply exec_straight_steps; eauto. - eapply exec_straight_trans; eauto. -Qed. - -Lemma exec_straight_exec_prop: - forall f sp c1 rs1 m1 c2 m2 ms', - transl_code_at_pc (rs1 PC) f c1 -> - (exists rs2, - exec_straight tge (transl_function f) - (transl_code c1) rs1 m1 - (transl_code c2) rs2 m2 - /\ agree ms' sp rs2) -> - (exists rs2, - agree ms' sp rs2 - /\ exec_steps tge rs1 m1 E0 rs2 m2 - /\ transl_code_at_pc (rs2 PC) f c2). -Proof. - intros until ms'. intros TRANS1 [rs2 [EX AG]]. - exists rs2. split. assumption. - eapply exec_straight_steps; eauto. Qed. Lemma exec_Mop_prop: - forall (f : function) (sp : val) (op : operation) (args : list mreg) - (res : mreg) (c : list Mach.instruction) (ms: Mach.regset) - (m : mem) (v: val), - eval_operation ge sp op ms ## args = Some v -> - exec_instr_prop f sp (Mop op args res :: c) ms m E0 c (Regmap.set res v ms) m. + forall (s : list stackframe) (fb : block) (sp : val) (op : operation) + (args : list mreg) (res : mreg) (c : list Mach.instruction) + (ms : mreg -> val) (m : mem) (v : val), + eval_operation ge sp op ms ## args m = Some v -> + exec_instr_prop (Machconcr.State s fb sp (Mop op args res :: c) ms m) E0 + (Machconcr.State s fb sp c (Regmap.set res v ms) m). Proof. - intros; red; intros. + intros; red; intros; inv MS. generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). - intro WTI. - eapply exec_straight_exec_prop; eauto. + intro WTI. + left; eapply exec_straight_steps; eauto with coqlib. simpl. eapply transl_op_correct; auto. rewrite <- H. apply eval_operation_preserved. exact symbols_preserved. Qed. Lemma exec_Mload_prop: - forall (f : function) (sp : val) (chunk : memory_chunk) - (addr : addressing) (args : list mreg) (dst : mreg) - (c : list Mach.instruction) (ms: Mach.regset) (m : mem) - (a v : val), - eval_addressing ge sp addr ms ## args = Some a -> - loadv chunk m a = Some v -> - exec_instr_prop f sp (Mload chunk addr args dst :: c) ms m E0 c (Regmap.set dst v ms) m. + forall (s : list stackframe) (fb : block) (sp : val) + (chunk : memory_chunk) (addr : addressing) (args : list mreg) + (dst : mreg) (c : list Mach.instruction) (ms : mreg -> val) + (m : mem) (a v : val), + eval_addressing ge sp addr ms ## args = Some a -> + loadv chunk m a = Some v -> + exec_instr_prop (Machconcr.State s fb sp (Mload chunk addr args dst :: c) ms m) + E0 (Machconcr.State s fb sp c (Regmap.set dst v ms) m). Proof. - intros; red; intros. + intros; red; intros; inv MS. generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). intro WTI; inversion WTI. assert (eval_addressing tge sp addr ms##args = Some a). rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. - eapply exec_straight_exec_prop; eauto. + left; eapply exec_straight_steps; eauto with coqlib; destruct chunk; simpl; simpl in H6; (* all cases but Mint8signed *) try (eapply transl_load_correct; eauto; @@ -776,7 +841,7 @@ Proof. (Plbz (ireg_of dst)) (Plbzx (ireg_of dst)) Mint8unsigned addr args (Pextsb (ireg_of dst) (ireg_of dst) :: transl_code c) - ms sp rs1 m dst a v' + ms sp rs m dst a v' X1 X2 AG H3 H7 LOAD'). intros [rs2 [EX1 AG1]]. exists (nextinstr (rs2#(ireg_of dst) <- v)). @@ -788,190 +853,298 @@ Proof. Qed. Lemma exec_Mstore_prop: - forall (f : function) (sp : val) (chunk : memory_chunk) - (addr : addressing) (args : list mreg) (src : mreg) - (c : list Mach.instruction) (ms: Mach.regset) (m m' : mem) - (a : val), - eval_addressing ge sp addr ms ## args = Some a -> - storev chunk m a (ms src) = Some m' -> - exec_instr_prop f sp (Mstore chunk addr args src :: c) ms m E0 c ms m'. + forall (s : list stackframe) (fb : block) (sp : val) + (chunk : memory_chunk) (addr : addressing) (args : list mreg) + (src : mreg) (c : list Mach.instruction) (ms : mreg -> val) + (m m' : mem) (a : val), + eval_addressing ge sp addr ms ## args = Some a -> + storev chunk m a (ms src) = Some m' -> + exec_instr_prop (Machconcr.State s fb sp (Mstore chunk addr args src :: c) ms m) E0 + (Machconcr.State s fb sp c ms m'). Proof. - intros; red; intros. + intros; red; intros; inv MS. generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). intro WTI; inversion WTI. rewrite <- (eval_addressing_preserved symbols_preserved) in H. - eapply exec_straight_exec_prop; eauto. + left; eapply exec_straight_steps; eauto with coqlib. destruct chunk; simpl; simpl in H6; - try (rewrite storev_8_signed_unsigned in H); - try (rewrite storev_16_signed_unsigned in H); + try (rewrite storev_8_signed_unsigned in H0); + try (rewrite storev_16_signed_unsigned in H0); simpl; eapply transl_store_correct; eauto; intros; unfold preg_of; rewrite H6; reflexivity. Qed. -Hypothesis wt_prog: wt_program prog. - Lemma exec_Mcall_prop: - forall (f : function) (sp : val) (sig : signature) - (mos : mreg + ident) (c : list Mach.instruction) (ms : Mach.regset) - (m : mem) (f' : Mach.fundef) (t: trace) (ms' : Mach.regset) (m' : mem), - find_function ge mos ms = Some f' -> - exec_function ge f' sp ms m t ms' m' -> - exec_function_prop f' sp ms m t ms' m' -> - exec_instr_prop f sp (Mcall sig mos :: c) ms m t c ms' m'. + forall (s : list stackframe) (fb : block) (sp : val) + (sig : signature) (ros : mreg + ident) (c : Mach.code) + (ms : Mach.regset) (m : mem) (f : function) (f' : block) + (ra : int), + find_function_ptr ge ros ms = Some f' -> + Genv.find_funct_ptr ge fb = Some (Internal f) -> + return_address_offset f c ra -> + exec_instr_prop (Machconcr.State s fb sp (Mcall sig ros :: c) ms m) E0 + (Callstate (Stackframe fb sp (Vptr fb ra) c :: s) f' ms m). Proof. - intros; red; intros. + intros; red; intros; inv MS. + assert (f0 = f) by congruence. subst f0. generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). intro WTI. inversion WTI. - inversion AT. - assert (WTF': wt_fundef f'). - destruct mos; simpl in H. - apply (Genv.find_funct_prop wt_fundef wt_prog H). - destruct (Genv.find_symbol ge i); try discriminate. - apply (Genv.find_funct_ptr_prop wt_fundef wt_prog H). + inv AT. assert (NOOV: code_size (transl_function f) <= Int.max_unsigned). eapply functions_transl_no_overflow; eauto. - destruct mos; simpl in H; simpl transl_code in H7. + destruct ros; simpl in H; simpl transl_code in H7. (* Indirect call *) generalize (code_tail_next_int _ _ _ _ NOOV H7). intro CT1. generalize (code_tail_next_int _ _ _ _ NOOV CT1). intro CT2. - set (rs2 := nextinstr (rs1#CTR <- (ms m0))). + set (rs2 := nextinstr (rs#CTR <- (ms m0))). set (rs3 := rs2 #LR <- (Val.add rs2#PC Vone) #PC <- (ms m0)). - assert (TFIND: Genv.find_funct ge (rs3#PC) = Some f'). - unfold rs3. rewrite Pregmap.gss. auto. + assert (ATPC: rs3 PC = Vptr f' Int.zero). + change (rs3 PC) with (ms m0). + destruct (ms m0); try discriminate. + generalize H; predSpec Int.eq Int.eq_spec i Int.zero; intros; congruence. + exploit return_address_offset_correct; eauto. constructor; eauto. + intro RA_EQ. + assert (ATLR: rs3 LR = Vptr fb ra). + rewrite RA_EQ. + change (rs3 LR) with (Val.add (Val.add (rs PC) Vone) Vone). + rewrite <- H5. reflexivity. assert (AG3: agree ms sp rs3). unfold rs3, rs2; auto 8 with ppcgen. - assert (WTRA: Val.has_type rs3#LR Tint). - change rs3#LR with (Val.add (Val.add rs1#PC Vone) Vone). - rewrite <- H5. exact I. - generalize (H1 rs3 WTF' TFIND AG3 WTRA). - intros [rs4 [AG4 [EXF' PC4]]]. - exists rs4. split. auto. split. - apply exec_trans with E0 rs2 m t. apply exec_one. econstructor. - eauto. apply functions_transl. eexact H6. - rewrite find_instr_tail. rewrite H7. reflexivity. - simpl. rewrite <- (ireg_val ms sp rs1); auto. - apply exec_trans with E0 rs3 m t. apply exec_one. econstructor. - unfold rs2, nextinstr. rewrite Pregmap.gss. - rewrite Pregmap.gso. rewrite <- H5. simpl. reflexivity. - discriminate. apply functions_transl. eexact H6. - rewrite find_instr_tail. rewrite CT1. reflexivity. - simpl. replace (rs2 CTR) with (ms m0). reflexivity. - unfold rs2. rewrite nextinstr_inv. rewrite Pregmap.gss. - auto. discriminate. - exact EXF'. traceEq. traceEq. - rewrite PC4. unfold rs3. rewrite Pregmap.gso. rewrite Pregmap.gss. - unfold rs2, nextinstr. rewrite Pregmap.gss. rewrite Pregmap.gso. - rewrite <- H5. simpl. constructor. auto. auto. - discriminate. discriminate. + left; exists (State rs3 m); split. + apply plus_left with E0 (State rs2 m) E0. + econstructor. eauto. apply functions_transl. eexact H0. + eapply find_instr_tail. eauto. + simpl. rewrite <- (ireg_val ms sp rs); auto. + apply star_one. econstructor. + change (rs2 PC) with (Val.add (rs PC) Vone). rewrite <- H5. + simpl. auto. + apply functions_transl. eexact H0. + eapply find_instr_tail. eauto. + simpl. reflexivity. + traceEq. + econstructor; eauto. + econstructor; eauto with coqlib. + rewrite RA_EQ. econstructor; eauto. (* Direct call *) - caseEq (Genv.find_symbol ge i). intros fblock FINDS. - rewrite FINDS in H. generalize (code_tail_next_int _ _ _ _ NOOV H7). intro CT1. - set (rs2 := rs1 #LR <- (Val.add rs1#PC Vone) #PC <- (symbol_offset tge i Int.zero)). - assert (TFIND: Genv.find_funct ge (rs2#PC) = Some f'). - unfold rs2. rewrite Pregmap.gss. - unfold symbol_offset. rewrite symbols_preserved. - rewrite FINDS. - rewrite Genv.find_funct_find_funct_ptr. assumption. + set (rs2 := rs #LR <- (Val.add rs#PC Vone) #PC <- (symbol_offset tge i Int.zero)). + assert (ATPC: rs2 PC = Vptr f' Int.zero). + change (rs2 PC) with (symbol_offset tge i Int.zero). + unfold symbol_offset. rewrite symbols_preserved. rewrite H. auto. + exploit return_address_offset_correct; eauto. constructor; eauto. + intro RA_EQ. + assert (ATLR: rs2 LR = Vptr fb ra). + rewrite RA_EQ. + change (rs2 LR) with (Val.add (rs PC) Vone). + rewrite <- H5. reflexivity. assert (AG2: agree ms sp rs2). unfold rs2; auto 8 with ppcgen. - assert (WTRA: Val.has_type rs2#LR Tint). - change rs2#LR with (Val.add rs1#PC Vone). - rewrite <- H5. exact I. - generalize (H1 rs2 WTF' TFIND AG2 WTRA). - intros [rs3 [AG3 [EXF' PC3]]]. - exists rs3. split. auto. split. - apply exec_trans with E0 rs2 m t. apply exec_one. econstructor. - eauto. apply functions_transl. eexact H6. - rewrite find_instr_tail. rewrite H7. reflexivity. - simpl. reflexivity. - exact EXF'. traceEq. - rewrite PC3. unfold rs2. rewrite Pregmap.gso. rewrite Pregmap.gss. - rewrite <- H5. simpl. constructor. auto. auto. - discriminate. - intro FINDS. rewrite FINDS in H. discriminate. + left; exists (State rs2 m); split. + apply plus_one. econstructor. + eauto. + apply functions_transl. eexact H0. + eapply find_instr_tail. eauto. + simpl. reflexivity. + econstructor; eauto with coqlib. + econstructor; eauto with coqlib. + rewrite RA_EQ. econstructor; eauto. +Qed. + +Lemma exec_Mtailcall_prop: + forall (s : list stackframe) (fb stk : block) (soff : int) + (sig : signature) (ros : mreg + ident) (c : list Mach.instruction) + (ms : Mach.regset) (m : mem) (f' : block), + find_function_ptr ge ros ms = Some f' -> + load_stack m (Vptr stk soff) Tint (Int.repr 0) = Some (parent_sp s) -> + load_stack m (Vptr stk soff) Tint (Int.repr 12) = Some (parent_ra s) -> + exec_instr_prop + (Machconcr.State s fb (Vptr stk soff) (Mtailcall sig ros :: c) ms m) E0 + (Callstate s f' ms (free m stk)). +Proof. + intros; red; intros; inv MS. + generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). + intro WTI. inversion WTI. + inversion AT. subst b f0 c0. + assert (NOOV: code_size (transl_function f) <= Int.max_unsigned). + eapply functions_transl_no_overflow; eauto. + destruct ros; simpl in H; simpl in H8. + (* Indirect call *) + set (rs2 := nextinstr (rs#CTR <- (ms m0))). + set (rs3 := nextinstr (rs2#GPR2 <- (parent_ra s))). + set (rs4 := nextinstr (rs3#LR <- (parent_ra s))). + set (rs5 := nextinstr (rs4#GPR1 <- (parent_sp s))). + set (rs6 := rs5#PC <- (rs5 CTR)). + assert (exec_straight tge (transl_function f) + (transl_code (Mtailcall sig (inl ident m0) :: c)) rs m + (Pbctr :: transl_code c) rs5 (free m stk)). + simpl. apply exec_straight_step with rs2 m. + simpl. rewrite <- (ireg_val _ _ _ _ AG H5). reflexivity. reflexivity. + apply exec_straight_step with rs3 m. + simpl. unfold load1. rewrite gpr_or_zero_not_zero. unfold const_low. + change (rs2 GPR1) with (rs GPR1). rewrite <- (sp_val _ _ _ AG). + simpl. unfold load_stack in H1. simpl in H1. rewrite H1. + reflexivity. discriminate. reflexivity. + apply exec_straight_step with rs4 m. + simpl. reflexivity. reflexivity. + apply exec_straight_one. + simpl. change (rs4 GPR1) with (rs GPR1). rewrite <- (sp_val _ _ _ AG). + unfold load_stack in H0; simpl in H0. rewrite Int.add_zero in H0. + simpl. rewrite H0. reflexivity. reflexivity. + left; exists (State rs6 (free m stk)); split. + (* execution *) + eapply plus_right'. eapply exec_straight_exec; eauto. + econstructor. + change (rs5 PC) with (Val.add (Val.add (Val.add (Val.add (rs PC) Vone) Vone) Vone) Vone). + rewrite <- H6; simpl. eauto. + eapply functions_transl; eauto. + eapply find_instr_tail. + repeat (eapply code_tail_next_int; auto). eauto. + simpl. reflexivity. traceEq. + (* match states *) + econstructor; eauto. + assert (AG4: agree ms (Vptr stk soff) rs4). + unfold rs4, rs3, rs2; auto 10 with ppcgen. + assert (AG5: agree ms (parent_sp s) rs5). + unfold rs5. apply agree_nextinstr. + split. reflexivity. intros. inv AG4. rewrite H11. + rewrite Pregmap.gso; auto with ppcgen. + unfold rs6; auto with ppcgen. + change (rs6 PC) with (ms m0). + generalize H. destruct (ms m0); try congruence. + predSpec Int.eq Int.eq_spec i Int.zero; intros; congruence. + (* direct call *) + set (rs2 := nextinstr (rs#GPR2 <- (parent_ra s))). + set (rs3 := nextinstr (rs2#LR <- (parent_ra s))). + set (rs4 := nextinstr (rs3#GPR1 <- (parent_sp s))). + set (rs5 := rs4#PC <- (Vptr f' Int.zero)). + assert (exec_straight tge (transl_function f) + (transl_code (Mtailcall sig (inr mreg i) :: c)) rs m + (Pbs i :: transl_code c) rs4 (free m stk)). + simpl. apply exec_straight_step with rs2 m. + simpl. unfold load1. rewrite gpr_or_zero_not_zero. unfold const_low. + rewrite <- (sp_val _ _ _ AG). + simpl. unfold load_stack in H1. simpl in H1. rewrite H1. + reflexivity. discriminate. reflexivity. + apply exec_straight_step with rs3 m. + simpl. reflexivity. reflexivity. + apply exec_straight_one. + simpl. change (rs3 GPR1) with (rs GPR1). rewrite <- (sp_val _ _ _ AG). + unfold load_stack in H0; simpl in H0. rewrite Int.add_zero in H0. + simpl. rewrite H0. reflexivity. reflexivity. + left; exists (State rs5 (free m stk)); split. + (* execution *) + eapply plus_right'. eapply exec_straight_exec; eauto. + econstructor. + change (rs4 PC) with (Val.add (Val.add (Val.add (rs PC) Vone) Vone) Vone). + rewrite <- H6; simpl. eauto. + eapply functions_transl; eauto. + eapply find_instr_tail. + repeat (eapply code_tail_next_int; auto). eauto. + simpl. unfold symbol_offset. rewrite symbols_preserved. rewrite H. + reflexivity. traceEq. + (* match states *) + econstructor; eauto. + assert (AG3: agree ms (Vptr stk soff) rs3). + unfold rs3, rs2; auto 10 with ppcgen. + assert (AG4: agree ms (parent_sp s) rs4). + unfold rs4. apply agree_nextinstr. + split. reflexivity. intros. inv AG3. rewrite H11. + rewrite Pregmap.gso; auto with ppcgen. + unfold rs5; auto with ppcgen. Qed. Lemma exec_Malloc_prop: - forall (f : function) (sp : val) (c : list Mach.instruction) - (ms : Mach.regset) (m : mem) (sz : int) (m' : mem) (blk : block), + forall (s : list stackframe) (fb : block) (sp : val) + (c : list Mach.instruction) (ms : mreg -> val) (m : mem) (sz : int) + (m' : mem) (blk : block), ms Conventions.loc_alloc_argument = Vint sz -> - Mem.alloc m 0 (Int.signed sz) = (m', blk) -> - exec_instr_prop f sp (Malloc :: c) ms m E0 c - (Regmap.set Conventions.loc_alloc_result (Vptr blk Int.zero) ms) m'. + alloc m 0 (Int.signed sz) = (m', blk) -> + exec_instr_prop (Machconcr.State s fb sp (Malloc :: c) ms m) E0 + (Machconcr.State s fb sp c + (Regmap.set (Conventions.loc_alloc_result) (Vptr blk Int.zero) ms) m'). Proof. - intros; red; intros. - eapply exec_straight_exec_prop; eauto. + intros; red; intros; inv MS. + left; eapply exec_straight_steps; eauto with coqlib. simpl. eapply transl_alloc_correct; eauto. Qed. Lemma exec_Mgoto_prop: - forall (f : function) (sp : val) (lbl : Mach.label) - (c : list Mach.instruction) (ms : Mach.regset) (m : mem) - (c' : Mach.code), - Mach.find_label lbl (fn_code f) = Some c' -> - exec_instr_prop f sp (Mgoto lbl :: c) ms m E0 c' ms m. + forall (s : list stackframe) (fb : block) (f : function) (sp : val) + (lbl : Mach.label) (c : list Mach.instruction) (ms : Mach.regset) + (m : mem) (c' : Mach.code), + Genv.find_funct_ptr ge fb = Some (Internal f) -> + Mach.find_label lbl (fn_code f) = Some c' -> + exec_instr_prop (Machconcr.State s fb sp (Mgoto lbl :: c) ms m) E0 + (Machconcr.State s fb sp c' ms m). Proof. - intros; red; intros. - inversion AT. - generalize (find_label_goto_label f lbl rs1 m _ _ _ H1 (sym_equal H0) H). + intros; red; intros; inv MS. + assert (f0 = f) by congruence. subst f0. + inv AT. simpl in H3. + generalize (find_label_goto_label f lbl rs m _ _ _ FIND (sym_equal H1) H0). intros [rs2 [GOTO [AT2 INV]]]. - exists rs2. split. apply agree_exten_2 with rs1; auto. - split. inversion AT. apply exec_one. econstructor; eauto. - apply functions_transl; eauto. - rewrite find_instr_tail. rewrite H7. simpl. reflexivity. - simpl. rewrite GOTO. auto. auto. + left; exists (State rs2 m); split. + apply plus_one. econstructor; eauto. + apply functions_transl; eauto. + eapply find_instr_tail; eauto. + simpl; auto. + econstructor; eauto. + eapply Mach.find_label_incl; eauto. + apply agree_exten_2 with rs; auto. Qed. Lemma exec_Mcond_true_prop: - forall (f : function) (sp : val) (cond : condition) - (args : list mreg) (lbl : Mach.label) (c : list Mach.instruction) - (ms: Mach.regset) (m : mem) (c' : Mach.code), - eval_condition cond ms ## args = Some true -> - Mach.find_label lbl (fn_code f) = Some c' -> - exec_instr_prop f sp (Mcond cond args lbl :: c) ms m E0 c' ms m. + forall (s : list stackframe) (fb : block) (f : function) (sp : val) + (cond : condition) (args : list mreg) (lbl : Mach.label) + (c : list Mach.instruction) (ms : mreg -> val) (m : mem) + (c' : Mach.code), + eval_condition cond ms ## args m = Some true -> + Genv.find_funct_ptr ge fb = Some (Internal f) -> + Mach.find_label lbl (fn_code f) = Some c' -> + exec_instr_prop (Machconcr.State s fb sp (Mcond cond args lbl :: c) ms m) E0 + (Machconcr.State s fb sp c' ms m). Proof. - intros; red; intros. + intros; red; intros; inv MS. assert (f0 = f) by congruence. subst f0. generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). - intro WTI. inversion WTI. + intro WTI. inv WTI. pose (k1 := if snd (crbit_for_cond cond) then Pbt (fst (crbit_for_cond cond)) lbl :: transl_code c else Pbf (fst (crbit_for_cond cond)) lbl :: transl_code c). generalize (transl_cond_correct tge (transl_function f) - cond args k1 ms sp rs1 m true H2 AG H). + cond args k1 ms sp rs m true H3 AG H). simpl. intros [rs2 [EX [RES AG2]]]. - inversion AT. - generalize (functions_transl _ _ H6); intro FN. - generalize (functions_transl_no_overflow _ _ H6); intro NOOV. - simpl in H7. - generalize (exec_straight_steps_2 _ _ _ _ _ _ _ EX - NOOV _ _ (sym_equal H5) FN H7). + inv AT. simpl in H5. + generalize (functions_transl _ _ H4); intro FN. + generalize (functions_transl_no_overflow _ _ H4); intro NOOV. + exploit exec_straight_steps_2; eauto. intros [ofs' [PC2 CT2]]. - generalize (find_label_goto_label f lbl rs2 m _ _ _ H6 PC2 H0). + generalize (find_label_goto_label f lbl rs2 m _ _ _ FIND PC2 H1). intros [rs3 [GOTO [AT3 INV3]]]. - exists rs3. split. - apply agree_exten_2 with rs2; auto. - split. eapply exec_trans. + left; exists (State rs3 m); split. + eapply plus_right'. eapply exec_straight_steps_1; eauto. caseEq (snd (crbit_for_cond cond)); intro ISSET; rewrite ISSET in RES. - apply exec_one. econstructor; eauto. - rewrite find_instr_tail. rewrite CT2. unfold k1. rewrite ISSET. reflexivity. + econstructor; eauto. + eapply find_instr_tail. unfold k1 in CT2; rewrite ISSET in CT2. eauto. simpl. rewrite RES. simpl. auto. - apply exec_one. econstructor; eauto. - rewrite find_instr_tail. rewrite CT2. unfold k1. rewrite ISSET. reflexivity. + econstructor; eauto. + eapply find_instr_tail. unfold k1 in CT2; rewrite ISSET in CT2. eauto. simpl. rewrite RES. simpl. auto. - traceEq. auto. + traceEq. + econstructor; eauto. + eapply Mach.find_label_incl; eauto. + apply agree_exten_2 with rs2; auto. Qed. Lemma exec_Mcond_false_prop: - forall (f : function) (sp : val) (cond : condition) - (args : list mreg) (lbl : Mach.label) (c : list Mach.instruction) - (ms : Mach.regset) (m : mem), - eval_condition cond ms ## args = Some false -> - exec_instr_prop f sp (Mcond cond args lbl :: c) ms m E0 c ms m. + forall (s : list stackframe) (fb : block) (sp : val) + (cond : condition) (args : list mreg) (lbl : Mach.label) + (c : list Mach.instruction) (ms : mreg -> val) (m : mem), + eval_condition cond ms ## args m = Some false -> + exec_instr_prop (Machconcr.State s fb sp (Mcond cond args lbl :: c) ms m) E0 + (Machconcr.State s fb sp c ms m). Proof. - intros; red; intros. + intros; red; intros; inv MS. generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). intro WTI. inversion WTI. pose (k1 := @@ -979,12 +1152,11 @@ Proof. then Pbt (fst (crbit_for_cond cond)) lbl :: transl_code c else Pbf (fst (crbit_for_cond cond)) lbl :: transl_code c). generalize (transl_cond_correct tge (transl_function f) - cond args k1 ms sp rs1 m false H1 AG H). + cond args k1 ms sp rs m false H1 AG H). simpl. intros [rs2 [EX [RES AG2]]]. - exists (nextinstr rs2). - split. auto with ppcgen. - eapply exec_straight_steps; eauto. - eapply exec_straight_trans. eexact EX. + left; eapply exec_straight_steps; eauto with coqlib. + exists (nextinstr rs2); split. + simpl. eapply exec_straight_trans. eexact EX. caseEq (snd (crbit_for_cond cond)); intro ISSET; rewrite ISSET in RES. unfold k1; rewrite ISSET; apply exec_straight_one. simpl. rewrite RES. reflexivity. @@ -992,114 +1164,110 @@ Proof. unfold k1; rewrite ISSET; apply exec_straight_one. simpl. rewrite RES. reflexivity. reflexivity. + auto with ppcgen. Qed. -Lemma exec_instr_incl: - forall f sp c rs m t c' rs' m', - Mach.exec_instr ge f sp c rs m t c' rs' m' -> - incl c f.(fn_code) -> incl c' f.(fn_code). +Lemma exec_Mreturn_prop: + forall (s : list stackframe) (fb stk : block) (soff : int) + (c : list Mach.instruction) (ms : Mach.regset) (m : mem), + load_stack m (Vptr stk soff) Tint (Int.repr 0) = Some (parent_sp s) -> + load_stack m (Vptr stk soff) Tint (Int.repr 12) = Some (parent_ra s) -> + exec_instr_prop (Machconcr.State s fb (Vptr stk soff) (Mreturn :: c) ms m) E0 + (Returnstate s ms (free m stk)). Proof. - induction 1; intros; eauto with coqlib. - eapply incl_find_label; eauto. - eapply incl_find_label; eauto. -Qed. - -Lemma exec_instrs_incl: - forall f sp c rs m t c' rs' m', - Mach.exec_instrs ge f sp c rs m t c' rs' m' -> - incl c f.(fn_code) -> incl c' f.(fn_code). -Proof. - induction 1; intros. - auto. - eapply exec_instr_incl; eauto. - eauto. -Qed. - -Lemma exec_refl_prop: - forall (f : function) (sp : val) (c : Mach.code) (ms : Mach.regset) - (m : mem), exec_instr_prop f sp c ms m E0 c ms m. -Proof. - intros; red; intros. - exists rs1. split. auto. split. apply exec_refl. auto. -Qed. - -Lemma exec_one_prop: - forall (f : function) (sp : val) (c : Mach.code) (ms : Mach.regset) - (m : mem) (t: trace) (c' : Mach.code) (ms' : Mach.regset) (m' : mem), - Mach.exec_instr ge f sp c ms m t c' ms' m' -> - exec_instr_prop f sp c ms m t c' ms' m' -> - exec_instr_prop f sp c ms m t c' ms' m'. -Proof. - auto. + intros; red; intros; inv MS. + set (rs2 := nextinstr (rs#GPR2 <- (parent_ra s))). + set (rs3 := nextinstr (rs2#LR <- (parent_ra s))). + set (rs4 := nextinstr (rs3#GPR1 <- (parent_sp s))). + set (rs5 := rs4#PC <- (parent_ra s)). + assert (exec_straight tge (transl_function f) + (transl_code (Mreturn :: c)) rs m + (Pblr :: transl_code c) rs4 (free m stk)). + simpl. apply exec_straight_three with rs2 m rs3 m. + simpl. unfold load1. rewrite gpr_or_zero_not_zero. unfold const_low. + unfold load_stack in H0. simpl in H0. + rewrite <- (sp_val _ _ _ AG). simpl. rewrite H0. + reflexivity. discriminate. + unfold rs3. change (parent_ra s) with rs2#GPR2. reflexivity. + simpl. change (rs3 GPR1) with (rs GPR1). rewrite <- (sp_val _ _ _ AG). + simpl. + unfold load_stack in H. simpl in H. rewrite Int.add_zero in H. + rewrite H. reflexivity. + reflexivity. reflexivity. reflexivity. + left; exists (State rs5 (free m stk)); split. + (* execution *) + apply plus_right' with E0 (State rs4 (free m stk)) E0. + eapply exec_straight_exec; eauto. + inv AT. econstructor. + change (rs4 PC) with (Val.add (Val.add (Val.add (rs PC) Vone) Vone) Vone). + rewrite <- H2. simpl. eauto. + apply functions_transl; eauto. + generalize (functions_transl_no_overflow _ _ H3); intro NOOV. + simpl in H4. eapply find_instr_tail. + eapply code_tail_next_int; auto. + eapply code_tail_next_int; auto. + eapply code_tail_next_int; eauto. + reflexivity. traceEq. + (* match states *) + econstructor; eauto. + assert (AG3: agree ms (Vptr stk soff) rs3). + unfold rs3, rs2; auto 10 with ppcgen. + assert (AG4: agree ms (parent_sp s) rs4). + split. reflexivity. intros. unfold rs4. + rewrite nextinstr_inv. rewrite Pregmap.gso. + elim AG3; auto. auto with ppcgen. auto with ppcgen. + unfold rs5; auto with ppcgen. Qed. -Lemma exec_trans_prop: - forall (f : function) (sp : val) (c1 : Mach.code) (ms1 : Mach.regset) - (m1 : mem) (t1: trace) (c2 : Mach.code) (ms2 : Mach.regset) (m2 : mem) - (t2: trace) (c3 : Mach.code) (ms3 : Mach.regset) (m3 : mem) (t3: trace), - exec_instrs ge f sp c1 ms1 m1 t1 c2 ms2 m2 -> - exec_instr_prop f sp c1 ms1 m1 t1 c2 ms2 m2 -> - exec_instrs ge f sp c2 ms2 m2 t2 c3 ms3 m3 -> - exec_instr_prop f sp c2 ms2 m2 t2 c3 ms3 m3 -> - t3 = t1 ** t2 -> - exec_instr_prop f sp c1 ms1 m1 t3 c3 ms3 m3. -Proof. - intros; red; intros. - generalize (H0 rs1 WTF INCL AT AG). - intros [rs2 [AG2 [EX2 AT2]]]. - generalize (exec_instrs_incl _ _ _ _ _ _ _ _ _ H INCL). intro INCL2. - generalize (H2 rs2 WTF INCL2 AT2 AG2). - intros [rs3 [AG3 [EX3 AT3]]]. - exists rs3. split. auto. split. eapply exec_trans; eauto. auto. -Qed. +Hypothesis wt_prog: wt_program prog. -Lemma exec_function_body_prop_: - forall (f : function) (parent ra : val) (ms : Mach.regset) (m : mem) - (t: trace) (ms' : Mach.regset) (m1 m2 m3 m4 : mem) (stk : block) - (c : list Mach.instruction), - alloc m (- fn_framesize f) - (align_16_top (- fn_framesize f) (fn_stacksize f)) = (m1, stk) -> - let sp := Vptr stk (Int.repr (- fn_framesize f)) in - store_stack m1 sp Tint (Int.repr 0) parent = Some m2 -> - store_stack m2 sp Tint (Int.repr 12) ra = Some m3 -> - exec_instrs ge f sp (fn_code f) ms m3 t (Mreturn :: c) ms' m4 -> - exec_instr_prop f sp (fn_code f) ms m3 t (Mreturn :: c) ms' m4 -> - load_stack m4 sp Tint (Int.repr 0) = Some parent -> - load_stack m4 sp Tint (Int.repr 12) = Some ra -> - exec_function_body_prop f parent ra ms m t ms' (free m4 stk). +Lemma exec_function_internal_prop: + forall (s : list stackframe) (fb : block) (ms : Mach.regset) + (m : mem) (f : function) (m1 m2 m3 : mem) (stk : block), + Genv.find_funct_ptr ge fb = Some (Internal f) -> + alloc m (- fn_framesize f) + (align_16_top (- fn_framesize f) (fn_stacksize f)) = (m1, stk) -> + let sp := Vptr stk (Int.repr (- fn_framesize f)) in + store_stack m1 sp Tint (Int.repr 0) (parent_sp s) = Some m2 -> + store_stack m2 sp Tint (Int.repr 12) (parent_ra s) = Some m3 -> + exec_instr_prop (Machconcr.Callstate s fb ms m) E0 + (Machconcr.State s fb sp (fn_code f) ms m3). Proof. - intros; red; intros. - generalize (Genv.find_funct_inv AT). intros [b EQPC]. - generalize AT. rewrite EQPC. rewrite Genv.find_funct_find_funct_ptr. intro FN. - generalize (functions_transl_no_overflow _ _ FN); intro NOOV. - set (rs2 := nextinstr (rs1#GPR1 <- sp #GPR2 <- Vundef)). - set (rs3 := nextinstr (rs2#GPR2 <- ra)). + intros; red; intros; inv MS. + assert (WTF: wt_function f). + generalize (Genv.find_funct_ptr_prop wt_fundef wt_prog H); intro TY. + inversion TY; auto. + exploit functions_transl; eauto. intro TFIND. + generalize (functions_transl_no_overflow _ _ H); intro NOOV. + set (rs2 := nextinstr (rs#GPR1 <- sp #GPR2 <- Vundef)). + set (rs3 := nextinstr (rs2#GPR2 <- (parent_ra s))). set (rs4 := nextinstr rs3). - assert (exec_straight tge (transl_function f) - (transl_function f) rs1 m - (transl_code (fn_code f)) rs4 m3). + (* Execution of function prologue *) + assert (EXEC_PROLOGUE: + exec_straight tge (transl_function f) + (transl_function f) rs m + (transl_code (fn_code f)) rs4 m3). unfold transl_function at 2. apply exec_straight_three with rs2 m2 rs3 m2. - unfold exec_instr. rewrite H. fold sp. - generalize H0. unfold store_stack. change (Vint (Int.repr 0)) with Vzero. + unfold exec_instr. rewrite H0. fold sp. + generalize H1. unfold store_stack. change (Vint (Int.repr 0)) with Vzero. replace (Val.add sp Vzero) with sp. simpl chunk_of_type. - rewrite (sp_val _ _ _ AG). intro. rewrite H6. clear H6. + rewrite (sp_val _ _ _ AG). intro EQ; rewrite EQ; clear EQ. reflexivity. unfold sp. simpl. rewrite Int.add_zero. reflexivity. - simpl. replace (rs2 LR) with ra. reflexivity. + simpl. change (rs2 LR) with (rs LR). rewrite ATLR. reflexivity. simpl. unfold store1. rewrite gpr_or_zero_not_zero. - unfold const_low. replace (rs3 GPR1) with sp. replace (rs3 GPR2) with ra. - unfold store_stack in H1. simpl chunk_of_type in H1. rewrite H1. reflexivity. - reflexivity. reflexivity. discriminate. - reflexivity. reflexivity. reflexivity. - assert (AT2: transl_code_at_pc rs4#PC f f.(fn_code)). - change (rs4 PC) with (Val.add (Val.add (Val.add (rs1 PC) Vone) Vone) Vone). - rewrite EQPC. simpl. constructor. auto. + unfold const_low. change (rs3 GPR1) with sp. change (rs3 GPR2) with (parent_ra s). + unfold store_stack in H2. simpl chunk_of_type in H2. rewrite H2. reflexivity. + discriminate. reflexivity. reflexivity. reflexivity. + (* Agreement at end of prologue *) + assert (AT4: transl_code_at_pc rs4#PC fb f f.(fn_code)). + change (rs4 PC) with (Val.add (Val.add (Val.add (rs PC) Vone) Vone) Vone). + rewrite ATPC. simpl. constructor. auto. eapply code_tail_next_int; auto. eapply code_tail_next_int; auto. eapply code_tail_next_int; auto. - unfold Int.zero. rewrite Int.unsigned_repr. - rewrite code_tail_zero. unfold transl_function. reflexivity. - compute. intuition congruence. + change (Int.unsigned Int.zero) with 0. + unfold transl_function. constructor. assert (AG2: agree ms sp rs2). split. reflexivity. intros. unfold rs2. rewrite nextinstr_inv. @@ -1107,114 +1275,52 @@ Proof. auto with ppcgen. auto with ppcgen. auto with ppcgen. assert (AG4: agree ms sp rs4). unfold rs4, rs3; auto with ppcgen. - generalize (H3 rs4 WTF (incl_refl _) AT2 AG4). - intros [rs5 [AG5 [EXB AT5]]]. - set (rs6 := nextinstr (rs5#GPR2 <- ra)). - set (rs7 := nextinstr (rs6#LR <- ra)). - set (rs8 := nextinstr (rs7#GPR1 <- parent)). - set (rs9 := rs8#PC <- ra). - assert (exec_straight tge (transl_function f) - (transl_code (Mreturn :: c)) rs5 m4 - (Pblr :: transl_code c) rs8 (free m4 stk)). - simpl. apply exec_straight_three with rs6 m4 rs7 m4. - simpl. unfold load1. rewrite gpr_or_zero_not_zero. unfold const_low. - unfold load_stack in H5. simpl in H5. - rewrite <- (sp_val _ _ _ AG5). simpl. rewrite H5. - reflexivity. discriminate. - unfold rs7. change ra with rs6#GPR2. reflexivity. - unfold exec_instr. generalize H4. unfold load_stack. - replace (Val.add sp (Vint (Int.repr 0))) with sp. - simpl chunk_of_type. intro. change rs7#GPR1 with rs5#GPR1. - rewrite <- (sp_val _ _ _ AG5). rewrite H7. - unfold sp. reflexivity. - unfold sp. simpl. rewrite Int.add_zero. reflexivity. - reflexivity. reflexivity. reflexivity. - exists rs9. split. - (* agreement *) - assert (AG7: agree ms' sp rs7). - unfold rs7, rs6; auto 10 with ppcgen. - assert (AG8: agree ms' parent rs8). - split. reflexivity. intros. unfold rs8. - rewrite nextinstr_inv. rewrite Pregmap.gso. - elim AG7; auto. auto with ppcgen. auto with ppcgen. - unfold rs9; auto with ppcgen. + left; exists (State rs4 m3); split. (* execution *) - split. apply exec_trans with E0 rs4 m3 t. - eapply exec_straight_steps_1; eauto. - apply functions_transl; auto. - apply exec_trans with t rs5 m4 E0. assumption. - inversion AT5. - apply exec_trans with E0 rs8 (free m4 stk) E0. eapply exec_straight_steps_1; eauto. - apply functions_transl; auto. - apply exec_one. econstructor. - change rs8#PC with (Val.add (Val.add (Val.add rs5#PC Vone) Vone) Vone). - rewrite <- H8. simpl. reflexivity. - apply functions_transl; eauto. - assert (code_tail (Int.unsigned (Int.add (Int.add (Int.add ofs Int.one) Int.one) Int.one)) - (transl_function f) = Pblr :: transl_code c). - eapply code_tail_next_int; auto. - eapply code_tail_next_int; auto. - eapply code_tail_next_int; auto. - rewrite H10. simpl. reflexivity. - rewrite find_instr_tail. rewrite H13. - reflexivity. - reflexivity. - traceEq. traceEq. traceEq. - (* LR preservation *) - change rs9#PC with ra. auto. + change (Int.unsigned Int.zero) with 0. constructor. + (* match states *) + econstructor; eauto with coqlib. Qed. -Lemma exec_function_internal_prop: - forall (f : function) (parent : val) (ms : Mach.regset) (m : mem) - (t: trace) (ms' : Mach.regset) (m' : mem), - (forall ra : val, - Val.has_type ra Tint -> - exec_function_body ge f parent ra ms m t ms' m') -> - (forall ra : val, Val.has_type ra Tint -> - exec_function_body_prop f parent ra ms m t ms' m') -> - exec_function_prop (Internal f) parent ms m t ms' m'. +Lemma exec_function_external_prop: + forall (s : list stackframe) (fb : block) (ms : Mach.regset) + (m : mem) (t0 : trace) (ms' : RegEq.t -> val) + (ef : external_function) (args : list val) (res : val), + Genv.find_funct_ptr ge fb = Some (External ef) -> + event_match ef args t0 res -> + Machconcr.extcall_arguments ms m (parent_sp s) (ef_sig ef) args -> + ms' = Regmap.set (Conventions.loc_result (ef_sig ef)) res ms -> + exec_instr_prop (Machconcr.Callstate s fb ms m) + t0 (Machconcr.Returnstate s ms' m). Proof. - intros; red; intros. - inversion WTF. subst f0. - apply (H0 rs1#LR WTRA rs1 WTRA (refl_equal _) H2 AT AG). + intros; red; intros; inv MS. + exploit functions_translated; eauto. + intros [tf [A B]]. simpl in B. inv B. + left; exists (State (rs#(loc_external_result (ef_sig ef)) <- res #PC <- (rs LR)) + m); split. + apply plus_one. eapply exec_step_external; eauto. + eapply extcall_arguments_match; eauto. + econstructor; eauto. + rewrite loc_external_result_match. auto with ppcgen. Qed. -Lemma exec_function_external_prop: - forall (ef : external_function) (parent : val) (args : list val) - (res : val) (ms1 ms2: Mach.regset) (m : mem) - (t : trace), - event_match ef args t res -> - Mach.extcall_arguments ms1 m parent ef.(ef_sig) args -> - ms2 = Regmap.set (Conventions.loc_result (ef_sig ef)) res ms1 -> - exec_function_prop (External ef) parent ms1 m t ms2 m. +Lemma exec_return_prop: + forall (s : list stackframe) (fb : block) (sp ra : val) + (c : Mach.code) (ms : Mach.regset) (m : mem), + exec_instr_prop (Machconcr.Returnstate (Stackframe fb sp ra c :: s) ms m) E0 + (Machconcr.State s fb sp c ms m). Proof. - intros; red; intros. - destruct (Genv.find_funct_inv AT) as [b EQ]. - rewrite EQ in AT. rewrite Genv.find_funct_find_funct_ptr in AT. - exists (rs1#(loc_external_result (ef_sig ef)) <- res #PC <- (rs1 LR)). - split. rewrite loc_external_result_match. rewrite H1. auto with ppcgen. - split. apply exec_one. eapply exec_step_external; eauto. - destruct (functions_translated _ _ AT) as [tf [A B]]. - simpl in B. congruence. - eapply extcall_arguments_match; eauto. - reflexivity. + intros; red; intros; inv MS. inv STACKS. simpl in *. + right. split. omega. split. auto. + econstructor; eauto. rewrite ATPC; auto. Qed. -(** We then conclude by induction on the structure of the Mach -execution derivation. *) - -Theorem transf_function_correct: - forall f parent ms m t ms' m', - Mach.exec_function ge f parent ms m t ms' m' -> - exec_function_prop f parent ms m t ms' m'. -Proof - (Mach.exec_function_ind4 ge - exec_instr_prop - exec_instr_prop - exec_function_body_prop - exec_function_prop - +Theorem transf_instr_correct: + forall s1 t s2, Machconcr.step ge s1 t s2 -> + exec_instr_prop s1 t s2. +Proof + (Machconcr.step_ind ge exec_instr_prop exec_Mlabel_prop exec_Mgetstack_prop exec_Msetstack_prop @@ -1223,53 +1329,50 @@ Proof exec_Mload_prop exec_Mstore_prop exec_Mcall_prop + exec_Mtailcall_prop exec_Malloc_prop exec_Mgoto_prop exec_Mcond_true_prop exec_Mcond_false_prop - exec_refl_prop - exec_one_prop - exec_trans_prop - exec_function_body_prop_ + exec_Mreturn_prop exec_function_internal_prop - exec_function_external_prop). + exec_function_external_prop + exec_return_prop). -End PRESERVATION. +Lemma transf_initial_states: + forall st1, Machconcr.initial_state prog st1 -> + exists st2, PPC.initial_state tprog st2 /\ match_states st1 st2. +Proof. + intros. inversion H. unfold ge0 in *. + econstructor; split. + econstructor. + replace (symbol_offset (Genv.globalenv tprog) (prog_main tprog) Int.zero) + with (Vptr fb Int.zero). + rewrite (Genv.init_mem_transf_partial _ _ TRANSF). + econstructor; eauto. constructor. + split. auto. intros. repeat rewrite Pregmap.gso; auto with ppcgen. + unfold symbol_offset. + rewrite (transform_partial_program_main _ _ TRANSF). + rewrite symbols_preserved. unfold ge; rewrite H0. auto. +Qed. + +Lemma transf_final_states: + forall st1 st2 r, + match_states st1 st2 -> Machconcr.final_state st1 r -> PPC.final_state st2 r. +Proof. + intros. inv H0. inv H. constructor. auto. + rewrite (ireg_val _ _ _ R3 AG) in H1. auto. auto. +Qed. Theorem transf_program_correct: - forall (p: Mach.program) (tp: PPC.program) (t: trace) (r: val), - wt_program p -> - transf_program p = Some tp -> - Mach.exec_program p t r -> - PPC.exec_program tp t r. + forall (beh: program_behavior), + Machconcr.exec_program prog beh -> PPC.exec_program tprog beh. Proof. - intros. - destruct H1 as [fptr [f [ms [m [FINDS [FINDF [EX RES]]]]]]]. - assert (WTF: wt_fundef f). - apply (Genv.find_funct_ptr_prop wt_fundef H FINDF). - set (ge := Genv.globalenv p) in *. - set (ms0 := Regmap.init Vundef) in *. - set (tge := Genv.globalenv tp). - set (rs0 := - (Pregmap.init Vundef) # PC <- (symbol_offset tge tp.(prog_main) Int.zero) - # LR <- Vzero - # GPR1 <- (Vptr Mem.nullptr Int.zero)). - assert (AT: Genv.find_funct ge (rs0 PC) = Some f). - change (rs0 PC) with (symbol_offset tge tp.(prog_main) Int.zero). - rewrite (transform_partial_program_main _ _ H0). - unfold symbol_offset. rewrite (symbols_preserved p tp H0). - fold ge. rewrite FINDS. - rewrite Genv.find_funct_find_funct_ptr. exact FINDF. - assert (AG: agree ms0 (Vptr Mem.nullptr Int.zero) rs0). - split. reflexivity. intros. unfold rs0. - repeat (rewrite Pregmap.gso; auto with ppcgen). - assert (WTRA: Val.has_type (rs0 LR) Tint). - exact I. - generalize (transf_function_correct p tp H0 H - _ _ _ _ _ _ _ EX rs0 WTF AT AG WTRA). - intros [rs [AG' [EX' RPC]]]. - red. exists rs; exists m. - split. rewrite (Genv.init_mem_transf_partial _ _ H0). exact EX'. - split. rewrite RPC. reflexivity. rewrite <- RES. - change (IR GPR3) with (preg_of R3). elim AG'; auto. + unfold Machconcr.exec_program, PPC.exec_program; intros. + eapply simulation_star_preservation with (measure := measure); eauto. + eexact transf_initial_states. + eexact transf_final_states. + exact transf_instr_correct. Qed. + +End PRESERVATION. diff --git a/backend/PPCgenproof1.v b/backend/PPCgenproof1.v index f9af3c30..1b432c72 100644 --- a/backend/PPCgenproof1.v +++ b/backend/PPCgenproof1.v @@ -11,6 +11,7 @@ Require Import Globalenvs. Require Import Op. Require Import Locations. Require Import Mach. +Require Import Machconcr. Require Import Machtyping. Require Import PPC. Require Import PPCgen. @@ -448,7 +449,7 @@ Lemma extcall_args_match: forall tyl iregl fregl ofs args, (forall r, In r iregl -> mreg_type r = Tint) -> (forall r, In r fregl -> mreg_type r = Tfloat) -> - Mach.extcall_args ms m sp (Conventions.loc_arguments_rec tyl iregl fregl ofs) args -> + Machconcr.extcall_args ms m sp (Conventions.loc_arguments_rec tyl iregl fregl ofs) args -> PPC.extcall_args rs m tyl (List.map ireg_of iregl) (List.map freg_of fregl) (4 * ofs) args. Proof. induction tyl; intros. @@ -478,9 +479,7 @@ Proof. eapply sp_val; eauto. change (@nil freg) with (freg_of ## nil). replace (4 * ofs + 8) with (4 * (ofs + 2)) by omega. - rewrite list_map_drop2. apply IHtyl; auto. - intros. apply H0. apply list_drop2_incl. auto. (* register *) inversion H2; subst; clear H2. inversion H8; subst; clear H8. simpl map. econstructor. eapply freg_val; eauto. @@ -505,13 +504,13 @@ Ltac ElimOrEq := Lemma extcall_arguments_match: forall ms m sp rs sg args, agree ms sp rs -> - Mach.extcall_arguments ms m sp sg args -> + Machconcr.extcall_arguments ms m sp sg args -> PPC.extcall_arguments rs m sg args. Proof. - unfold Mach.extcall_arguments, PPC.extcall_arguments; intros. + unfold Machconcr.extcall_arguments, PPC.extcall_arguments; intros. change (extcall_args rs m sg.(sig_args) (List.map ireg_of Conventions.int_param_regs) - (List.map freg_of Conventions.float_param_regs) (4 * 6) args). + (List.map freg_of Conventions.float_param_regs) (4 * 14) args). eapply extcall_args_match; eauto. intro; simpl; ElimOrEq; reflexivity. intro; simpl; ElimOrEq; reflexivity. @@ -533,9 +532,11 @@ Variable fn: code. Inductive exec_straight: code -> regset -> mem -> code -> regset -> mem -> Prop := - | exec_straight_refl: - forall c rs m, - exec_straight c rs m c rs m + | exec_straight_one: + forall i1 c rs1 m1 rs2 m2, + exec_instr ge fn i1 rs1 m1 = OK rs2 m2 -> + rs2#PC = Val.add rs1#PC Vone -> + exec_straight (i1 :: c) rs1 m1 c rs2 m2 | exec_straight_step: forall i c rs1 m1 rs2 m2 c' rs3 m3, exec_instr ge fn i rs1 m1 = OK rs2 m2 -> @@ -549,18 +550,9 @@ Lemma exec_straight_trans: exec_straight c2 rs2 m2 c3 rs3 m3 -> exec_straight c1 rs1 m1 c3 rs3 m3. Proof. - induction 1. auto. - intro. apply exec_straight_step with rs2 m2; auto. -Qed. - -Lemma exec_straight_one: - forall i1 c rs1 m1 rs2 m2, - exec_instr ge fn i1 rs1 m1 = OK rs2 m2 -> - rs2#PC = Val.add rs1#PC Vone -> - exec_straight (i1 :: c) rs1 m1 c rs2 m2. -Proof. - intros. apply exec_straight_step with rs2 m2. auto. auto. - apply exec_straight_refl. + induction 1; intros. + apply exec_straight_step with rs2 m2; auto. + apply exec_straight_step with rs2 m2; auto. Qed. Lemma exec_straight_two: @@ -1182,7 +1174,7 @@ Lemma transl_cond_correct: forall cond args k ms sp rs m b, map mreg_type args = type_of_condition cond -> agree ms sp rs -> - eval_condition cond (map ms args) = Some b -> + eval_condition cond (map ms args) m = Some b -> exists rs', exec_straight (transl_cond cond args k) rs m k rs' m /\ rs'#(reg_of_crbit (fst (crbit_for_cond cond))) = @@ -1191,7 +1183,7 @@ Lemma transl_cond_correct: else Val.notbool (Val.of_bool b)) /\ agree ms sp rs'. Proof. - intros. rewrite <- (eval_condition_weaken _ _ H1). + intros. rewrite <- (eval_condition_weaken _ _ _ H1). apply transl_cond_correct_aux; auto. Qed. @@ -1221,12 +1213,12 @@ Lemma transl_op_correct: forall op args res k ms sp rs m v, wt_instr (Mop op args res) -> agree ms sp rs -> - eval_operation ge sp op (map ms args) = Some v -> + eval_operation ge sp op (map ms args) m = Some v -> exists rs', exec_straight (transl_op op args res k) rs m k rs' m /\ agree (Regmap.set res v ms) sp rs'. Proof. - intros. rewrite <- (eval_operation_weaken _ _ _ _ H1). clear H1; clear v. + intros. rewrite <- (eval_operation_weaken _ _ _ _ _ H1). clear H1; clear v. inversion H. (* Omove *) simpl. exists (nextinstr (rs#(preg_of res) <- (ms r1))). @@ -1238,19 +1230,9 @@ Proof. simpl. unfold preg_of. rewrite <- H2. rewrite H5. reflexivity. auto with ppcgen. auto with ppcgen. - (* Oundef *) - simpl. exists (nextinstr (rs#(preg_of res) <- Vundef)). - split. caseEq (mreg_type res); intro. - apply exec_straight_one. simpl. - unfold preg_of; rewrite H1. reflexivity. - auto with ppcgen. - apply exec_straight_one. simpl. - unfold preg_of; rewrite H1. reflexivity. - auto with ppcgen. - auto with ppcgen. (* Other instructions *) - clear H1; clear H2; clear H3. - destruct op; simpl in H6; injection H6; clear H6; intros; + clear H1; clear H2; clear H4. + destruct op; simpl in H5; injection H5; clear H5; intros; TypeInv; simpl; try (TranslOpSimpl). (* Omove again *) congruence. @@ -1283,8 +1265,6 @@ Proof. exists rs'. split. auto. apply agree_set_mireg_exten with rs; auto. rewrite (sp_val ms sp rs). auto. auto. - (* Oundef again *) - congruence. (* Ocast8unsigned *) exists (nextinstr (rs#(ireg_of res) <- (Val.rolm (ms m0) Int.zero (Int.repr 255)))). split. apply exec_straight_one. repeat (rewrite (ireg_val ms sp rs)); auto. reflexivity. diff --git a/backend/PPCgenretaddr.v b/backend/PPCgenretaddr.v new file mode 100644 index 00000000..f2802ecd --- /dev/null +++ b/backend/PPCgenretaddr.v @@ -0,0 +1,176 @@ +(** Predictor for return addresses in generated PPC code. + + The [return_address_offset] predicate defined here is used in the + concrete semantics for Mach (module [Machconcr]) to determine the + return addresses that are stored in activation records. *) + +Require Import Coqlib. +Require Import Maps. +Require Import AST. +Require Import Integers. +Require Import Floats. +Require Import Values. +Require Import Mem. +Require Import Globalenvs. +Require Import Op. +Require Import Locations. +Require Import Mach. +Require Import PPC. +Require Import PPCgen. + +(** The ``code tail'' of an instruction list [c] is the list of instructions + starting at PC [pos]. *) + +Inductive code_tail: Z -> code -> code -> Prop := + | code_tail_0: forall c, + code_tail 0 c c + | code_tail_S: forall pos i c1 c2, + code_tail pos c1 c2 -> + code_tail (pos + 1) (i :: c1) c2. + +Lemma code_tail_pos: + forall pos c1 c2, code_tail pos c1 c2 -> pos >= 0. +Proof. + induction 1. omega. omega. +Qed. + +(** Consider a Mach function [f] and a sequence [c] of Mach instructions + representing the Mach code that remains to be executed after a + function call returns. The predicate [return_address_offset f c ofs] + holds if [ofs] is the integer offset of the PPC instruction + following the call in the PPC code obtained by translating the + code of [f]. Graphically: +<< + Mach function f |--------- Mcall ---------| + Mach code c | |--------| + | \ \ + | \ \ + | \ \ + PPC code | |--------| + PPC function |--------------- Pbl ---------| + + <-------- ofs -------> +>> +*) + +Inductive return_address_offset: Mach.function -> Mach.code -> int -> Prop := + | return_address_offset_intro: + forall c f ofs, + code_tail ofs (transl_function f) (transl_code c) -> + return_address_offset f c (Int.repr ofs). + +(** We now show that such an offset always exists if the Mach code [c] + is a suffix of [f.(fn_code)]. This holds because the translation + from Mach to PPC is compositional: each Mach instruction becomes + zero, one or several PPC instructions, but the order of instructions + is preserved. *) + +Lemma is_tail_code_tail: + forall c1 c2, is_tail c1 c2 -> exists ofs, code_tail ofs c2 c1. +Proof. + induction 1. exists 0; constructor. + destruct IHis_tail as [ofs CT]. exists (ofs + 1); constructor; auto. +Qed. + +Hint Resolve is_tail_refl: ppcretaddr. + +Ltac IsTail := + auto with ppcretaddr; + match goal with + | [ |- is_tail _ (_ :: _) ] => constructor; IsTail + | [ |- is_tail _ (match ?x with true => _ | false => _ end) ] => destruct x; IsTail + | [ |- is_tail _ (match ?x with left _ => _ | right _ => _ end) ] => destruct x; IsTail + | [ |- is_tail _ (match ?x with nil => _ | _ :: _ => _ end) ] => destruct x; IsTail + | [ |- is_tail _ (match ?x with Tint => _ | Tfloat => _ end) ] => destruct x; IsTail + | [ |- is_tail _ (?f _ _ _ _ _ _ ?k) ] => apply is_tail_trans with k; IsTail + | [ |- is_tail _ (?f _ _ _ _ _ ?k) ] => apply is_tail_trans with k; IsTail + | [ |- is_tail _ (?f _ _ _ _ ?k) ] => apply is_tail_trans with k; IsTail + | [ |- is_tail _ (?f _ _ _ ?k) ] => apply is_tail_trans with k; IsTail + | [ |- is_tail _ (?f _ _ ?k) ] => apply is_tail_trans with k; IsTail + | _ => idtac + end. + +Lemma loadimm_tail: + forall r n k, is_tail k (loadimm r n k). +Proof. unfold loadimm; intros; IsTail. Qed. +Hint Resolve loadimm_tail: ppcretaddr. + +Lemma addimm_tail: + forall r1 r2 n k, is_tail k (addimm r1 r2 n k). +Proof. unfold addimm, addimm_1, addimm_2; intros; IsTail. Qed. +Hint Resolve addimm_tail: ppcretaddr. + +Lemma andimm_tail: + forall r1 r2 n k, is_tail k (andimm r1 r2 n k). +Proof. unfold andimm; intros; IsTail. Qed. +Hint Resolve andimm_tail: ppcretaddr. + +Lemma orimm_tail: + forall r1 r2 n k, is_tail k (orimm r1 r2 n k). +Proof. unfold orimm; intros; IsTail. Qed. +Hint Resolve orimm_tail: ppcretaddr. + +Lemma xorimm_tail: + forall r1 r2 n k, is_tail k (xorimm r1 r2 n k). +Proof. unfold xorimm; intros; IsTail. Qed. +Hint Resolve xorimm_tail: ppcretaddr. + +Lemma loadind_tail: + forall base ofs ty dst k, is_tail k (loadind base ofs ty dst k). +Proof. unfold loadind; intros; IsTail. Qed. +Hint Resolve loadind_tail: ppcretaddr. + +Lemma storeind_tail: + forall src base ofs ty k, is_tail k (storeind src base ofs ty k). +Proof. unfold storeind; intros; IsTail. Qed. +Hint Resolve storeind_tail: ppcretaddr. + +Lemma floatcomp_tail: + forall cmp r1 r2 k, is_tail k (floatcomp cmp r1 r2 k). +Proof. unfold floatcomp; intros; destruct cmp; IsTail. Qed. +Hint Resolve floatcomp_tail: ppcretaddr. + +Lemma transl_cond_tail: + forall cond args k, is_tail k (transl_cond cond args k). +Proof. unfold transl_cond; intros; destruct cond; IsTail. Qed. +Hint Resolve transl_cond_tail: ppcretaddr. + +Lemma transl_op_tail: + forall op args r k, is_tail k (transl_op op args r k). +Proof. unfold transl_op; intros; destruct op; IsTail. Qed. +Hint Resolve transl_op_tail: ppcretaddr. + +Lemma transl_load_store_tail: + forall mk1 mk2 addr args k, + is_tail k (transl_load_store mk1 mk2 addr args k). +Proof. unfold transl_load_store; intros; destruct addr; IsTail. Qed. +Hint Resolve transl_load_store_tail: ppcretaddr. + +Lemma transl_instr_tail: + forall i k, is_tail k (transl_instr i k). +Proof. + unfold transl_instr; intros; destruct i; IsTail. + destruct m; IsTail. + destruct m; IsTail. + destruct s0; IsTail. + destruct s0; IsTail. +Qed. +Hint Resolve transl_instr_tail: ppcretaddr. + +Lemma transl_code_tail: + forall c1 c2, is_tail c1 c2 -> is_tail (transl_code c1) (transl_code c2). +Proof. + induction 1; simpl. constructor. eapply is_tail_trans; eauto with ppcretaddr. +Qed. + +Lemma return_address_exists: + forall f c, is_tail c f.(fn_code) -> + exists ra, return_address_offset f c ra. +Proof. + intros. assert (is_tail (transl_code c) (transl_function f)). + unfold transl_function. IsTail. apply transl_code_tail; auto. + destruct (is_tail_code_tail _ _ H0) as [ofs A]. + exists (Int.repr ofs). constructor. auto. +Qed. + + diff --git a/backend/Parallelmove.v b/backend/Parallelmove.v index b2ec930b..3d77b57a 100644 --- a/backend/Parallelmove.v +++ b/backend/Parallelmove.v @@ -1,3 +1,14 @@ +(** Translation of parallel moves into sequences of individual moves. + + In this file, we adapt the generic "parallel move" algorithm + (developed and proved correct in module [Parmov]) to the idiosyncraties + of the [LTLin] and [Linear] intermediate languages. While the generic + algorithm assumes that registers never overlap, the locations + used in [LTLin] and [Linear] can overlap, and assigning one location + can set the values of other, overlapping locations to [Vundef]. + We address this issue in the remainder of this file. +*) + Require Import Coqlib. Require Parmov. Require Import Values. @@ -6,16 +17,28 @@ Require Import AST. Require Import Locations. Require Import Conventions. +(** * Instantiating the generic parallel move algorithm *) + +(** The temporary location to use for a move is determined + by the type of the data being moved: register [IT2] for an + integer datum, and register [FT2] for a floating-point datum. *) + Definition temp_for (l: loc) : loc := match Loc.type l with Tint => R IT2 | Tfloat => R FT2 end. Definition parmove (srcs dsts: list loc) := - Parmov.parmove2 loc temp_for Loc.eq srcs dsts. + Parmov.parmove2 loc Loc.eq temp_for srcs dsts. Definition moves := (list (loc * loc))%type. +(** [exec_seq m] gives semantics to a sequence of elementary moves. + This semantics ignores the possibility of overlap: only the + target locations are updated, but the locations they + overlap with are not set to [Vundef]. See [effect_seqmove] below + for a semantics that accounts for overlaps. *) + Definition exec_seq (m: moves) (e: Locmap.t) : Locmap.t := - Parmov.exec_seq loc val Loc.eq m e. + Parmov.exec_seq loc Loc.eq val m e. Lemma temp_for_charact: forall l, temp_for l = R IT2 \/ temp_for l = R FT2. @@ -52,6 +75,12 @@ Proof. apply Loc.notin_not_in; auto. auto. Qed. +(** Instantiating the theorems proved in [Parmov], we obtain + the following properties of semantic correctness and well-typedness + of the generated sequence of moves. Note that the semantic + correctness result is stated in terms of the [exec_seq] semantics, + and therefore does not account for overlap between locations. *) + Lemma parmove_prop_1: forall srcs dsts, List.length srcs = List.length dsts -> @@ -69,8 +98,8 @@ Proof. intros. apply disjoint_temp_not_temp. apply Loc.disjoint_notin with srcs; auto. assert (NTD: forall r, In r dsts -> Parmov.is_not_temp loc temp_for r). intros. apply disjoint_temp_not_temp. apply Loc.disjoint_notin with dsts; auto. - generalize (Parmov.parmove2_correctness loc temp_for val Loc.eq srcs dsts H NR NTS NTD e). - change (Parmov.exec_seq loc val Loc.eq (Parmov.parmove2 loc temp_for Loc.eq srcs dsts) e) with e'. + generalize (Parmov.parmove2_correctness loc Loc.eq temp_for val srcs dsts H NR NTS NTD e). + change (Parmov.exec_seq loc Loc.eq val (Parmov.parmove2 loc Loc.eq temp_for srcs dsts) e) with e'. intros [A B]. split. auto. intros. apply B. auto. rewrite is_not_temp_charact; auto. Qed. @@ -97,7 +126,7 @@ Proof. tauto. right. apply temp_for_charact. intros. apply H. - apply (Parmov.parmove2_wf_moves loc temp_for Loc.eq srcs dsts s d H0). + apply (Parmov.parmove2_wf_moves loc Loc.eq temp_for srcs dsts s d H0). Qed. Lemma loc_type_temp_for: @@ -134,11 +163,21 @@ Proof. rewrite loc_type_temp_for; auto. rewrite loc_type_temp_for; auto. intros. apply H. - apply (Parmov.parmove2_wf_moves loc temp_for Loc.eq srcs dsts s d H0). + apply (Parmov.parmove2_wf_moves loc Loc.eq temp_for srcs dsts s d H0). Qed. +(** * Accounting for overlap between locations *) + Section EQUIVALENCE. +(** We now prove the correctness of the generated sequence of elementary + moves, accounting for possible overlap between locations. + The proof is conducted under the following hypotheses: there must + be no partial overlap between +- two distinct destinations (hypothesis [NOREPET]); +- a source location and a destination location (hypothesis [NO_OVERLAP]). +*) + Variables srcs dsts: list loc. Hypothesis LENGTH: List.length srcs = List.length dsts. Hypothesis NOREPET: Loc.norepet dsts. @@ -146,9 +185,16 @@ Hypothesis NO_OVERLAP: Loc.no_overlap srcs dsts. Hypothesis NO_SRCS_TEMP: Loc.disjoint srcs temporaries. Hypothesis NO_DSTS_TEMP: Loc.disjoint dsts temporaries. +(** [no_overlap_dests l] holds if location [l] does not partially overlap + a destination location: either it is identical to one of the + destinations, or it is disjoint from all destinations. *) + Definition no_overlap_dests (l: loc) : Prop := forall d, In d dsts -> l = d \/ Loc.diff l d. +(** We show that [no_overlap_dests] holds for any destination location + and for any source location. *) + Lemma dests_no_overlap_dests: forall l, In l dsts -> no_overlap_dests l. Proof. @@ -201,10 +247,19 @@ Proof. elim H2; intro; subst d; auto. Qed. +(** [locmap_equiv e1 e2] holds if the location maps [e1] and [e2] + assign the same values to all locations except temporaries [IT1], [FT1] + and except locations that partially overlap a destination. *) + Definition locmap_equiv (e1 e2: Locmap.t): Prop := forall l, no_overlap_dests l -> Loc.diff l (R IT1) -> Loc.diff l (R FT1) -> e2 l = e1 l. +(** The following predicates characterize the effect of one move + move ([effect_move]) and of a sequence of elementary moves + ([effect_seqmove]). We allow the code generated for one move + to use the temporaries [IT1] and [FT1] in any way it needs. *) + Definition effect_move (src dst: loc) (e e': Locmap.t): Prop := e' dst = e src /\ forall l, Loc.diff l dst -> Loc.diff l (R IT1) -> Loc.diff l (R FT1) -> e' l = e l. @@ -217,12 +272,18 @@ Inductive effect_seqmove: list (loc * loc) -> Locmap.t -> Locmap.t -> Prop := effect_seqmove m e2 e3 -> effect_seqmove ((s, d) :: m) e1 e3. +(** The following crucial lemma shows that [locmap_equiv] is preserved + by executing one move [d <- s], once using the [effect_move] + predicate that accounts for partial overlap and the use of + temporaries [IT1], [FT1], or via the [Parmov.update] function that + does not account for any of these. *) + Lemma effect_move_equiv: forall s d e1 e2 e1', (In s srcs \/ s = R IT2 \/ s = R FT2) -> (In d dsts \/ d = R IT2 \/ d = R FT2) -> locmap_equiv e1 e2 -> effect_move s d e1 e1' -> - locmap_equiv e1' (Parmov.update loc val Loc.eq d (e2 s) e2). + locmap_equiv e1' (Parmov.update loc Loc.eq val d (e2 s) e2). Proof. intros. destruct H2. red; intros. unfold Parmov.update. destruct (Loc.eq l d). @@ -231,6 +292,9 @@ Proof. rewrite H3; auto. apply dest_noteq_diff; auto. Qed. +(** We then extend the previous lemma to a sequence [mu] of elementary moves. +*) + Lemma effect_seqmove_equiv: forall mu e1 e1', effect_seqmove mu e1 e1' -> @@ -249,6 +313,13 @@ Proof. eapply effect_move_equiv; eauto. Qed. +(** Here is the main result in this file: executing the sequence + of moves returned by the [parmove] function results in the + desired state for locations: the final values of destination locations + are the initial values of source locations, and all locations + that are disjoint from the temporaries and the destinations + keep their initial values. *) + Lemma effect_parmove: forall e e', effect_seqmove (parmove srcs dsts) e e' -> diff --git a/backend/RTL.v b/backend/RTL.v index 8b46a7db..74719977 100644 --- a/backend/RTL.v +++ b/backend/RTL.v @@ -1,10 +1,9 @@ (** The RTL intermediate language: abstract syntax and semantics. - RTL (``Register Transfer Language'' is the first intermediate language - after Cminor. + RTL stands for "Register Transfer Language". This is the first + intermediate language after Cminor and CminorSel. *) -(*Require Import Relations.*) Require Import Coqlib. Require Import Maps. Require Import AST. @@ -13,6 +12,7 @@ Require Import Values. Require Import Events. Require Import Mem. Require Import Globalenvs. +Require Import Smallstep. Require Import Op. Require Import Registers. @@ -55,6 +55,7 @@ Inductive instruction: Set := function name), giving it the values of registers [args] as arguments. It stores the return value in [dest] and branches to [succ]. *) + | Itailcall: signature -> reg + ident -> list reg -> instruction | Ialloc: reg -> reg -> node -> instruction (** [Ialloc arg dest succ] allocates a fresh block of size the contents of register [arg], stores a pointer to this @@ -111,6 +112,52 @@ Fixpoint init_regs (vl: list val) (rl: list reg) {struct rl} : regset := | _, _ => Regmap.init Vundef end. +Inductive stackframe : Set := + | Stackframe: + forall (res: reg) (c: code) (sp: val) (pc: node) (rs: regset), + stackframe. + +Inductive state : Set := + | State: + forall (stack: list stackframe) (c: code) (sp: val) (pc: node) + (rs: regset) (m: mem), state + | Callstate: + forall (stack: list stackframe) (f: fundef) (args: list val) (m: mem), + state + | Returnstate: + forall (stack: list stackframe) (v: val) (m: mem), + state. + +(** The dynamic semantics of RTL is given in small-step style, as a + set of transitions between states. A state captures the current + point in the execution. Three kinds of states appear in the transitions: + +- [State cs c sp pc rs m] describes an execution point within a function. + [c] is the code for the current function (a CFG). + [sp] is the pointer to the stack block for its current activation + (as in Cminor). + [pc] is the current program point (CFG node) within the code [c]. + [rs] gives the current values for the pseudo-registers. + [m] is the current memory state. +- [Callstate cs f args m] is an intermediate state that appears during + function calls. + [f] is the function definition that we are calling. + [args] (a list of values) are the arguments for this call. + [m] is the current memory state. +- [Returnstate cs v m] is an intermediate state that appears when a + function terminates and returns to its caller. + [v] is the return value and [m] the current memory state. + +In all three kinds of states, the [cs] parameter represents the call stack. +It is a list of frames [Stackframe res c sp pc rs]. Each frame represents +a function call in progress. +[res] is the pseudo-register that will receive the result of the call. +[c] is the code of the calling function. +[sp] is its stack pointer. +[pc] is the program point for the instruction that follows the call. +[rs] is the state of registers in the calling function. +*) + Section RELSEM. Variable ge: genv. @@ -126,194 +173,142 @@ Definition find_function end end. -(** The dynamic semantics of RTL is a combination of small-step (transition) - semantics and big-step semantics. Execution of an instruction performs - a single transition to the next instruction (small-step), except if - the instruction is a function call. In this case, the whole body of - the called function is executed at once and the transition terminates - on the instruction immediately following the call in the caller function. - Such ``mixed-step'' semantics is convenient for reasoning over - intra-procedural analyses and transformations. It also dispenses us - from making the call stack explicit in the semantics. - - The semantics is organized in three mutually inductive predicates. - The first is [exec_instr ge c sp pc rs m pc' rs' m']. [ge] is the - global environment (see module [Genv]), [c] the CFG for the current - function, and [sp] the pointer to the stack block for its - current activation (as in Cminor). [pc], [rs] and [m] is the - initial state of the transition: program point (CFG node) [pc], - register state (mapping of pseudo-registers to values) [rs], - and memory state [m]. The final state is [pc'], [rs'] and [m']. *) - -Inductive exec_instr: code -> val -> - node -> regset -> mem -> trace -> - node -> regset -> mem -> Prop := +(** The transitions are presented as an inductive predicate + [step ge st1 t st2], where [ge] is the global environment, + [st1] the initial state, [st2] the final state, and [t] the trace + of system calls performed during this transition. *) + +Inductive step: state -> trace -> state -> Prop := | exec_Inop: - forall c sp pc rs m pc', + forall s c sp pc rs m pc', c!pc = Some(Inop pc') -> - exec_instr c sp pc rs m E0 pc' rs m + step (State s c sp pc rs m) + E0 (State s c sp pc' rs m) | exec_Iop: - forall c sp pc rs m op args res pc' v, + forall s c sp pc rs m op args res pc' v, c!pc = Some(Iop op args res pc') -> - eval_operation ge sp op rs##args = Some v -> - exec_instr c sp pc rs m E0 pc' (rs#res <- v) m + eval_operation ge sp op rs##args m = Some v -> + step (State s c sp pc rs m) + E0 (State s c sp pc' (rs#res <- v) m) | exec_Iload: - forall c sp pc rs m chunk addr args dst pc' a v, + forall s c sp pc rs m chunk addr args dst pc' a v, c!pc = Some(Iload chunk addr args dst pc') -> eval_addressing ge sp addr rs##args = Some a -> Mem.loadv chunk m a = Some v -> - exec_instr c sp pc rs m E0 pc' (rs#dst <- v) m + step (State s c sp pc rs m) + E0 (State s c sp pc' (rs#dst <- v) m) | exec_Istore: - forall c sp pc rs m chunk addr args src pc' a m', + forall s c sp pc rs m chunk addr args src pc' a m', c!pc = Some(Istore chunk addr args src pc') -> eval_addressing ge sp addr rs##args = Some a -> Mem.storev chunk m a rs#src = Some m' -> - exec_instr c sp pc rs m E0 pc' rs m' + step (State s c sp pc rs m) + E0 (State s c sp pc' rs m') | exec_Icall: - forall c sp pc rs m sig ros args res pc' f vres m' t, + forall s c sp pc rs m sig ros args res pc' f, c!pc = Some(Icall sig ros args res pc') -> find_function ros rs = Some f -> funsig f = sig -> - exec_function f rs##args m t vres m' -> - exec_instr c sp pc rs m t pc' (rs#res <- vres) m' + step (State s c sp pc rs m) + E0 (Callstate (Stackframe res c sp pc' rs :: s) f rs##args m) + | exec_Itailcall: + forall s c stk pc rs m sig ros args f, + c!pc = Some(Itailcall sig ros args) -> + find_function ros rs = Some f -> + funsig f = sig -> + step (State s c (Vptr stk Int.zero) pc rs m) + E0 (Callstate s f rs##args (Mem.free m stk)) | exec_Ialloc: - forall c sp pc rs m pc' arg res sz m' b, + forall s c sp pc rs m pc' arg res sz m' b, c!pc = Some(Ialloc arg res pc') -> rs#arg = Vint sz -> Mem.alloc m 0 (Int.signed sz) = (m', b) -> - exec_instr c sp pc rs m E0 pc' (rs#res <- (Vptr b Int.zero)) m' + step (State s c sp pc rs m) + E0 (State s c sp pc' (rs#res <- (Vptr b Int.zero)) m') | exec_Icond_true: - forall c sp pc rs m cond args ifso ifnot, + forall s c sp pc rs m cond args ifso ifnot, c!pc = Some(Icond cond args ifso ifnot) -> - eval_condition cond rs##args = Some true -> - exec_instr c sp pc rs m E0 ifso rs m + eval_condition cond rs##args m = Some true -> + step (State s c sp pc rs m) + E0 (State s c sp ifso rs m) | exec_Icond_false: - forall c sp pc rs m cond args ifso ifnot, + forall s c sp pc rs m cond args ifso ifnot, c!pc = Some(Icond cond args ifso ifnot) -> - eval_condition cond rs##args = Some false -> - exec_instr c sp pc rs m E0 ifnot rs m - -(** [exec_instrs ge c sp pc rs m pc' rs' m'] is the reflexive - transitive closure of [exec_instr]. It corresponds to the execution - of zero, one or finitely many transitions. *) - -with exec_instrs: code -> val -> - node -> regset -> mem -> trace -> - node -> regset -> mem -> Prop := - | exec_refl: - forall c sp pc rs m, - exec_instrs c sp pc rs m E0 pc rs m - | exec_one: - forall c sp pc rs m t pc' rs' m', - exec_instr c sp pc rs m t pc' rs' m' -> - exec_instrs c sp pc rs m t pc' rs' m' - | exec_trans: - forall c sp pc1 rs1 m1 t1 pc2 rs2 m2 t2 pc3 rs3 m3 t3, - exec_instrs c sp pc1 rs1 m1 t1 pc2 rs2 m2 -> - exec_instrs c sp pc2 rs2 m2 t2 pc3 rs3 m3 -> - t3 = t1 ** t2 -> - exec_instrs c sp pc1 rs1 m1 t3 pc3 rs3 m3 - -(** [exec_function ge f args m res m'] executes a function application. - [f] is the called function, [args] the values of its arguments, - and [m] the memory state at the beginning of the call. [res] is - the returned value: the value of [r] if the function terminates with - a [Ireturn (Some r)], or [Vundef] if it terminates with [Ireturn None]. - Evaluation proceeds by executing transitions from the function's entry - point to the first [Ireturn] instruction encountered. It is preceeded - by the allocation of the stack activation block and the binding - of register parameters to the provided arguments. - (Non-parameter registers are initialized to [Vundef].) Before returning, - the stack activation block is freed. *) - -with exec_function: fundef -> list val -> mem -> trace -> - val -> mem -> Prop := - | exec_funct_internal: - forall f m m1 stk args t pc rs m2 or vres, - Mem.alloc m 0 f.(fn_stacksize) = (m1, stk) -> - exec_instrs f.(fn_code) (Vptr stk Int.zero) - f.(fn_entrypoint) (init_regs args f.(fn_params)) m1 - t pc rs m2 -> - f.(fn_code)!pc = Some(Ireturn or) -> - vres = regmap_optget or Vundef rs -> - exec_function (Internal f) args m t vres (Mem.free m2 stk) - | exec_funct_external: - forall ef args m t res, + eval_condition cond rs##args m = Some false -> + step (State s c sp pc rs m) + E0 (State s c sp ifnot rs m) + | exec_Ireturn: + forall s c stk pc rs m or, + c!pc = Some(Ireturn or) -> + step (State s c (Vptr stk Int.zero) pc rs m) + E0 (Returnstate s (regmap_optget or Vundef rs) (Mem.free m stk)) + | exec_function_internal: + forall s f args m m' stk, + Mem.alloc m 0 f.(fn_stacksize) = (m', stk) -> + step (Callstate s (Internal f) args m) + E0 (State s + f.(fn_code) + (Vptr stk Int.zero) + f.(fn_entrypoint) + (init_regs args f.(fn_params)) + m') + | exec_function_external: + forall s ef args res t m, event_match ef args t res -> - exec_function (External ef) args m t res m. - -Scheme exec_instr_ind_3 := Minimality for exec_instr Sort Prop - with exec_instrs_ind_3 := Minimality for exec_instrs Sort Prop - with exec_function_ind_3 := Minimality for exec_function Sort Prop. - -(** Some derived execution rules. *) - -Lemma exec_step: - forall c sp pc1 rs1 m1 t1 pc2 rs2 m2 t2 pc3 rs3 m3 t3, - exec_instr c sp pc1 rs1 m1 t1 pc2 rs2 m2 -> - exec_instrs c sp pc2 rs2 m2 t2 pc3 rs3 m3 -> - t3 = t1 ** t2 -> - exec_instrs c sp pc1 rs1 m1 t3 pc3 rs3 m3. -Proof. - intros. eapply exec_trans. apply exec_one. eauto. eauto. auto. -Qed. + step (Callstate s (External ef) args m) + t (Returnstate s res m) + | exec_return: + forall res c sp pc rs s vres m, + step (Returnstate (Stackframe res c sp pc rs :: s) vres m) + E0 (State s c sp pc (rs#res <- vres) m). Lemma exec_Iop': - forall c sp pc rs m op args res pc' rs' v, + forall s c sp pc rs m op args res pc' rs' v, c!pc = Some(Iop op args res pc') -> - eval_operation ge sp op rs##args = Some v -> + eval_operation ge sp op rs##args m = Some v -> rs' = (rs#res <- v) -> - exec_instr c sp pc rs m E0 pc' rs' m. + step (State s c sp pc rs m) + E0 (State s c sp pc' rs' m). Proof. intros. subst rs'. eapply exec_Iop; eauto. Qed. Lemma exec_Iload': - forall c sp pc rs m chunk addr args dst pc' rs' a v, + forall s c sp pc rs m chunk addr args dst pc' rs' a v, c!pc = Some(Iload chunk addr args dst pc') -> eval_addressing ge sp addr rs##args = Some a -> Mem.loadv chunk m a = Some v -> rs' = (rs#dst <- v) -> - exec_instr c sp pc rs m E0 pc' rs' m. + step (State s c sp pc rs m) + E0 (State s c sp pc' rs' m). Proof. intros. subst rs'. eapply exec_Iload; eauto. Qed. -(** If a transition can take place from [pc], the instruction at [pc] - is defined in the CFG. *) +End RELSEM. -Lemma exec_instr_present: - forall c sp pc rs m t pc' rs' m', - exec_instr c sp pc rs m t pc' rs' m' -> - c!pc <> None. -Proof. - induction 1; congruence. -Qed. +(** Execution of whole programs are described as sequences of transitions + from an initial state to a final state. An initial state is a [Callstate] + corresponding to the invocation of the ``main'' function of the program + without arguments and with an empty call stack. *) -Lemma exec_instrs_present: - forall c sp pc rs m t pc' rs' m', - exec_instrs c sp pc rs m t pc' rs' m' -> - c!pc' <> None -> c!pc <> None. -Proof. - induction 1; intros. - auto. - eapply exec_instr_present; eauto. - eauto. -Qed. +Inductive initial_state (p: program): state -> Prop := + | initial_state_intro: forall b f, + let ge := Genv.globalenv p in + let m0 := Genv.init_mem p in + Genv.find_symbol ge p.(prog_main) = Some b -> + Genv.find_funct_ptr ge b = Some f -> + funsig f = mksignature nil (Some Tint) -> + initial_state p (Callstate nil f nil m0). -End RELSEM. +(** A final state is a [Returnstate] with an empty call stack. *) -(** Execution of whole programs. As in Cminor, we call the ``main'' function - with no arguments and observe its return value. *) +Inductive final_state: state -> int -> Prop := + | final_state_intro: forall r m, + final_state (Returnstate nil (Vint r) m) r. -Definition exec_program (p: program) (t: trace) (r: val) : Prop := - let ge := Genv.globalenv p in - let m0 := Genv.init_mem p in - exists b, exists f, exists m, - Genv.find_symbol ge p.(prog_main) = Some b /\ - Genv.find_funct_ptr ge b = Some f /\ - funsig f = mksignature nil (Some Tint) /\ - exec_function ge f nil m0 t r m. +Definition exec_program (p: program) (beh: program_behavior) : Prop := + program_behaves step (initial_state p) final_state (Genv.globalenv p) beh. (** * Operations on RTL abstract syntax *) @@ -330,21 +325,13 @@ Definition successors (f: function) (pc: node) : list node := | Iload chunk addr args dst s => s :: nil | Istore chunk addr args src s => s :: nil | Icall sig ros args res s => s :: nil + | Itailcall sig ros args => nil | Ialloc arg res s => s :: nil | Icond cond args ifso ifnot => ifso :: ifnot :: nil | Ireturn optarg => nil end end. -Lemma successors_correct: - forall ge f sp pc rs m t pc' rs' m', - exec_instr ge f.(fn_code) sp pc rs m t pc' rs' m' -> - In pc' (successors f pc). -Proof. - intros ge f. unfold successors. generalize (fn_code f). - induction 1; rewrite H; simpl; tauto. -Qed. - (** Transformation of a RTL function instruction by instruction. This applies a given transformation function to all instructions of a function and constructs a transformed function from that. *) diff --git a/backend/RTLbigstep.v b/backend/RTLbigstep.v new file mode 100644 index 00000000..0ad6e68a --- /dev/null +++ b/backend/RTLbigstep.v @@ -0,0 +1,400 @@ +(** An alternate, mixed-step semantics for the RTL intermediate language. *) + +Require Import Coqlib. +Require Import Maps. +Require Import AST. +Require Import Integers. +Require Import Values. +Require Import Events. +Require Import Mem. +Require Import Globalenvs. +Require Import Smallstep. +Require Import Op. +Require Import Registers. +Require Import RTL. + +Section BIGSTEP. + +Variable ge: genv. + +(** The dynamic semantics of RTL is a combination of small-step (transition) + semantics and big-step semantics. Execution of an instruction performs + a single transition to the next instruction (small-step), except if + the instruction is a function call. In this case, the whole body of + the called function is executed at once and the transition terminates + on the instruction immediately following the call in the caller function. + Such ``mixed-step'' semantics is convenient for reasoning over + intra-procedural analyses and transformations. It also dispenses us + from making the call stack explicit in the semantics. + + The semantics is organized in three mutually inductive predicates. + The first is [exec_instr ge c sp pc rs m pc' rs' m']. [ge] is the + global environment (see module [Genv]), [c] the CFG for the current + function, and [sp] the pointer to the stack block for its + current activation (as in Cminor). [pc], [rs] and [m] is the + initial state of the transition: program point (CFG node) [pc], + register state (mapping of pseudo-registers to values) [rs], + and memory state [m]. The final state is [pc'], [rs'] and [m']. *) + +Inductive exec_instr: code -> val -> + node -> regset -> mem -> trace -> + node -> regset -> mem -> Prop := + | exec_Inop: + forall c sp pc rs m pc', + c!pc = Some(Inop pc') -> + exec_instr c sp pc rs m E0 pc' rs m + | exec_Iop: + forall c sp pc rs m op args res pc' v, + c!pc = Some(Iop op args res pc') -> + eval_operation ge sp op rs##args m = Some v -> + exec_instr c sp pc rs m E0 pc' (rs#res <- v) m + | exec_Iload: + forall c sp pc rs m chunk addr args dst pc' a v, + c!pc = Some(Iload chunk addr args dst pc') -> + eval_addressing ge sp addr rs##args = Some a -> + Mem.loadv chunk m a = Some v -> + exec_instr c sp pc rs m E0 pc' (rs#dst <- v) m + | exec_Istore: + forall c sp pc rs m chunk addr args src pc' a m', + c!pc = Some(Istore chunk addr args src pc') -> + eval_addressing ge sp addr rs##args = Some a -> + Mem.storev chunk m a rs#src = Some m' -> + exec_instr c sp pc rs m E0 pc' rs m' + | exec_Icall: + forall c sp pc rs m sig ros args res pc' f vres m' t, + c!pc = Some(Icall sig ros args res pc') -> + find_function ge ros rs = Some f -> + funsig f = sig -> + exec_function f rs##args m t vres m' -> + exec_instr c sp pc rs m t pc' (rs#res <- vres) m' + | exec_Ialloc: + forall c sp pc rs m pc' arg res sz m' b, + c!pc = Some(Ialloc arg res pc') -> + rs#arg = Vint sz -> + Mem.alloc m 0 (Int.signed sz) = (m', b) -> + exec_instr c sp pc rs m E0 pc' (rs#res <- (Vptr b Int.zero)) m' + | exec_Icond_true: + forall c sp pc rs m cond args ifso ifnot, + c!pc = Some(Icond cond args ifso ifnot) -> + eval_condition cond rs##args m = Some true -> + exec_instr c sp pc rs m E0 ifso rs m + | exec_Icond_false: + forall c sp pc rs m cond args ifso ifnot, + c!pc = Some(Icond cond args ifso ifnot) -> + eval_condition cond rs##args m = Some false -> + exec_instr c sp pc rs m E0 ifnot rs m + +(** [exec_body ge c sp pc rs m res m'] repeatedly executes + instructions starting at [pc] in [c], until it + reaches a return or tailcall instruction. It performs + that instruction and sets [res] to the return value + and [m'] to the final memory state. *) + +with exec_body: code -> val -> + node -> regset -> mem -> trace -> + val -> mem -> Prop := + | exec_body_step: forall c sp pc rs m t1 pc1 rs1 m1 t2 t res m2, + exec_instr c sp pc rs m t1 pc1 rs1 m1 -> + exec_body c sp pc1 rs1 m1 t2 res m2 -> + t = t1 ** t2 -> + exec_body c sp pc rs m t res m2 + | exec_Ireturn: forall c stk pc rs m or res, + c!pc = Some(Ireturn or) -> + res = regmap_optget or Vundef rs -> + exec_body c (Vptr stk Int.zero) pc rs m E0 res (Mem.free m stk) + | exec_Itailcall: forall c stk pc rs m sig ros args f t res m', + c!pc = Some(Itailcall sig ros args) -> + find_function ge ros rs = Some f -> + funsig f = sig -> + exec_function f rs##args (Mem.free m stk) t res m' -> + exec_body c (Vptr stk Int.zero) pc rs m t res m' + +(** [exec_function ge f args m res m'] executes a function application. + [f] is the called function, [args] the values of its arguments, + and [m] the memory state at the beginning of the call. [res] is + the returned value: the value of [r] if the function terminates with + a [Ireturn (Some r)], or [Vundef] if it terminates with [Ireturn None]. + Evaluation proceeds by executing transitions from the function's entry + point to the first [Ireturn] instruction encountered. It is preceeded + by the allocation of the stack activation block and the binding + of register parameters to the provided arguments. + (Non-parameter registers are initialized to [Vundef].) Before returning, + the stack activation block is freed. *) + +with exec_function: fundef -> list val -> mem -> trace -> + val -> mem -> Prop := + | exec_funct_internal: + forall f m m1 stk args t m2 vres, + Mem.alloc m 0 f.(fn_stacksize) = (m1, stk) -> + exec_body f.(fn_code) (Vptr stk Int.zero) + f.(fn_entrypoint) (init_regs args f.(fn_params)) m1 + t vres m2 -> + exec_function (Internal f) args m t vres m2 + | exec_funct_external: + forall ef args m t res, + event_match ef args t res -> + exec_function (External ef) args m t res m. + +Scheme exec_instr_ind_3 := Minimality for exec_instr Sort Prop + with exec_body_ind_3 := Minimality for exec_body Sort Prop + with exec_function_ind_3 := Minimality for exec_function Sort Prop. + +(** The reflexive transitive closure of [exec_instr]. *) + +Inductive exec_instrs: code -> val -> + node -> regset -> mem -> trace -> + node -> regset -> mem -> Prop := + | exec_refl: + forall c sp pc rs m, + exec_instrs c sp pc rs m E0 pc rs m + | exec_one: + forall c sp pc rs m t pc' rs' m', + exec_instr c sp pc rs m t pc' rs' m' -> + exec_instrs c sp pc rs m t pc' rs' m' + | exec_trans: + forall c sp pc1 rs1 m1 t1 pc2 rs2 m2 t2 pc3 rs3 m3 t3, + exec_instrs c sp pc1 rs1 m1 t1 pc2 rs2 m2 -> + exec_instrs c sp pc2 rs2 m2 t2 pc3 rs3 m3 -> + t3 = t1 ** t2 -> + exec_instrs c sp pc1 rs1 m1 t3 pc3 rs3 m3. + +(** Some derived execution rules. *) + +Lemma exec_instrs_exec_body: + forall c sp pc1 rs1 m1 t1 pc2 rs2 m2, + exec_instrs c sp pc1 rs1 m1 t1 pc2 rs2 m2 -> + forall res t2 m3 t3, + exec_body c sp pc2 rs2 m2 t2 res m3 -> + t3 = t1 ** t2 -> + exec_body c sp pc1 rs1 m1 t3 res m3. +Proof. + induction 1; intros. + subst t3. rewrite E0_left. auto. + eapply exec_body_step; eauto. + eapply IHexec_instrs1. eapply IHexec_instrs2. eauto. + eauto. traceEq. +Qed. + +Lemma exec_step: + forall c sp pc1 rs1 m1 t1 pc2 rs2 m2 t2 pc3 rs3 m3 t3, + exec_instr c sp pc1 rs1 m1 t1 pc2 rs2 m2 -> + exec_instrs c sp pc2 rs2 m2 t2 pc3 rs3 m3 -> + t3 = t1 ** t2 -> + exec_instrs c sp pc1 rs1 m1 t3 pc3 rs3 m3. +Proof. + intros. eapply exec_trans. apply exec_one. eauto. eauto. auto. +Qed. + +Lemma exec_Iop': + forall c sp pc rs m op args res pc' rs' v, + c!pc = Some(Iop op args res pc') -> + eval_operation ge sp op rs##args m = Some v -> + rs' = (rs#res <- v) -> + exec_instr c sp pc rs m E0 pc' rs' m. +Proof. + intros. subst rs'. eapply exec_Iop; eauto. +Qed. + +Lemma exec_Iload': + forall c sp pc rs m chunk addr args dst pc' rs' a v, + c!pc = Some(Iload chunk addr args dst pc') -> + eval_addressing ge sp addr rs##args = Some a -> + Mem.loadv chunk m a = Some v -> + rs' = (rs#dst <- v) -> + exec_instr c sp pc rs m E0 pc' rs' m. +Proof. + intros. subst rs'. eapply exec_Iload; eauto. +Qed. + +(** Experimental: coinductive big-step semantics for divergence. *) + +CoInductive diverge_body: + code -> val -> node -> regset -> mem -> traceinf -> Prop := + | diverge_step: forall c sp pc rs m t1 pc1 rs1 m1 T2 T, + exec_instr c sp pc rs m t1 pc1 rs1 m1 -> + diverge_body c sp pc1 rs1 m1 T2 -> + T = t1 *** T2 -> + diverge_body c sp pc rs m T + | diverge_Icall: + forall c sp pc rs m sig ros args res pc' f T, + c!pc = Some(Icall sig ros args res pc') -> + find_function ge ros rs = Some f -> + funsig f = sig -> + diverge_function f rs##args m T -> + diverge_body c sp pc rs m T + | diverge_Itailcall: forall c stk pc rs m sig ros args f T, + c!pc = Some(Itailcall sig ros args) -> + find_function ge ros rs = Some f -> + funsig f = sig -> + diverge_function f rs##args (Mem.free m stk) T -> + diverge_body c (Vptr stk Int.zero) pc rs m T + +with diverge_function: fundef -> list val -> mem -> traceinf -> Prop := + | diverge_funct_internal: + forall f m m1 stk args T, + Mem.alloc m 0 f.(fn_stacksize) = (m1, stk) -> + diverge_body f.(fn_code) (Vptr stk Int.zero) + f.(fn_entrypoint) (init_regs args f.(fn_params)) m1 + T -> + diverge_function (Internal f) args m T. + +End BIGSTEP. + +(** Execution of whole programs. *) + +Inductive exec_program (p: program): program_behavior -> Prop := + | exec_program_terminates: forall b f t r m, + let ge := Genv.globalenv p in + let m0 := Genv.init_mem p in + Genv.find_symbol ge p.(prog_main) = Some b -> + Genv.find_funct_ptr ge b = Some f -> + funsig f = mksignature nil (Some Tint) -> + exec_function ge f nil m0 t (Vint r) m -> + exec_program p (Terminates t r) + | exec_program_diverges: forall b f T, + let ge := Genv.globalenv p in + let m0 := Genv.init_mem p in + Genv.find_symbol ge p.(prog_main) = Some b -> + Genv.find_funct_ptr ge b = Some f -> + funsig f = mksignature nil (Some Tint) -> + diverge_function ge f nil m0 T -> + exec_program p (Diverges T). + +(** * Equivalence with the transition semantics. *) + +Section EQUIVALENCE. + +Variable ge: genv. + +Definition exec_instr_prop + (c: code) (sp: val) (pc1: node) (rs1: regset) (m1: mem) + (t: trace) (pc2: node) (rs2: regset) (m2: mem) : Prop := + forall s, + plus step ge (State s c sp pc1 rs1 m1) + t (State s c sp pc2 rs2 m2). + +Definition exec_body_prop + (c: code) (sp: val) (pc1: node) (rs1: regset) (m1: mem) + (t: trace) (res: val) (m2: mem) : Prop := + forall s, + plus step ge (State s c sp pc1 rs1 m1) + t (Returnstate s res m2). + +Definition exec_function_prop + (f: fundef) (args: list val) (m1: mem) + (t: trace) (res: val) (m2: mem) : Prop := + forall s, + plus step ge (Callstate s f args m1) + t (Returnstate s res m2). + +Lemma exec_steps: + (forall c sp pc1 rs1 m1 t pc2 rs2 m2, + exec_instr ge c sp pc1 rs1 m1 t pc2 rs2 m2 -> + exec_instr_prop c sp pc1 rs1 m1 t pc2 rs2 m2) /\ + (forall c sp pc1 rs1 m1 t res m2, + exec_body ge c sp pc1 rs1 m1 t res m2 -> + exec_body_prop c sp pc1 rs1 m1 t res m2) /\ + (forall f args m1 t res m2, + exec_function ge f args m1 t res m2 -> + exec_function_prop f args m1 t res m2). +Proof. + set (IND := fun a b c d e f g h i j k l m => + conj (exec_instr_ind_3 ge exec_instr_prop exec_body_prop exec_function_prop a b c d e f g h i j k l m) + (conj (exec_body_ind_3 ge exec_instr_prop exec_body_prop exec_function_prop a b c d e f g h i j k l m) + (exec_function_ind_3 ge exec_instr_prop exec_body_prop exec_function_prop a b c d e f g h i j k l m))). + apply IND; clear IND; + intros; red; intros. + (* nop *) + apply plus_one. eapply RTL.exec_Inop; eauto. + (* op *) + apply plus_one. eapply RTL.exec_Iop'; eauto. + (* load *) + apply plus_one. eapply RTL.exec_Iload'; eauto. + (* store *) + apply plus_one. eapply RTL.exec_Istore; eauto. + (* call *) + eapply plus_left'. eapply RTL.exec_Icall; eauto. + eapply plus_right'. apply H3. apply RTL.exec_return. + eauto. traceEq. + (* alloc *) + apply plus_one. eapply RTL.exec_Ialloc; eauto. + (* cond true *) + apply plus_one. eapply RTL.exec_Icond_true; eauto. + (* cond false *) + apply plus_one. eapply RTL.exec_Icond_false; eauto. + (* body step *) + eapply plus_trans. apply H0. apply H2. auto. + (* body return *) + apply plus_one. rewrite H0. eapply RTL.exec_Ireturn; eauto. + (* body tailcall *) + eapply plus_left'. eapply RTL.exec_Itailcall; eauto. + apply H3. traceEq. + (* internal function *) + eapply plus_left'. eapply RTL.exec_function_internal; eauto. + apply H1. traceEq. + (* external function *) + apply plus_one. eapply RTL.exec_function_external; eauto. +Qed. + +Lemma diverge_function_steps: + forall fd args m T s, + diverge_function ge fd args m T -> + forever step ge (Callstate s fd args m) T. +Proof. + assert (diverge_function_steps': + forall fd args m T s, + diverge_function ge fd args m T -> + forever_N step ge O (Callstate s fd args m) T). + cofix COINDHYP1. + assert (diverge_body_steps: forall c sp pc rs m T s, + diverge_body ge c sp pc rs m T -> + forever_N step ge O (State s c sp pc rs m) T). + cofix COINDHYP2; intros. + inv H. + (* step *) + apply forever_N_plus with (State s c sp pc1 rs1 m1) O. + destruct exec_steps as [E [F G]]. + apply E. assumption. + apply COINDHYP2. assumption. + (* call *) + change T with (E0 *** T). + apply forever_N_plus with (Callstate (Stackframe res c sp pc' rs :: s) + f rs##args m) O. + apply plus_one. eapply RTL.exec_Icall; eauto. + apply COINDHYP1. assumption. + (* tailcall *) + change T with (E0 *** T). + apply forever_N_plus with (Callstate s f rs##args (free m stk)) O. + apply plus_one. eapply RTL.exec_Itailcall; eauto. + apply COINDHYP1. assumption. + (* internal function *) + intros. inv H. + change T with (E0 *** T). + apply forever_N_plus with + (State s f.(fn_code) (Vptr stk Int.zero) + f.(fn_entrypoint) (init_regs args f.(fn_params)) m1) O. + apply plus_one. eapply RTL.exec_function_internal; eauto. + apply diverge_body_steps. assumption. + (* conclusion *) + intros. eapply forever_N_forever. eauto. +Qed. + +End EQUIVALENCE. + +Theorem exec_program_bigstep_smallstep: + forall p beh, + exec_program p beh -> + RTL.exec_program p beh. +Proof. + intros. unfold RTL.exec_program. inv H. + econstructor. + econstructor; eauto. + apply plus_star. + destruct (exec_steps (Genv.globalenv p)) as [E [F G]]. + apply (G _ _ _ _ _ _ H3). + constructor. + econstructor. + econstructor; eauto. + apply diverge_function_steps. auto. +Qed. + diff --git a/backend/RTLgen.v b/backend/RTLgen.v index b38964d2..117631ef 100644 --- a/backend/RTLgen.v +++ b/backend/RTLgen.v @@ -1,21 +1,25 @@ -(** Translation from Cminor to RTL. *) +(** Translation from CminorSel to RTL. *) Require Import Coqlib. +Require Errors. Require Import Maps. Require Import AST. Require Import Integers. Require Import Values. +Require Import Switch. Require Import Op. Require Import Registers. -Require Import Cminor. +Require Import CminorSel. Require Import RTL. +Open Local Scope string_scope. + (** * Translation environments and state *) (** The translation functions are parameterized by the following - compile-time environment, which maps Cminor local variables and + compile-time environment, which maps CminorSel local variables and let-bound variables to RTL registers. The mapping for local variables - is computed from the Cminor variable declarations at the beginning of + is computed from the CminorSel variable declarations at the beginning of the translation of a function, and does not change afterwards. The mapping for let-bound variables is initially empty and updated during translation of expressions, when crossing a [Elet] binding. *) @@ -46,9 +50,10 @@ Record state: Set := mkstate { to modify the global state. These luxuries are not available in Coq, however. Instead, we use a monadic encoding of the translation: translation functions take the current global state as argument, - and return either [Error] to denote an error, or [OK r s] to denote + and return either [Error msg] to denote an error, or [OK r s] to denote success. [s] is the modified state, and [r] the result value of the - translation function. + translation function. In the error case, [msg] is an error message + (see modules [Errors]) describing the problem. We now define this monadic encoding -- the ``state and error'' monad -- as well as convenient syntax to express monadic computations. *) @@ -56,19 +61,19 @@ Record state: Set := mkstate { Set Implicit Arguments. Inductive res (A: Set) : Set := - | Error: res A + | Error: Errors.errmsg -> res A | OK: A -> state -> res A. Definition mon (A: Set) : Set := state -> res A. Definition ret (A: Set) (x: A) : mon A := fun (s: state) => OK x s. -Definition error (A: Set) : mon A := fun (s: state) => Error A. +Definition error (A: Set) (msg: Errors.errmsg) : mon A := fun (s: state) => Error A msg. Definition bind (A B: Set) (f: mon A) (g: A -> mon B) : mon B := fun (s: state) => match f s with - | Error => Error B + | Error msg => Error B msg | OK a s' => g a s' end. @@ -155,7 +160,7 @@ Definition update_instr (n: node) (i: instruction) : mon unit := (PTree.set n i s.(st_code)) (@update_instr_wf s n i PEQ)) | right _ => - Error unit + Error unit (Errors.msg "RTLgen.update_instr") end. (** Generate a fresh RTL register. *) @@ -188,7 +193,7 @@ Fixpoint add_vars (map: mapping) (names: list ident) Definition find_var (map: mapping) (name: ident) : mon reg := match PTree.get name map.(map_vars) with - | None => error reg + | None => error reg (Errors.MSG "RTLgen: unbound variable " :: Errors.CTX name :: nil) | Some r => ret r end. @@ -197,7 +202,7 @@ Definition add_letvar (map: mapping) (r: reg) : mapping := Definition find_letvar (map: mapping) (idx: nat) : mon reg := match List.nth_error map.(map_letvars) idx with - | None => error reg + | None => error reg (Errors.msg "RTLgen: unbound let variable") | Some r => ret r end. @@ -227,8 +232,8 @@ Fixpoint alloc_regs (map: mapping) (al: exprlist) | Enil => ret nil | Econs a bl => - do rl <- alloc_regs map bl; do r <- alloc_reg map a; + do rl <- alloc_regs map bl; ret (r :: rl) end. @@ -241,9 +246,9 @@ Definition add_move (rs rd: reg) (nd: node) : mon node := then ret nd else add_instr (Iop Omove (rs::nil) rd nd). -(** Translation of an expression. [transl_expr map mut a rd nd] +(** Translation of an expression. [transl_expr map a rd nd] enriches the current CFG with the RTL instructions necessary - to compute the value of Cminor expression [a], leave its result + to compute the value of CminorSel expression [a], leave its result in register [rd], and branch to node [nd]. It returns the node of the first instruction in this sequence. [map] is the compile-time translation environment. *) @@ -311,7 +316,7 @@ with transl_condition (map: mapping) (a: condexpr) (ntrue nfalse: node) end (** Translation of a list of expressions. The expressions are evaluated - left-to-right, and their values left in the given list of registers. *) + left-to-right, and their values stored in the given list of registers. *) with transl_exprlist (map: mapping) (al: exprlist) (rl: list reg) (nd: node) {struct al} : mon node := @@ -321,7 +326,7 @@ with transl_exprlist (map: mapping) (al: exprlist) (rl: list reg) (nd: node) | Econs b bs, r :: rs => do no <- transl_exprlist map bs rs nd; transl_expr map b r no | _, _ => - error node + error node (Errors.msg "RTLgen.transl_exprlist") end. (** Auxiliary for branch prediction. When compiling an if/then/else @@ -336,27 +341,32 @@ Parameter more_likely: condexpr -> stmt -> stmt -> bool. (** Auxiliary for translating [Sswitch] statements. *) +Parameter compile_switch: nat -> table -> comptree. + Definition transl_exit (nexits: list node) (n: nat) : mon node := match nth_error nexits n with - | None => error node + | None => error node (Errors.msg "RTLgen: wrong exit") | Some ne => ret ne end. -Fixpoint transl_switch (r: reg) (nexits: list node) - (cases: list (int * nat)) (default: nat) - {struct cases} : mon node := - match cases with - | nil => - transl_exit nexits default - | (key1, exit1) :: cases' => - do ncont <- transl_switch r nexits cases' default; - do nfound <- transl_exit nexits exit1; - add_instr (Icond (Ccompimm Ceq key1) (r :: nil) nfound ncont) +Fixpoint transl_switch (r: reg) (nexits: list node) (t: comptree) + {struct t} : mon node := + match t with + | CTaction act => + transl_exit nexits act + | CTifeq key act t' => + do ncont <- transl_switch r nexits t'; + do nfound <- transl_exit nexits act; + add_instr (Icond (Ccompimm Ceq key) (r :: nil) nfound ncont) + | CTiflt key t1 t2 => + do n2 <- transl_switch r nexits t2; + do n1 <- transl_switch r nexits t1; + add_instr (Icond (Ccompuimm Clt key) (r :: nil) n1 n2) end. (** Translation of statements. [transl_stmt map s nd nexits nret rret] enriches the current CFG with the RTL instructions necessary to - execute the Cminor statement [s], and returns the node of the first + execute the CminorSel statement [s], and returns the node of the first instruction in this sequence. The generated instructions continue at node [nd] if the statement terminates normally, at node [nret] if it terminates by early return, and at the [n]-th node in the list @@ -398,18 +408,28 @@ Fixpoint transl_stmt (map: mapping) (s: stmt) (nd: node) | Sexit n => transl_exit nexits n | Sswitch a cases default => - do r <- alloc_reg map a; - do ns <- transl_switch r nexits cases default; - transl_expr map a r ns + let t := compile_switch default cases in + if validate_switch default cases t then + (do r <- alloc_reg map a; + do ns <- transl_switch r nexits t; + transl_expr map a r ns) + else + error node (Errors.msg "RTLgen: wrong switch") | Sreturn opt_a => match opt_a, rret with | None, None => ret nret | Some a, Some r => transl_expr map a r nret - | _, _ => error node + | _, _ => error node (Errors.msg "RTLgen: type mismatch on return") end + | Stailcall sig b cl => + do rf <- alloc_reg map b; + do rargs <- alloc_regs map cl; + do n1 <- add_instr (Itailcall sig (inl _ rf) rargs); + do n2 <- transl_exprlist map cl rargs n1; + transl_expr map b rf n2 end. -(** Translation of a Cminor function. *) +(** Translation of a CminorSel function. *) Definition ret_reg (sig: signature) (rd: reg) : option reg := match sig.(sig_res) with @@ -417,32 +437,32 @@ Definition ret_reg (sig: signature) (rd: reg) : option reg := | Some ty => Some rd end. -Definition transl_fun (f: Cminor.function) : mon (node * list reg) := - do (rparams, map1) <- add_vars init_mapping f.(Cminor.fn_params); - do (rvars, map2) <- add_vars map1 f.(Cminor.fn_vars); +Definition transl_fun (f: CminorSel.function) : mon (node * list reg) := + do (rparams, map1) <- add_vars init_mapping f.(CminorSel.fn_params); + do (rvars, map2) <- add_vars map1 f.(CminorSel.fn_vars); do rret <- new_reg; - let orret := ret_reg f.(Cminor.fn_sig) rret in + let orret := ret_reg f.(CminorSel.fn_sig) rret in do nret <- add_instr (Ireturn orret); - do nentry <- transl_stmt map2 f.(Cminor.fn_body) nret nil nret orret; + do nentry <- transl_stmt map2 f.(CminorSel.fn_body) nret nil nret orret; ret (nentry, rparams). -Definition transl_function (f: Cminor.function) : option RTL.function := +Definition transl_function (f: CminorSel.function) : Errors.res RTL.function := match transl_fun f init_state with - | Error => None + | Error msg => Errors.Error msg | OK (nentry, rparams) s => - Some (RTL.mkfunction - f.(Cminor.fn_sig) - rparams - f.(Cminor.fn_stackspace) - s.(st_code) - nentry - s.(st_nextnode) - s.(st_wf)) + Errors.OK (RTL.mkfunction + f.(CminorSel.fn_sig) + rparams + f.(CminorSel.fn_stackspace) + s.(st_code) + nentry + s.(st_nextnode) + s.(st_wf)) end. Definition transl_fundef := transf_partial_fundef transl_function. (** Translation of a whole program. *) -Definition transl_program (p: Cminor.program) : option RTL.program := +Definition transl_program (p: CminorSel.program) : Errors.res RTL.program := transform_partial_program transl_fundef p. diff --git a/backend/RTLgenproof.v b/backend/RTLgenproof.v index 2ce961bc..15f305a8 100644 --- a/backend/RTLgenproof.v +++ b/backend/RTLgenproof.v @@ -1,4 +1,4 @@ -(** Correctness proof for RTL generation: main proof. *) +(** Correctness proof for RTL generation. *) Require Import Coqlib. Require Import Maps. @@ -7,144 +7,411 @@ Require Import Integers. Require Import Values. Require Import Mem. Require Import Events. +Require Import Smallstep. Require Import Globalenvs. -Require Import Op. +Require Import Switch. Require Import Registers. Require Import Cminor. +Require Import Op. +Require Import CminorSel. Require Import RTL. Require Import RTLgen. -Require Import RTLgenproof1. +Require Import RTLgenspec. + +(** * Correspondence between Cminor environments and RTL register sets *) + +(** A compilation environment (mapping) is well-formed if + the following properties hold: +- Two distinct Cminor local variables are mapped to distinct pseudo-registers. +- A Cminor local variable and a let-bound variable are mapped to + distinct pseudo-registers. +*) + +Record map_wf (m: mapping) : Prop := + mk_map_wf { + map_wf_inj: + (forall id1 id2 r, + m.(map_vars)!id1 = Some r -> m.(map_vars)!id2 = Some r -> id1 = id2); + map_wf_disj: + (forall id r, + m.(map_vars)!id = Some r -> In r m.(map_letvars) -> False) + }. + +Lemma init_mapping_wf: + map_wf init_mapping. +Proof. + unfold init_mapping; split; simpl. + intros until r. rewrite PTree.gempty. congruence. + tauto. +Qed. + +Lemma add_var_wf: + forall s1 s2 map name r map', + add_var map name s1 = OK (r,map') s2 -> + map_wf map -> map_valid map s1 -> map_wf map'. +Proof. + intros. monadInv H. + apply mk_map_wf; simpl. + intros until r0. repeat rewrite PTree.gsspec. + destruct (peq id1 name); destruct (peq id2 name). + congruence. + intros. inv H. elimtype False. + apply valid_fresh_absurd with r0 s1. + apply H1. left; exists id2; auto. + eauto with rtlg. + intros. inv H2. elimtype False. + apply valid_fresh_absurd with r0 s1. + apply H1. left; exists id1; auto. + eauto with rtlg. + inv H0. eauto. + intros until r0. rewrite PTree.gsspec. + destruct (peq id name). + intros. inv H. + apply valid_fresh_absurd with r0 s1. + apply H1. right; auto. + eauto with rtlg. + inv H0; eauto. +Qed. + +Lemma add_vars_wf: + forall names s1 s2 map map' rl, + add_vars map names s1 = OK (rl,map') s2 -> + map_wf map -> map_valid map s1 -> map_wf map'. +Proof. + induction names; simpl; intros; monadInv H. + auto. + exploit add_vars_valid; eauto. intros [A B]. + eapply add_var_wf; eauto. +Qed. + +Lemma add_letvar_wf: + forall map r, + map_wf map -> ~reg_in_map map r -> map_wf (add_letvar map r). +Proof. + intros. inv H. unfold add_letvar; constructor; simpl. + auto. + intros. elim H1; intro. subst r0. elim H0. left; exists id; auto. + eauto. +Qed. + +(** An RTL register environment matches a Cminor local environment and + let-environment if the value of every local or let-bound variable in + the Cminor environments is identical to the value of the + corresponding pseudo-register in the RTL register environment. *) + +Record match_env + (map: mapping) (e: Cminor.env) (le: Cminor.letenv) (rs: regset) : Prop := + mk_match_env { + me_vars: + (forall id v, + e!id = Some v -> exists r, map.(map_vars)!id = Some r /\ rs#r = v); + me_letvars: + rs##(map.(map_letvars)) = le + }. + +Lemma match_env_find_var: + forall map e le rs id v r, + match_env map e le rs -> + e!id = Some v -> + map.(map_vars)!id = Some r -> + rs#r = v. +Proof. + intros. exploit me_vars; eauto. intros [r' [EQ' RS]]. + replace r with r'. auto. congruence. +Qed. + +Lemma match_env_find_letvar: + forall map e le rs idx v r, + match_env map e le rs -> + List.nth_error le idx = Some v -> + List.nth_error map.(map_letvars) idx = Some r -> + rs#r = v. +Proof. + intros. exploit me_letvars; eauto. intros. + rewrite <- H2 in H0. rewrite list_map_nth in H0. + change reg with positive in H1. rewrite H1 in H0. + simpl in H0. congruence. +Qed. + +Lemma match_env_invariant: + forall map e le rs rs', + match_env map e le rs -> + (forall r, (reg_in_map map r) -> rs'#r = rs#r) -> + match_env map e le rs'. +Proof. + intros. inversion H. apply mk_match_env. + intros. exploit me_vars0; eauto. intros [r [A B]]. + exists r; split. auto. rewrite H0; auto. left; exists id; auto. + rewrite <- me_letvars0. apply list_map_exten. intros. + symmetry. apply H0. right; auto. +Qed. + +(** Matching between environments is preserved when an unmapped register + (not corresponding to any Cminor variable) is assigned in the RTL + execution. *) + +Lemma match_env_update_temp: + forall map e le rs r v, + match_env map e le rs -> + ~(reg_in_map map r) -> + match_env map e le (rs#r <- v). +Proof. + intros. apply match_env_invariant with rs; auto. + intros. case (Reg.eq r r0); intro. + subst r0; contradiction. + apply Regmap.gso; auto. +Qed. +Hint Resolve match_env_update_temp: rtlg. + +(** Matching between environments is preserved by simultaneous + assignment to a Cminor local variable (in the Cminor environments) + and to the corresponding RTL pseudo-register (in the RTL register + environment). *) + +Lemma match_env_update_var: + forall map e le rs id r v, + map_wf map -> + map.(map_vars)!id = Some r -> + match_env map e le rs -> + match_env map (PTree.set id v e) le (rs#r <- v). +Proof. + intros. inversion H. inversion H1. apply mk_match_env. + intros id' v'. rewrite PTree.gsspec. destruct (peq id' id); intros. + subst id'. inv H2. exists r; split. auto. apply PMap.gss. + exploit me_vars0; eauto. intros [r' [A B]]. + exists r'; split. auto. rewrite PMap.gso; auto. + red; intros. subst r'. elim n. eauto. + rewrite <- me_letvars0. apply list_map_exten; intros. + symmetry. apply PMap.gso. red; intros. subst x. eauto. +Qed. + +Lemma match_env_bind_letvar: + forall map e le rs r v, + match_env map e le rs -> + rs#r = v -> + match_env (add_letvar map r) e (v :: le) rs. +Proof. + intros. inv H. unfold add_letvar. apply mk_match_env; simpl; auto. +Qed. + +Lemma match_env_unbind_letvar: + forall map e le rs r v, + match_env (add_letvar map r) e (v :: le) rs -> + match_env map e le rs. +Proof. + unfold add_letvar; intros. inv H. simpl in *. + constructor. auto. congruence. +Qed. + +Lemma match_env_empty: + forall map, + map.(map_letvars) = nil -> + match_env map (PTree.empty val) nil (Regmap.init Vundef). +Proof. + intros. apply mk_match_env. + intros. rewrite PTree.gempty in H0. discriminate. + rewrite H. reflexivity. +Qed. + +(** The assignment of function arguments to local variables (on the Cminor + side) and pseudo-registers (on the RTL side) preserves matching + between environments. *) + +Lemma match_set_params_init_regs: + forall il rl s1 map2 s2 vl, + add_vars init_mapping il s1 = OK (rl, map2) s2 -> + match_env map2 (set_params vl il) nil (init_regs vl rl) + /\ (forall r, reg_fresh r s2 -> (init_regs vl rl)#r = Vundef). +Proof. + induction il; intros. + + inv H. split. apply match_env_empty. auto. intros. + simpl. apply Regmap.gi. + + monadInv H. simpl. + exploit add_vars_valid; eauto. apply init_mapping_valid. intros [A B]. + exploit add_var_valid; eauto. intros [A' B']. clear B'. + monadInv EQ1. + destruct vl as [ | v1 vs]. + (* vl = nil *) + destruct (IHil _ _ _ _ nil EQ) as [ME UNDEF]. inv ME. split. + constructor; simpl. + intros id v. repeat rewrite PTree.gsspec. destruct (peq id a); intros. + subst a. inv H. exists x1; split. auto. apply Regmap.gi. + replace (init_regs nil x) with (Regmap.init Vundef) in me_vars0. eauto. + destruct x; reflexivity. + destruct (map_letvars x0). auto. simpl in me_letvars0. congruence. + intros. apply Regmap.gi. + (* vl = v1 :: vs *) + destruct (IHil _ _ _ _ vs EQ) as [ME UNDEF]. inv ME. split. + constructor; simpl. + intros id v. repeat rewrite PTree.gsspec. destruct (peq id a); intros. + subst a. inv H. exists x1; split. auto. apply Regmap.gss. + exploit me_vars0; eauto. intros [r' [C D]]. + exists r'; split. auto. rewrite Regmap.gso. auto. + apply valid_fresh_different with s. + apply B. left; exists id; auto. + eauto with rtlg. + destruct (map_letvars x0). auto. simpl in me_letvars0. congruence. + intros. rewrite Regmap.gso. apply UNDEF. + apply reg_fresh_decr with s2; eauto with rtlg. + apply sym_not_equal. apply valid_fresh_different with s2; auto. +Qed. + +Lemma match_set_locals: + forall map1 s1, + map_wf map1 -> + forall il rl map2 s2 e le rs, + match_env map1 e le rs -> + (forall r, reg_fresh r s1 -> rs#r = Vundef) -> + add_vars map1 il s1 = OK (rl, map2) s2 -> + match_env map2 (set_locals il e) le rs. +Proof. + induction il; simpl in *; intros. + + inv H2. auto. + + monadInv H2. + exploit IHil; eauto. intro. + monadInv EQ1. + constructor. + intros id v. simpl. repeat rewrite PTree.gsspec. + destruct (peq id a). subst a. intro. + exists x1. split. auto. inv H3. + apply H1. apply reg_fresh_decr with s. + eapply add_vars_incr; eauto. + eauto with rtlg. + intros. eapply me_vars; eauto. + simpl. eapply me_letvars; eauto. +Qed. + +Lemma match_init_env_init_reg: + forall params s0 rparams map1 s1 vars rvars map2 s2 vparams, + add_vars init_mapping params s0 = OK (rparams, map1) s1 -> + add_vars map1 vars s1 = OK (rvars, map2) s2 -> + match_env map2 (set_locals vars (set_params vparams params)) + nil (init_regs vparams rparams). +Proof. + intros. + exploit match_set_params_init_regs; eauto. intros [A B]. + eapply match_set_locals; eauto. + eapply add_vars_wf; eauto. apply init_mapping_wf. + apply init_mapping_valid. +Qed. + +(** * The simulation argument *) + +Require Import Errors. Section CORRECTNESS. -Variable prog: Cminor.program. +Variable prog: CminorSel.program. Variable tprog: RTL.program. -Hypothesis TRANSL: transl_program prog = Some tprog. +Hypothesis TRANSL: transl_program prog = OK tprog. -Let ge : Cminor.genv := Genv.globalenv prog. +Let ge : CminorSel.genv := Genv.globalenv prog. Let tge : RTL.genv := Genv.globalenv tprog. (** Relationship between the global environments for the original - Cminor program and the generated RTL program. *) + CminorSel program and the generated RTL program. *) 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 transl_fundef. - exact TRANSL. -Qed. +Proof + (Genv.find_symbol_transf_partial transl_fundef _ TRANSL). Lemma function_ptr_translated: - forall (b: block) (f: Cminor.fundef), + forall (b: block) (f: CminorSel.fundef), Genv.find_funct_ptr ge b = Some f -> exists tf, - Genv.find_funct_ptr tge b = Some tf /\ transl_fundef f = Some tf. -Proof. - intros. - generalize - (Genv.find_funct_ptr_transf_partial transl_fundef TRANSL H). - case (transl_fundef f). - intros tf [A B]. exists tf. tauto. - intros [A B]. elim B. reflexivity. -Qed. + Genv.find_funct_ptr tge b = Some tf /\ transl_fundef f = OK tf. +Proof + (Genv.find_funct_ptr_transf_partial transl_fundef TRANSL). Lemma functions_translated: - forall (v: val) (f: Cminor.fundef), + forall (v: val) (f: CminorSel.fundef), Genv.find_funct ge v = Some f -> exists tf, - Genv.find_funct tge v = Some tf /\ transl_fundef f = Some tf. -Proof. - intros. - generalize - (Genv.find_funct_transf_partial transl_fundef TRANSL H). - case (transl_fundef f). - intros tf [A B]. exists tf. tauto. - intros [A B]. elim B. reflexivity. -Qed. + Genv.find_funct tge v = Some tf /\ transl_fundef f = OK tf. +Proof + (Genv.find_funct_transf_partial transl_fundef TRANSL). Lemma sig_transl_function: - forall (f: Cminor.fundef) (tf: RTL.fundef), - transl_fundef f = Some tf -> - RTL.funsig tf = Cminor.funsig f. + forall (f: CminorSel.fundef) (tf: RTL.fundef), + transl_fundef f = OK tf -> + RTL.funsig tf = CminorSel.funsig f. Proof. intros until tf. unfold transl_fundef, transf_partial_fundef. case f; intro. unfold transl_function. - case (transl_fun f0 init_state); intros. + case (transl_fun f0 init_state); simpl; intros. discriminate. - destruct p. inversion H. reflexivity. + destruct p. simpl in H. inversion H. reflexivity. intro. inversion H. reflexivity. Qed. (** Correctness of the code generated by [add_move]. *) -Lemma add_move_correct: - forall r1 r2 sp nd s ns s' rs m, - add_move r1 r2 nd s = OK ns s' -> +Lemma tr_move_correct: + forall r1 ns r2 nd cs code sp rs m, + tr_move code ns r1 nd r2 -> exists rs', - exec_instrs tge s'.(st_code) sp ns rs m E0 nd rs' m /\ + star step tge (State cs code sp ns rs m) E0 (State cs code sp nd rs' m) /\ rs'#r2 = rs#r1 /\ (forall r, r <> r2 -> rs'#r = rs#r). Proof. - intros until m. - unfold add_move. case (Reg.eq r1 r2); intro. - monadSimpl. subst s'; subst r2; subst ns. - exists rs. split. apply exec_refl. split. auto. auto. - intro. exists (rs#r2 <- (rs#r1)). - split. apply exec_one. eapply exec_Iop. eauto with rtlg. - reflexivity. - split. apply Regmap.gss. - intros. apply Regmap.gso; auto. + intros. inv H. + exists rs; split. constructor. auto. + exists (rs#r2 <- (rs#r1)); split. + apply star_one. eapply exec_Iop. eauto. auto. + split. apply Regmap.gss. intros; apply Regmap.gso; auto. Qed. (** The proof of semantic preservation for the translation of expressions is a simulation argument based on diagrams of the following form: << I /\ P - e, m, a ------------- ns, rs, m + e, le, m, a ------------- State cs code sp ns rs m || | - || |* + t|| t|* || | \/ v - e', m', v ----------- nd, rs', m' + e, le, m', v ------------ State cs code sp nd rs' m' I /\ Q >> - where [transl_expr map mut a rd nd s = OK ns s']. + where [tr_expr code map pr a ns nd rd] is assumed to hold. The left vertical arrow represents an evaluation of the expression [a] - (assumption). The right vertical arrow represents the execution of - zero, one or several instructions in the generated RTL flow graph - found in the final state [s'] (conclusion). + to value [v]. + The right vertical arrow represents the execution of zero, one or + several instructions in the generated RTL flow graph [code]. - The invariant [I] is the agreement between Cminor environments and - RTL register environment, as captured by [match_envs]. + The invariant [I] is the agreement between CminorSel environments + [e], [le] and the RTL register environment [rs], + as captured by [match_envs]. - The preconditions [P] include the well-formedness of the compilation - environment [mut] and the validity of [rd] as a target register. + The precondition [P] is the well-formedness of the compilation + environment [mut]. The postconditions [Q] state that in the final register environment - [rs'], register [rd] contains value [v], and most other registers - valid in [s] are unchanged w.r.t. the initial register environment - [rs]. (See below for a precise specification of ``most other - registers''.) + [rs'], register [rd] contains value [v], and the registers in + the set of preserved registers [pr] are unchanged, as are the registers + in the codomain of [map]. We formalize this simulation property by the following predicate - parameterized by the Cminor evaluation (left arrow). *) + parameterized by the CminorSel evaluation (left arrow). *) Definition transl_expr_correct (sp: val) (le: letenv) (e: env) (m: mem) (a: expr) (t: trace) (m': mem) (v: val) : Prop := - forall map rd nd s ns s' rs - (MWF: map_wf map s) - (TE: transl_expr map a rd nd s = OK ns s') - (ME: match_env map e le rs) - (TRG: target_reg_ok s map a rd), + forall cs code map pr ns nd rd rs + (MWF: map_wf map) + (TE: tr_expr code map pr a ns nd rd) + (ME: match_env map e le rs), exists rs', - exec_instrs tge s'.(st_code) sp ns rs m t nd rs' m' + star step tge (State cs code sp ns rs m) t (State cs code sp nd rs' m') /\ match_env map e le rs' /\ rs'#rd = v - /\ (forall r, - reg_valid r s -> reg_in_map map r \/ r <> rd -> rs'#r = rs#r). + /\ (forall r, reg_in_map map r \/ In r pr -> rs'#r = rs#r). (** The simulation properties for lists of expressions and for conditional expressions are similar. *) @@ -152,122 +419,113 @@ Definition transl_expr_correct Definition transl_exprlist_correct (sp: val) (le: letenv) (e: env) (m: mem) (al: exprlist) (t: trace) (m': mem) (vl: list val) : Prop := - forall map rl nd s ns s' rs - (MWF: map_wf map s) - (TE: transl_exprlist map al rl nd s = OK ns s') - (ME: match_env map e le rs) - (TRG: target_regs_ok s map al rl), + forall cs code map pr ns nd rl rs + (MWF: map_wf map) + (TE: tr_exprlist code map pr al ns nd rl) + (ME: match_env map e le rs), exists rs', - exec_instrs tge s'.(st_code) sp ns rs m t nd rs' m' + star step tge (State cs code sp ns rs m) t (State cs code sp nd rs' m') /\ match_env map e le rs' /\ rs'##rl = vl - /\ (forall r, - reg_valid r s -> reg_in_map map r \/ ~(In r rl) -> rs'#r = rs#r). + /\ (forall r, reg_in_map map r \/ In r pr -> rs'#r = rs#r). Definition transl_condition_correct (sp: val) (le: letenv) (e: env) (m: mem) (a: condexpr) (t: trace) (m': mem) (vb: bool) : Prop := - forall map ntrue nfalse s ns s' rs - (MWF: map_wf map s) - (TE: transl_condition map a ntrue nfalse s = OK ns s') + forall cs code map pr ns ntrue nfalse rs + (MWF: map_wf map) + (TE: tr_condition code map pr a ns ntrue nfalse) (ME: match_env map e le rs), exists rs', - exec_instrs tge s'.(st_code) sp ns rs m t (if vb then ntrue else nfalse) rs' m' + star step tge (State cs code sp ns rs m) t + (State cs code sp (if vb then ntrue else nfalse) rs' m') /\ match_env map e le rs' - /\ (forall r, reg_valid r s -> rs'#r = rs#r). - -(** For statements, we define the following auxiliary predicates - relating the outcome of the Cminor execution with the final node - and value of the return register in the RTL execution. *) - -Definition outcome_node - (out: outcome) - (ncont: node) (nexits: list node) (nret: node) (nd: node) : Prop := - match out with - | Out_normal => ncont = nd - | Out_exit n => nth_error nexits n = Some nd - | Out_return _ => nret = nd - end. - -Definition match_return_reg - (rs: regset) (rret: option reg) (v: val) : Prop := - match rret with - | None => True - | Some r => rs#r = v - end. - -Definition match_return_outcome - (out: outcome) (rret: option reg) (rs: regset) : Prop := - match out with - | Out_normal => True - | Out_exit n => True - | Out_return optv => - match rret, optv with - | None, None => True - | Some r, Some v => rs#r = v - | _, _ => False - end - end. + /\ (forall r, reg_in_map map r \/ In r pr -> rs'#r = rs#r). + (** The simulation diagram for the translation of statements is of the following form: << I /\ P - e, m, a ------------- ns, rs, m + e, m, a -------------- State cs code sp ns rs m || | - || |* + t|| t|* || | \/ v - e', m', out --------- nd, rs', m' + e', m', out -------------- st' I /\ Q >> - where [transl_stmt map a ncont nexits nret rret s = OK ns s']. + where [tr_stmt code map a ns ncont nexits nret rret] holds. The left vertical arrow represents an execution of the statement [a] - (assumption). The right vertical arrow represents the execution of - zero, one or several instructions in the generated RTL flow graph - found in the final state [s'] (conclusion). + with outcome [out]. + The right vertical arrow represents the execution of + zero, one or several instructions in the generated RTL flow graph [code]. - The invariant [I] is the agreement between Cminor environments and + The invariant [I] is the agreement between CminorSel environments and RTL register environment, as captured by [match_envs]. - The preconditions [P] include the well-formedness of the compilation - environment [mut] and the agreement between the outcome [out] - and the end node [nd]. - - The postcondition [Q] states agreement between the outcome [out] - and the value of the return register [rret]. *) + The precondition [P] is the well-formedness of the compilation + environment [mut]. + + The postcondition [Q] characterizes the final RTL state [st']. + It must have memory state [m'] and a register state [rs'] that matches + [e']. Moreover, the program point reached must correspond to the outcome + [out]. This is captured by the following [state_for_outcome] predicate. *) + +Inductive state_for_outcome + (ncont: node) (nexits: list node) (nret: node) (rret: option reg) + (cs: list stackframe) (c: code) (sp: val) (rs: regset) (m: mem): + outcome -> RTL.state -> Prop := + | state_for_normal: + state_for_outcome ncont nexits nret rret cs c sp rs m + Out_normal (State cs c sp ncont rs m) + | state_for_exit: forall n nexit, + nth_error nexits n = Some nexit -> + state_for_outcome ncont nexits nret rret cs c sp rs m + (Out_exit n) (State cs c sp nexit rs m) + | state_for_return_none: + rret = None -> + state_for_outcome ncont nexits nret rret cs c sp rs m + (Out_return None) (State cs c sp nret rs m) + | state_for_return_some: forall r v, + rret = Some r -> + rs#r = v -> + state_for_outcome ncont nexits nret rret cs c sp rs m + (Out_return (Some v)) (State cs c sp nret rs m) + | state_for_return_tail: forall v, + state_for_outcome ncont nexits nret rret cs c sp rs m + (Out_tailcall_return v) (Returnstate cs v m). Definition transl_stmt_correct (sp: val) (e: env) (m: mem) (a: stmt) (t: trace) (e': env) (m': mem) (out: outcome) : Prop := - forall map ncont nexits nret rret s ns s' nd rs - (MWF: map_wf map s) - (TE: transl_stmt map a ncont nexits nret rret s = OK ns s') - (ME: match_env map e nil rs) - (OUT: outcome_node out ncont nexits nret nd) - (RRG: return_reg_ok s map rret), - exists rs', - exec_instrs tge s'.(st_code) sp ns rs m t nd rs' m' - /\ match_env map e' nil rs' - /\ match_return_outcome out rret rs'. + forall cs code map ns ncont nexits nret rret rs + (MWF: map_wf map) + (TE: tr_stmt code map a ns ncont nexits nret rret) + (ME: match_env map e nil rs), + exists rs', exists st, + state_for_outcome ncont nexits nret rret cs code sp rs' m' out st + /\ star step tge (State cs code sp ns rs m) t st + /\ match_env map e' nil rs'. (** Finally, the correctness condition for the translation of functions is that the translated RTL function, when applied to the same arguments - as the original Cminor function, returns the same value and performs - the same modifications on the memory state. *) + as the original CminorSel function, returns the same value, produces + the same trace of events, and performs the same modifications on the + memory state. *) Definition transl_function_correct - (m: mem) (f: Cminor.fundef) (vargs: list val) - (t: trace) (m':mem) (vres: val) : Prop := - forall tf - (TE: transl_fundef f = Some tf), - exec_function tge tf vargs m t vres m'. + (m: mem) (f: CminorSel.fundef) (vargs: list val) + (t: trace) (m': mem) (vres: val) : Prop := + forall cs tf + (TE: transl_fundef f = OK tf), + star step tge (Callstate cs tf vargs m) t (Returnstate cs vres m'). (** The correctness of the translation is a huge induction over - the Cminor evaluation derivation for the source program. To keep + the CminorSel evaluation derivation for the source program. To keep the proof manageable, we put each case of the proof in a separate - lemma. There is one lemma for each Cminor evaluation rule. - It takes as hypotheses the premises of the Cminor evaluation rule, + lemma. There is one lemma for each CminorSel evaluation rule. + It takes as hypotheses the premises of the CminorSel evaluation rule, plus the induction hypotheses, that is, the [transl_expr_correct], etc, corresponding to the evaluations of sub-expressions or sub-statements. *) @@ -276,35 +534,22 @@ Lemma transl_expr_Evar_correct: e!id = Some v -> transl_expr_correct sp le e m (Evar id) E0 m v. Proof. - intros; red; intros. monadInv TE. intro. - generalize EQ; unfold find_var. caseEq (map_vars map)!id. - intros r' MV; monadSimpl. subst s0; subst r'. - generalize (add_move_correct _ _ sp _ _ _ _ rs m TE0). - intros [rs1 [EX1 [RES1 OTHER1]]]. - exists rs1. -(* Exec *) - split. assumption. -(* Match-env *) - split. inversion TRG; subst. - (* Optimized case rd = r *) - rewrite MV in H3; injection H3; intro; subst r. - apply match_env_exten with rs. - intros. case (Reg.eq r rd); intro. - subst r; assumption. apply OTHER1; assumption. - assumption. - (* General case rd is temp *) - apply match_env_invariant with rs. - assumption. intros. apply OTHER1. congruence. -(* Result value *) - split. rewrite RES1. eauto with rtlg. -(* Other regs *) - intros. destruct (Reg.eq rd r0). - subst r0. inversion TRG; subst. - congruence. - byContradiction. tauto. + intros; red; intros. inv TE. + exploit tr_move_correct; eauto. intros [rs' [A [B C]]]. + exists rs'; split. eauto. + destruct H2 as [D | [E F]]. + (* optimized case *) + subst r. + assert (forall r, rs'#r = rs#r). + intros. destruct (Reg.eq r rd). subst r. auto. auto. + split. eapply match_env_invariant; eauto. + split. rewrite B. eapply match_env_find_var; eauto. auto. - - intro; monadSimpl. + (* general case *) + split. eapply match_env_invariant; eauto. + intros. apply C. congruence. + split. rewrite B. eapply match_env_find_var; eauto. + intros. apply C. intuition congruence. Qed. Lemma transl_expr_Eop_correct: @@ -313,36 +558,25 @@ Lemma transl_expr_Eop_correct: (v: val), eval_exprlist ge sp le e m al t m1 vl -> transl_exprlist_correct sp le e m al t m1 vl -> - eval_operation ge sp op vl = Some v -> + eval_operation ge sp op vl m1 = Some v -> transl_expr_correct sp le e m (Eop op al) t m1 v. Proof. - intros until v. intros EEL TEL EOP. red; intros. - simpl in TE. monadInv TE. intro EQ1. - exploit TEL. 2: eauto. eauto with rtlg. eauto. eauto with rtlg. - intros [rs1 [EX1 [ME1 [RR1 RO1]]]]. + intros; red; intros. inv TE. + exploit H0; eauto. intros [rs1 [EX1 [ME1 [RR1 RO1]]]]. exists (rs1#rd <- v). (* Exec *) - split. eapply exec_trans. eexact EX1. - apply exec_instrs_incr with s1. eauto with rtlg. - apply exec_one; eapply exec_Iop. eauto with rtlg. + split. eapply star_right. eexact EX1. + eapply exec_Iop; eauto. subst vl. - rewrite (@eval_operation_preserved Cminor.fundef RTL.fundef ge tge). - eexact EOP. + rewrite (@eval_operation_preserved CminorSel.fundef RTL.fundef ge tge). + auto. exact symbols_preserved. traceEq. (* Match-env *) - split. inversion TRG. eauto with rtlg. + split. eauto with rtlg. (* Result reg *) split. apply Regmap.gss. (* Other regs *) - intros. rewrite Regmap.gso. - apply RO1. eauto with rtlg. - destruct (In_dec Reg.eq r l). - left. elim (alloc_regs_fresh_or_in_map _ _ _ _ _ MWF EQ r i); intro. - auto. byContradiction; eauto with rtlg. - right; auto. - red; intro; subst r. - elim H0; intro. inversion TRG. contradiction. - tauto. + intros. rewrite Regmap.gso. auto. intuition congruence. Qed. Lemma transl_expr_Eload_correct: @@ -356,30 +590,19 @@ Lemma transl_expr_Eload_correct: Mem.loadv chunk m1 a = Some v -> transl_expr_correct sp le e m (Eload chunk addr al) t m1 v. Proof. - intros; red; intros. simpl in TE. monadInv TE. intro EQ1. clear TE. - assert (MWF1: map_wf map s1). eauto with rtlg. - assert (TRG1: target_regs_ok s1 map al l). eauto with rtlg. - generalize (H0 _ _ _ _ _ _ _ MWF1 EQ1 ME TRG1). - intros [rs1 [EX1 [ME1 [RES1 OTHER1]]]]. + intros; red; intros. inv TE. + exploit H0; eauto. intros [rs1 [EX1 [ME1 [RES1 OTHER1]]]]. exists (rs1#rd <- v). (* Exec *) - split. eapply exec_trans. eexact EX1. - apply exec_instrs_incr with s1. eauto with rtlg. - apply exec_one. eapply exec_Iload. eauto with rtlg. + split. eapply star_right. eexact EX1. eapply exec_Iload; eauto. rewrite RES1. rewrite (@eval_addressing_preserved _ _ ge tge). - eexact H1. exact symbols_preserved. assumption. traceEq. + exact H1. exact symbols_preserved. traceEq. (* Match-env *) - split. eapply match_env_update_temp. assumption. inversion TRG. assumption. + split. eauto with rtlg. (* Result *) split. apply Regmap.gss. (* Other regs *) - intros. rewrite Regmap.gso. apply OTHER1. - eauto with rtlg. - case (In_dec Reg.eq r l); intro. - elim (alloc_regs_fresh_or_in_map _ _ _ _ _ MWF EQ r i); intro. - tauto. byContradiction. eauto with rtlg. - tauto. - red; intro; subst r. inversion TRG. tauto. + intros. rewrite Regmap.gso. auto. intuition congruence. Qed. Lemma transl_expr_Estore_correct: @@ -397,35 +620,18 @@ Lemma transl_expr_Estore_correct: t = t1 ** t2 -> transl_expr_correct sp le e m (Estore chunk addr al b) t m3 v. Proof. - intros; red; intros. simpl in TE; monadInv TE. intro EQ2; clear TE. - assert (MWF2: map_wf map s2). - apply map_wf_incr with s. - apply state_incr_trans2 with s0 s1; eauto with rtlg. - assumption. - assert (TRG2: target_regs_ok s2 map al l). - apply target_regs_ok_incr with s0; eauto with rtlg. - generalize (H0 _ _ _ _ _ _ _ MWF2 EQ2 ME TRG2). - intros [rs1 [EX1 [ME1 [RES1 OTHER1]]]]. - assert (MWF1: map_wf map s1). eauto with rtlg. - assert (TRG1: target_reg_ok s1 map b rd). - inversion TRG. apply target_reg_other; eauto with rtlg. - generalize (H2 _ _ _ _ _ _ _ MWF1 EQ1 ME1 TRG1). - intros [rs2 [EX2 [ME2 [RES2 OTHER2]]]]. + intros; red; intros; inv TE. + exploit H0; eauto. intros [rs1 [EX1 [ME1 [RES1 OTHER1]]]]. + exploit H2; eauto. intros [rs2 [EX2 [ME2 [RES2 OTHER2]]]]. exists rs2. (* Exec *) - split. eapply exec_trans. eexact EX1. - apply exec_instrs_incr with s2. eauto with rtlg. - eapply exec_trans. eexact EX2. - apply exec_instrs_incr with s1. eauto with rtlg. - apply exec_one. eapply exec_Istore. eauto with rtlg. - assert (rs2##l = rs1##l). + split. eapply star_trans. eexact EX1. + eapply star_right. eexact EX2. + eapply exec_Istore; eauto. + assert (rs2##rl = rs1##rl). apply list_map_exten. intros r' IN. symmetry. apply OTHER2. - eauto with rtlg. eauto with rtlg. - elim (alloc_regs_fresh_or_in_map _ _ _ _ _ MWF EQ r' IN); intro. - tauto. right. apply sym_not_equal. - apply valid_fresh_different with s. inversion TRG; assumption. - assumption. - rewrite H6; rewrite RES1. + right. apply in_or_app. auto. + rewrite H5; rewrite RES1. rewrite (@eval_addressing_preserved _ _ ge tge). eexact H3. exact symbols_preserved. rewrite RES2. assumption. @@ -435,110 +641,52 @@ Proof. (* Result *) split. assumption. (* Other regs *) - intro r'; intros. transitivity (rs1#r'). - apply OTHER2. apply reg_valid_incr with s; eauto with rtlg. - assumption. - apply OTHER1. apply reg_valid_incr with s. - apply state_incr_trans2 with s0 s1; eauto with rtlg. assumption. - case (In_dec Reg.eq r' l); intro. - elim (alloc_regs_fresh_or_in_map _ _ _ _ _ MWF EQ r' i); intro. - tauto. byContradiction; eauto with rtlg. tauto. -Qed. + intro r'; intros. transitivity (rs1#r'). + apply OTHER2. intuition. + auto. +Qed. Lemma transl_expr_Ecall_correct: forall (sp: val) (le : letenv) (e : env) (m : mem) (sig : signature) (a : expr) (bl : exprlist) (t t1: trace) (m1: mem) (t2: trace) (m2 : mem) (t3: trace) (m3: mem) (vf : val) - (vargs : list val) (vres : val) (f : Cminor.fundef), + (vargs : list val) (vres : val) (f : CminorSel.fundef), eval_expr ge sp le e m a t1 m1 vf -> transl_expr_correct sp le e m a t1 m1 vf -> eval_exprlist ge sp le e m1 bl t2 m2 vargs -> transl_exprlist_correct sp le e m1 bl t2 m2 vargs -> Genv.find_funct ge vf = Some f -> - Cminor.funsig f = sig -> + CminorSel.funsig f = sig -> eval_funcall ge m2 f vargs t3 m3 vres -> transl_function_correct m2 f vargs t3 m3 vres -> t = t1 ** t2 ** t3 -> transl_expr_correct sp le e m (Ecall sig a bl) t m3 vres. Proof. - intros. red; simpl; intros. - monadInv TE. intro EQ3. clear TE. - assert (MWFa: map_wf map s3). - apply map_wf_incr with s. - apply state_incr_trans3 with s0 s1 s2; eauto with rtlg. - assumption. - assert (TRGr: target_reg_ok s3 map a r). - apply target_reg_ok_incr with s0. - apply state_incr_trans2 with s1 s2; eauto with rtlg. - eauto with rtlg. - generalize (H0 _ _ _ _ _ _ _ MWFa EQ3 ME TRGr). - intros [rs1 [EX1 [ME1 [RES1 OTHER1]]]]. - clear MWFa TRGr. - assert (MWFbl: map_wf map s2). - apply map_wf_incr with s. - apply state_incr_trans2 with s0 s1; eauto with rtlg. - assumption. - assert (TRGl: target_regs_ok s2 map bl l). - apply target_regs_ok_incr with s1; eauto with rtlg. - generalize (H2 _ _ _ _ _ _ _ MWFbl EQ2 ME1 TRGl). - intros [rs2 [EX2 [ME2 [RES2 OTHER2]]]]. - clear MWFbl TRGl. - - generalize (functions_translated vf f H3). intros [tf [TFIND TF]]. - generalize (H6 tf TF). intro EXF. - - assert (EX3: exec_instrs tge (st_code s2) sp n rs2 m2 - t3 nd (rs2#rd <- vres) m3). - apply exec_one. eapply exec_Icall. - eauto with rtlg. simpl. replace (rs2#r) with vf. eexact TFIND. - rewrite <- RES1. symmetry. apply OTHER2. - apply reg_valid_incr with s0; eauto with rtlg. - assert (MWFs0: map_wf map s0). eauto with rtlg. - case (In_dec Reg.eq r l); intro. - elim (alloc_regs_fresh_or_in_map _ _ _ _ _ MWFs0 EQ0 r i); intro. - tauto. byContradiction. apply valid_fresh_absurd with r s0. - eauto with rtlg. assumption. - tauto. - generalize (sig_transl_function _ _ TF). congruence. - rewrite RES2. assumption. - + intros; red; intros; inv TE. + exploit H0; eauto. intros [rs1 [EX1 [ME1 [RES1 OTHER1]]]]. + exploit H2; eauto. intros [rs2 [EX2 [ME2 [RES2 OTHER2]]]]. + exploit functions_translated; eauto. intros [tf [TFIND TF]]. + exploit H6; eauto. intro EXF. exists (rs2#rd <- vres). (* Exec *) - split. eapply exec_trans. eexact EX1. - apply exec_instrs_incr with s3. eauto with rtlg. - eapply exec_trans. eexact EX2. - apply exec_instrs_incr with s2. eauto with rtlg. - eexact EX3. reflexivity. traceEq. + split. eapply star_trans. eexact EX1. + eapply star_trans. eexact EX2. + eapply star_left. eapply exec_Icall; eauto. + simpl. rewrite OTHER2. rewrite RES1. eauto. simpl; tauto. + eapply sig_transl_function; eauto. + eapply star_right. rewrite RES2. eexact EXF. + apply exec_return. reflexivity. reflexivity. reflexivity. traceEq. (* Match env *) - split. apply match_env_update_temp. assumption. - inversion TRG. assumption. + split. eauto with rtlg. (* Result *) split. apply Regmap.gss. (* Other regs *) intros. - rewrite Regmap.gso. transitivity (rs1#r0). - apply OTHER2. - apply reg_valid_incr with s. - apply state_incr_trans2 with s0 s1; eauto with rtlg. - assumption. - assert (MWFs0: map_wf map s0). eauto with rtlg. - case (In_dec Reg.eq r0 l); intro. - elim (alloc_regs_fresh_or_in_map _ _ _ _ _ MWFs0 EQ0 r0 i); intro. - tauto. byContradiction. apply valid_fresh_absurd with r0 s0. - eauto with rtlg. assumption. - tauto. - apply OTHER1. - apply reg_valid_incr with s. - apply state_incr_trans3 with s0 s1 s2; eauto with rtlg. - assumption. - case (Reg.eq r0 r); intro. - subst r0. - elim (alloc_reg_fresh_or_in_map _ _ _ _ _ MWF EQ); intro. - tauto. byContradiction; eauto with rtlg. - tauto. - red; intro; subst r0. - inversion TRG. tauto. + rewrite Regmap.gso. transitivity (rs1#r). + apply OTHER2. simpl; tauto. + apply OTHER1; auto. + intuition congruence. Qed. Lemma transl_expr_Econdition_correct: @@ -552,52 +700,20 @@ Lemma transl_expr_Econdition_correct: t = t1 ** t2 -> transl_expr_correct sp le e m (Econdition a b c) t m2 v2. Proof. - intros; red; intros. simpl in TE; monadInv TE. intro EQ1; clear TE. - - assert (MWF1: map_wf map s1). - apply map_wf_incr with s. eauto with rtlg. assumption. - generalize (H0 _ _ _ _ _ _ _ MWF1 EQ1 ME). - intros [rs1 [EX1 [ME1 OTHER1]]]. - destruct v1. - - assert (MWF0: map_wf map s0). eauto with rtlg. - assert (TRG0: target_reg_ok s0 map b rd). - inversion TRG. apply target_reg_other; eauto with rtlg. - generalize (H2 _ _ _ _ _ _ _ MWF0 EQ0 ME1 TRG0). - intros [rs2 [EX2 [ME2 [RES2 OTHER2]]]]. - exists rs2. -(* Exec *) - split. eapply exec_trans. eexact EX1. - apply exec_instrs_incr with s1. eauto with rtlg. - eexact EX2. auto. -(* Match-env *) - split. assumption. -(* Result value *) - split. assumption. -(* Other regs *) - intros. transitivity (rs1#r). - apply OTHER2; auto. eauto with rtlg. - apply OTHER1; auto. apply reg_valid_incr with s. - apply state_incr_trans with s0; eauto with rtlg. assumption. - - assert (TRGc: target_reg_ok s map c rd). - inversion TRG. apply target_reg_other; auto. - generalize (H2 _ _ _ _ _ _ _ MWF EQ ME1 TRGc). - intros [rs2 [EX2 [ME2 [RES2 OTHER2]]]]. + intros; red; intros; inv TE. + exploit H0; eauto. intros [rs1 [EX1 [ME1 OTHER1]]]. + assert (tr_expr code map pr (if v1 then b else c) (if v1 then ntrue else nfalse) nd rd). + destruct v1; auto. + exploit H2; eauto. intros [rs2 [EX2 [ME2 [RES2 OTHER2]]]]. exists rs2. (* Exec *) - split. eapply exec_trans. eexact EX1. - apply exec_instrs_incr with s0. eauto with rtlg. - eexact EX2. auto. + split. eapply star_trans. eexact EX1. eexact EX2. auto. (* Match-env *) split. assumption. (* Result value *) split. assumption. (* Other regs *) - intros. transitivity (rs1#r). - apply OTHER2; auto. eauto with rtlg. - apply OTHER1; auto. apply reg_valid_incr with s. - apply state_incr_trans2 with s0 s1; eauto with rtlg. assumption. + intros. transitivity (rs1#r); auto. Qed. Lemma transl_expr_Elet_correct: @@ -611,47 +727,25 @@ Lemma transl_expr_Elet_correct: t = t1 ** t2 -> transl_expr_correct sp le e m (Elet a b) t m2 v2. Proof. - intros; red; intros. - simpl in TE; monadInv TE. intro EQ1. - assert (MWF1: map_wf map s1). eauto with rtlg. - assert (TRG1: target_reg_ok s1 map a r). - eapply target_reg_other; eauto with rtlg. - generalize (H0 _ _ _ _ _ _ _ MWF1 EQ1 ME TRG1). - intros [rs1 [EX1 [ME1 [RES1 OTHER1]]]]. - assert (MWF2: map_wf (add_letvar map r) s0). - apply add_letvar_wf; eauto with rtlg. - assert (ME2: match_env (add_letvar map r) e (v1 :: le) rs1). - apply match_env_letvar; assumption. - assert (TRG2: target_reg_ok s0 (add_letvar map r) b rd). - inversion TRG. apply target_reg_other. - unfold reg_in_map, add_letvar; simpl. red; intro. - elim H10; intro. apply H4. left. assumption. - elim H11; intro. apply valid_fresh_absurd with rd s. - assumption. rewrite <- H12. eauto with rtlg. - apply H4. right. assumption. - eauto with rtlg. - generalize (H2 _ _ _ _ _ _ _ MWF2 EQ0 ME2 TRG2). + intros; red; intros; inv TE. + exploit H0; eauto. intros [rs1 [EX1 [ME1 [RES1 OTHER1]]]]. + assert (map_wf (add_letvar map r)). + eapply add_letvar_wf; eauto. + exploit H2; eauto. eapply match_env_bind_letvar; eauto. intros [rs2 [EX2 [ME3 [RES2 OTHER2]]]]. exists rs2. (* Exec *) - split. eapply exec_trans. eexact EX1. - apply exec_instrs_incr with s1. eauto with rtlg. eexact EX2. auto. + split. eapply star_trans. eexact EX1. eexact EX2. auto. (* Match-env *) - split. apply mk_match_env. exact (me_vars _ _ _ _ ME3). - generalize (me_letvars _ _ _ _ ME3). - unfold add_letvar; simpl. intro X; injection X; auto. + split. eapply match_env_unbind_letvar; eauto. (* Result *) split. assumption. (* Other regs *) intros. transitivity (rs1#r0). - apply OTHER2. eauto with rtlg. - elim H5; intro. left. + apply OTHER2. elim H4; intro; auto. unfold reg_in_map, add_letvar; simpl. - unfold reg_in_map in H6; tauto. - tauto. - apply OTHER1. eauto with rtlg. - right. red; intro. apply valid_fresh_absurd with r0 s. - assumption. rewrite H6. eauto with rtlg. + unfold reg_in_map in H5; tauto. + auto. Qed. Lemma transl_expr_Eletvar_correct: @@ -660,35 +754,22 @@ Lemma transl_expr_Eletvar_correct: nth_error le n = Some v -> transl_expr_correct sp le e m (Eletvar n) E0 m v. Proof. - intros; red; intros. - simpl in TE; monadInv TE. intro EQ1. - generalize EQ. unfold find_letvar. - caseEq (nth_error (map_letvars map) n). - intros r0 NE; monadSimpl. subst s0; subst r0. - generalize (add_move_correct _ _ sp _ _ _ _ rs m EQ1). - intros [rs1 [EX1 [RES1 OTHER1]]]. + intros; red; intros; inv TE. + exploit tr_move_correct; eauto. intros [rs1 [EX1 [RES1 OTHER1]]]. exists rs1. (* Exec *) - split. exact EX1. + split. eexact EX1. (* Match-env *) - split. inversion TRG. - assert (r = rd). congruence. - subst r. apply match_env_exten with rs. - intros. case (Reg.eq r rd); intro. subst r; auto. auto. auto. - apply match_env_invariant with rs. auto. - intros. apply OTHER1. red;intro;subst r1. contradiction. + split. apply match_env_invariant with rs. auto. + intros. destruct H2 as [A | [B C]]. + subst r. destruct (Reg.eq r0 rd). subst r0; auto. auto. + apply OTHER1. intuition congruence. (* Result *) - split. rewrite RES1. - generalize H. rewrite <- (me_letvars _ _ _ _ ME). - change positive with reg. - rewrite list_map_nth. rewrite NE. simpl. congruence. + split. rewrite RES1. eapply match_env_find_letvar; eauto. (* Other regs *) - intros. inversion TRG. - assert (r = rd). congruence. subst r. - case (Reg.eq r0 rd); intro. subst r0; auto. auto. - apply OTHER1. red; intro; subst r0. tauto. - - intro; monadSimpl. + intros. destruct H2 as [A | [B C]]. + subst r. destruct (Reg.eq r0 rd). subst r0; auto. auto. + apply OTHER1. intuition congruence. Qed. Lemma transl_expr_Ealloc_correct: @@ -700,47 +781,35 @@ Lemma transl_expr_Ealloc_correct: Mem.alloc m1 0 (Int.signed n) = (m2, b) -> transl_expr_correct sp le e m (Ealloc a) t m2 (Vptr b Int.zero). Proof. - intros until b; intros EE TEC ALLOC; red; intros. - simpl in TE. monadInv TE. intro EQ1. - assert (TRG': target_reg_ok s1 map a r); eauto with rtlg. - assert (MWF': map_wf map s1). eauto with rtlg. - generalize (TEC _ _ _ _ _ _ _ MWF' EQ1 ME TRG'). - intros [rs1 [EX1 [ME1 [RR1 RO1]]]]. + intros; red; intros; inv TE. + exploit H0; eauto. intros [rs1 [EX1 [ME1 [RR1 RO1]]]]. exists (rs1#rd <- (Vptr b Int.zero)). (* Exec *) - split. eapply exec_trans. eexact EX1. - apply exec_instrs_incr with s1. eauto with rtlg. - apply exec_one; eapply exec_Ialloc. eauto with rtlg. + split. eapply star_right. eexact EX1. + eapply exec_Ialloc. eauto with rtlg. eexact RR1. assumption. traceEq. (* Match-env *) - split. inversion TRG. eauto with rtlg. + split. eauto with rtlg. (* Result *) split. apply Regmap.gss. (* Other regs *) - intros. rewrite Regmap.gso. - apply RO1. eauto with rtlg. - case (Reg.eq r0 r); intro. - subst r0. left. elim (alloc_reg_fresh_or_in_map _ _ _ _ _ MWF EQ); intro. - auto. byContradiction; eauto with rtlg. - right; assumption. - elim H0; intro. red; intro. subst r0. inversion TRG. contradiction. - auto. + intros. rewrite Regmap.gso. auto. intuition congruence. Qed. Lemma transl_condition_CEtrue_correct: forall (sp: val) (le : letenv) (e : env) (m : mem), transl_condition_correct sp le e m CEtrue E0 m true. Proof. - intros; red; intros. simpl in TE; monadInv TE. subst ns. - exists rs. split. apply exec_refl. split. auto. auto. + intros; red; intros; inv TE. + exists rs. split. apply star_refl. split. auto. auto. Qed. Lemma transl_condition_CEfalse_correct: forall (sp: val) (le : letenv) (e : env) (m : mem), transl_condition_correct sp le e m CEfalse E0 m false. Proof. - intros; red; intros. simpl in TE; monadInv TE. subst ns. - exists rs. split. apply exec_refl. split. auto. auto. + intros; red; intros; inv TE. + exists rs. split. apply star_refl. split. auto. auto. Qed. Lemma transl_condition_CEcond_correct: @@ -749,33 +818,24 @@ Lemma transl_condition_CEcond_correct: (m1 : mem) (vl : list val) (b : bool), eval_exprlist ge sp le e m al t1 m1 vl -> transl_exprlist_correct sp le e m al t1 m1 vl -> - eval_condition cond vl = Some b -> + eval_condition cond vl m1 = Some b -> transl_condition_correct sp le e m (CEcond cond al) t1 m1 b. Proof. - intros; red; intros. simpl in TE; monadInv TE. intro EQ1; clear TE. - assert (MWF1: map_wf map s1). eauto with rtlg. - assert (TRG: target_regs_ok s1 map al l). eauto with rtlg. - generalize (H0 _ _ _ _ _ _ _ MWF1 EQ1 ME TRG). - intros [rs1 [EX1 [ME1 [RES1 OTHER1]]]]. + intros; red; intros; inv TE. + exploit H0; eauto. intros [rs1 [EX1 [ME1 [RES1 OTHER1]]]]. exists rs1. (* Exec *) - split. eapply exec_trans. eexact EX1. - apply exec_instrs_incr with s1. eauto with rtlg. - apply exec_one. + split. eapply star_right. eexact EX1. destruct b. - eapply exec_Icond_true. eauto with rtlg. + eapply exec_Icond_true; eauto. rewrite RES1. assumption. - eapply exec_Icond_false. eauto with rtlg. + eapply exec_Icond_false; eauto. rewrite RES1. assumption. traceEq. (* Match-env *) split. assumption. (* Regs *) - intros. apply OTHER1. eauto with rtlg. - case (In_dec Reg.eq r l); intro. - elim (alloc_regs_fresh_or_in_map _ _ _ _ _ MWF EQ r i); intro. - tauto. byContradiction; eauto with rtlg. - tauto. + auto. Qed. Lemma transl_condition_CEcondition_correct: @@ -789,47 +849,31 @@ Lemma transl_condition_CEcondition_correct: t = t1 ** t2 -> transl_condition_correct sp le e m (CEcondition a b c) t m2 vb2. Proof. - intros; red; intros. simpl in TE; monadInv TE. intro EQ1; clear TE. - assert (MWF1: map_wf map s1). eauto with rtlg. - generalize (H0 _ _ _ _ _ _ _ MWF1 EQ1 ME). - intros [rs1 [EX1 [ME1 OTHER1]]]. - destruct vb1. - - assert (MWF0: map_wf map s0). eauto with rtlg. - generalize (H2 _ _ _ _ _ _ _ MWF0 EQ0 ME1). - intros [rs2 [EX2 [ME2 OTHER2]]]. - exists rs2. - split. eapply exec_trans. eexact EX1. - apply exec_instrs_incr with s1. eauto with rtlg. - eexact EX2. auto. - split. assumption. - intros. transitivity (rs1#r). - apply OTHER2; eauto with rtlg. - apply OTHER1; eauto with rtlg. - - generalize (H2 _ _ _ _ _ _ _ MWF EQ ME1). - intros [rs2 [EX2 [ME2 OTHER2]]]. + intros; red; intros; inv TE. + exploit H0; eauto. intros [rs1 [EX1 [ME1 OTHER1]]]. + assert (tr_condition code map pr (if vb1 then b else c) + (if vb1 then ntrue' else nfalse') ntrue nfalse). + destruct vb1; auto. + exploit H2; eauto. intros [rs2 [EX2 [ME2 OTHER2]]]. exists rs2. - split. eapply exec_trans. eexact EX1. - apply exec_instrs_incr with s0. eauto with rtlg. - eexact EX2. auto. - split. assumption. - intros. transitivity (rs1#r). - apply OTHER2; eauto with rtlg. - apply OTHER1; eauto with rtlg. +(* Execution *) + split. eapply star_trans. eexact EX1. eexact EX2. auto. +(* Match-env *) + split. auto. +(* Regs *) + intros. transitivity (rs1#r); auto. Qed. Lemma transl_exprlist_Enil_correct: forall (sp: val) (le : letenv) (e : env) (m : mem), transl_exprlist_correct sp le e m Enil E0 m nil. Proof. - intros; red; intros. - generalize TE. simpl. destruct rl; monadSimpl. - subst s'; subst ns. exists rs. - split. apply exec_refl. + intros; red; intros; inv TE. + exists rs. + split. apply star_refl. split. assumption. split. reflexivity. - intros. reflexivity. + auto. Qed. Lemma transl_exprlist_Econs_correct: @@ -843,93 +887,90 @@ Lemma transl_exprlist_Econs_correct: t = t1 ** t2 -> transl_exprlist_correct sp le e m (Econs a bl) t m2 (v :: vl). Proof. - intros. red. intros. - inversion TRG. - rewrite <- H10 in TE. simpl in TE. monadInv TE. intro EQ1. - assert (MWF1: map_wf map s1); eauto with rtlg. - assert (TRG1: target_reg_ok s1 map a r); eauto with rtlg. - generalize (H0 _ _ _ _ _ _ _ MWF1 EQ1 ME TRG1). - intros [rs1 [EX1 [ME1 [RES1 OTHER1]]]]. - generalize (H2 _ _ _ _ _ _ _ MWF EQ ME1 H11). - intros [rs2 [EX2 [ME2 [RES2 OTHER2]]]]. + intros; red; intros; inv TE. + exploit H0; eauto. intros [rs1 [EX1 [ME1 [RES1 OTHER1]]]]. + exploit H2; eauto. intros [rs2 [EX2 [ME2 [RES2 OTHER2]]]]. exists rs2. (* Exec *) - split. eapply exec_trans. eexact EX1. - apply exec_instrs_incr with s1. eauto with rtlg. - eexact EX2. auto. + split. eapply star_trans. eexact EX1. eexact EX2. auto. (* Match-env *) split. assumption. (* Results *) - split. simpl. rewrite RES2. rewrite OTHER2. rewrite RES1. - reflexivity. - eauto with rtlg. - eauto with rtlg. + split. simpl. rewrite RES2. rewrite OTHER2. rewrite RES1. auto. + simpl; tauto. (* Other regs *) - simpl. intros. - transitivity (rs1#r0). - apply OTHER2; auto. tauto. - apply OTHER1; auto. eauto with rtlg. - elim H13; intro. left; assumption. right; apply sym_not_equal; tauto. + intros. transitivity (rs1#r). + apply OTHER2; auto. simpl; tauto. + apply OTHER1; auto. Qed. Lemma transl_funcall_internal_correct: - forall (m : mem) (f : Cminor.function) + forall (m : mem) (f : CminorSel.function) (vargs : list val) (m1 : mem) (sp : block) (e : env) (t : trace) - (e2 : env) (m2 : mem) (out : outcome) (vres : val), + (e2 : env) (m2 : mem) (out: outcome) (vres : val), Mem.alloc m 0 (fn_stackspace f) = (m1, sp) -> - set_locals (fn_vars f) (set_params vargs (Cminor.fn_params f)) = e -> + set_locals (fn_vars f) (set_params vargs (CminorSel.fn_params f)) = e -> exec_stmt ge (Vptr sp Int.zero) e m1 (fn_body f) t e2 m2 out -> transl_stmt_correct (Vptr sp Int.zero) e m1 (fn_body f) t e2 m2 out -> - outcome_result_value out f.(Cminor.fn_sig).(sig_res) vres -> - transl_function_correct m (Internal f) - vargs t (Mem.free m2 sp) vres. + outcome_result_value out f.(CminorSel.fn_sig).(sig_res) vres -> + transl_function_correct m (Internal f) vargs t + (outcome_free_mem out m2 sp) vres. Proof. intros; red; intros. - generalize TE. unfold transl_fundef, transl_function; simpl. - caseEq (transl_fun f init_state). - intros; discriminate. - intros ns s. unfold transl_fun. monadSimpl. - subst ns. intros EQ4. injection EQ4; intro TF; clear EQ4. - subst s4. - - pose (rs := init_regs vargs x). - assert (ME: match_env y0 e nil rs). + generalize TE; simpl. caseEq (transl_function f); simpl. 2: congruence. + intros tfi EQ1 EQ2. injection EQ2; clear EQ2; intro EQ2. + assert (TR: tr_function f tfi). apply transl_function_charact; auto. + rewrite <- EQ2. inversion TR. subst f0. + + pose (rs := init_regs vargs rparams). + assert (ME: match_env map2 e nil rs). rewrite <- H0. unfold rs. - eapply match_init_env_init_reg; eauto. + eapply match_init_env_init_reg; eauto. + + assert (MWF: map_wf map2). + assert (map_valid init_mapping init_state) by apply init_mapping_valid. + exploit (add_vars_valid (CminorSel.fn_params f)); eauto. intros [A B]. + eapply add_vars_wf; eauto. eapply add_vars_wf; eauto. apply init_mapping_wf. + + exploit H2; eauto. intros [rs' [st [OUT [EX ME']]]]. + + eapply star_left. + eapply exec_function_internal; eauto. simpl. + inversion OUT; clear OUT; subst out st; simpl in H3; simpl. + + (* Out_normal *) + unfold ret_reg in H6. destruct (sig_res (CminorSel.fn_sig f)). contradiction. + subst vres orret. + eapply star_right. unfold rs in EX. eexact EX. + change Vundef with (regmap_optget None Vundef rs'). + apply exec_Ireturn. auto. reflexivity. + + (* Out_exit *) + contradiction. + + (* Out_return None *) + subst orret. + unfold ret_reg in H8. destruct (sig_res (CminorSel.fn_sig f)). contradiction. + subst vres. + eapply star_right. unfold rs in EX. eexact EX. + change Vundef with (regmap_optget None Vundef rs'). + apply exec_Ireturn. auto. + reflexivity. - assert (OUT: outcome_node out n nil n n). - red. generalize H3. unfold outcome_result_value. - destruct out; contradiction || auto. - - assert (MWF1: map_wf y0 s1). - eapply add_vars_wf. eexact EQ0. - eapply add_vars_wf. eexact EQ. - apply init_mapping_wf. - - assert (MWF: map_wf y0 s3). - apply map_wf_incr with s1. apply state_incr_trans with s2; eauto with rtlg. - assumption. - - set (rr := ret_reg (Cminor.fn_sig f) r) in *. - assert (RRG: return_reg_ok s3 y0 rr). - apply return_reg_ok_incr with s2. eauto with rtlg. - unfold rr; apply new_reg_return_ok with s1; assumption. - - generalize (H2 _ _ _ _ _ _ _ _ _ rs MWF EQ3 ME OUT RRG). - intros [rs1 [EX1 [ME1 MR1]]]. - - rewrite <- TF. apply exec_funct_internal with m1 n rs1 rr; simpl. - assumption. - exact EX1. - apply instr_at_incr with s3. - eauto with rtlg. discriminate. eauto with rtlg. - generalize MR1. unfold match_return_outcome. - generalize H3. unfold outcome_result_value. - unfold rr, ret_reg; destruct (sig_res (Cminor.fn_sig f)). - unfold regmap_optget. destruct out; try contradiction. - destruct o; try contradiction. intros; congruence. - unfold regmap_optget. destruct out; contradiction||auto. - destruct o; contradiction||auto. + (* Out_return Some *) + subst orret. + unfold ret_reg in H8. unfold ret_reg in H9. + destruct (sig_res (CminorSel.fn_sig f)). inversion H9. + subst vres. + eapply star_right. unfold rs in EX. eexact EX. + replace v with (regmap_optget (Some rret) Vundef rs'). + apply exec_Ireturn. auto. + simpl. congruence. + reflexivity. + contradiction. + + (* a tail call *) + subst v. rewrite E0_right. auto. traceEq. Qed. Lemma transl_funcall_external_correct: @@ -939,17 +980,27 @@ Lemma transl_funcall_external_correct: Proof. intros; red; intros. unfold transl_function in TE; simpl in TE. inversion TE; subst tf. - apply exec_funct_external. auto. + apply star_one. apply exec_function_external. auto. Qed. Lemma transl_stmt_Sskip_correct: forall (sp: val) (e : env) (m : mem), transl_stmt_correct sp e m Sskip E0 e m Out_normal. Proof. - intros; red; intros. simpl in TE. monadInv TE. - subst s'; subst ns. - simpl in OUT. subst ncont. - exists rs. simpl. intuition. apply exec_refl. + intros; red; intros; inv TE. + exists rs; econstructor. + split. constructor. + split. apply star_refl. + auto. +Qed. + +Remark state_for_outcome_stop: + forall ncont1 ncont2 nexits nret rret cs code sp rs m out st, + state_for_outcome ncont1 nexits nret rret cs code sp rs m out st -> + out <> Out_normal -> + state_for_outcome ncont2 nexits nret rret cs code sp rs m out st. +Proof. + intros. inv H; congruence || econstructor; eauto. Qed. Lemma transl_stmt_Sseq_continue_correct: @@ -963,22 +1014,13 @@ Lemma transl_stmt_Sseq_continue_correct: t = t1 ** t2 -> transl_stmt_correct sp e m (Sseq s1 s2) t e2 m2 out. Proof. - intros; red; intros. simpl in TE; monadInv TE. intro EQ0. - assert (MWF1: map_wf map s0). eauto with rtlg. - assert (OUTs: outcome_node Out_normal n nexits nret n). - simpl. auto. - assert (RRG1: return_reg_ok s0 map rret). eauto with rtlg. - generalize (H0 _ _ _ _ _ _ _ _ _ _ MWF1 EQ0 ME OUTs RRG1). - intros [rs1 [EX1 [ME1 MR1]]]. - generalize (H2 _ _ _ _ _ _ _ _ _ _ MWF EQ ME1 OUT RRG). - intros [rs2 [EX2 [ME2 MR2]]]. - exists rs2. -(* Exec *) - split. eapply exec_trans. eexact EX1. - apply exec_instrs_incr with s0. eauto with rtlg. - eexact EX2. auto. -(* Match-env + return *) - tauto. + intros; red; intros; inv TE. + exploit H0; eauto. intros [rs1 [st1 [OUT1 [EX1 ME1]]]]. inv OUT1. + exploit H2; eauto. intros [rs2 [st2 [OUT2 [EX2 ME2]]]]. + exists rs2; exists st2. + split. eauto. + split. eapply star_trans; eauto. + auto. Qed. Lemma transl_stmt_Sseq_stop_correct: @@ -989,13 +1031,11 @@ Lemma transl_stmt_Sseq_stop_correct: out <> Out_normal -> transl_stmt_correct sp e m (Sseq s1 s2) t e1 m1 out. Proof. - intros; red; intros. - simpl in TE; monadInv TE. intro EQ0; clear TE. - assert (MWF1: map_wf map s0). eauto with rtlg. - assert (OUTs: outcome_node out n nexits nret nd). - destruct out; simpl; auto. tauto. - assert (RRG1: return_reg_ok s0 map rret). eauto with rtlg. - exact (H0 _ _ _ _ _ _ _ _ _ _ MWF1 EQ0 ME OUTs RRG1). + intros; red; intros; inv TE. + exploit H0; eauto. intros [rs1 [st1 [OUT1 [EX1 ME1]]]]. + exists rs1; exists st1. + split. eapply state_for_outcome_stop; eauto. + auto. Qed. Lemma transl_stmt_Sexpr_correct: @@ -1005,14 +1045,11 @@ Lemma transl_stmt_Sexpr_correct: transl_expr_correct sp nil e m a t m1 v -> transl_stmt_correct sp e m (Sexpr a) t e m1 Out_normal. Proof. - intros; red; intros. - simpl in OUT. subst nd. - unfold transl_stmt in TE. monadInv TE. intro EQ1. - assert (MWF0: map_wf map s0). eauto with rtlg. - assert (TRG: target_reg_ok s0 map a r). eauto with rtlg. - generalize (H0 _ _ _ _ _ _ _ MWF0 EQ1 ME TRG). - intros [rs1 [EX1 [ME1 [RES1 OTHER1]]]]. - exists rs1; simpl; tauto. + intros; red; intros; inv TE. + exploit H0; eauto. intros [rs1 [EX1 [ME1 [RES1 OTHER1]]]]. + exists rs1; econstructor. + split. constructor. + eauto. Qed. Lemma transl_stmt_Sassign_correct: @@ -1022,26 +1059,17 @@ Lemma transl_stmt_Sassign_correct: transl_expr_correct sp nil e m a t m1 v -> transl_stmt_correct sp e m (Sassign id a) t (PTree.set id v e) m1 Out_normal. Proof. - intros; red; intros. - simpl in TE. monadInv TE. intro EQ2. - assert (MWF0: map_wf map s2). - apply map_wf_incr with s. eauto 6 with rtlg. auto. - assert (TRGa: target_reg_ok s2 map a r0). eauto 6 with rtlg. - generalize (H0 _ _ _ _ _ _ _ MWF0 EQ2 ME TRGa). - intros [rs1 [EX1 [ME1 [RES1 OTHER1]]]]. - generalize (add_move_correct _ _ sp _ _ _ _ rs1 m1 EQ1). - intros [rs2 [EX2 [RES2 OTHER2]]]. - exists rs2. -(* Exec *) - split. inversion OUT; subst. eapply exec_trans. eexact EX1. - apply exec_instrs_incr with s2. eauto with rtlg. - eexact EX2. traceEq. -(* Match-env *) - split. - apply match_env_update_var with rs1 r s s0; auto. - congruence. -(* Outcome *) - simpl; auto. + intros; red; intros; inv TE. + exploit H0; eauto. intros [rs1 [EX1 [ME1 [RES1 OTHER1]]]]. + exploit tr_move_correct; eauto. intros [rs2 [EX2 [RES2 OTHER2]]]. + exists rs2; econstructor. + split. constructor. + split. eapply star_trans. eexact EX1. eexact EX2. traceEq. + apply match_env_invariant with (rs1#rv <- v). + apply match_env_update_var; auto. + intros. rewrite Regmap.gsspec. destruct (peq r rv). + subst r. congruence. + auto. Qed. Lemma transl_stmt_Sifthenelse_correct: @@ -1055,45 +1083,15 @@ Lemma transl_stmt_Sifthenelse_correct: t = t1 ** t2 -> transl_stmt_correct sp e m (Sifthenelse a s1 s2) t e2 m2 out. Proof. - intros; red; intros until rs; intro MWF. - simpl. case (more_likely a s1 s2); monadSimpl; intro EQ2; intros. - assert (MWF1: map_wf map s3). eauto with rtlg. - generalize (H0 _ _ _ _ _ _ rs MWF1 EQ2 ME). - intros [rs1 [EX1 [ME1 OTHER1]]]. - destruct v1. - assert (MWF0: map_wf map s0). eauto with rtlg. - assert (RRG0: return_reg_ok s0 map rret). eauto with rtlg. - generalize (H2 _ _ _ _ _ _ _ _ _ _ MWF0 EQ0 ME1 OUT RRG0). - intros [rs2 [EX2 [ME2 MRE2]]]. - exists rs2. split. - eapply exec_trans. eexact EX1. apply exec_instrs_incr with s3. - eauto with rtlg. eexact EX2. auto. - tauto. - generalize (H2 _ _ _ _ _ _ _ _ _ _ MWF EQ ME1 OUT RRG). - intros [rs2 [EX2 [ME2 MRE2]]]. - exists rs2. split. - eapply exec_trans. eexact EX1. apply exec_instrs_incr with s0. - eauto with rtlg. eexact EX2. auto. - tauto. - - assert (MWF1: map_wf map s3). eauto with rtlg. - generalize (H0 _ _ _ _ _ _ rs MWF1 EQ2 ME). - intros [rs1 [EX1 [ME1 OTHER1]]]. - destruct v1. - generalize (H2 _ _ _ _ _ _ _ _ _ _ MWF EQ ME1 OUT RRG). - intros [rs2 [EX2 [ME2 MRE2]]]. - exists rs2. split. - eapply exec_trans. eexact EX1. apply exec_instrs_incr with s0. - eauto with rtlg. eexact EX2. auto. - tauto. - assert (MWF0: map_wf map s0). eauto with rtlg. - assert (RRG0: return_reg_ok s0 map rret). eauto with rtlg. - generalize (H2 _ _ _ _ _ _ _ _ _ _ MWF0 EQ0 ME1 OUT RRG0). - intros [rs2 [EX2 [ME2 MRE2]]]. - exists rs2. split. - eapply exec_trans. eexact EX1. apply exec_instrs_incr with s3. - eauto with rtlg. eexact EX2. auto. - tauto. + intros; red; intros; inv TE. + exploit H0; eauto. intros [rs1 [EX1 [ME1 OTHER1]]]. + assert (tr_stmt code map (if v1 then s1 else s2) (if v1 then ntrue else nfalse) ncont nexits nret rret). + destruct v1; auto. + exploit H2; eauto. intros [rs2 [st2 [OUT2 [EX2 ME2]]]]. + exists rs2; exists st2. + split. eauto. + split. eapply star_trans. eexact EX1. eexact EX2. auto. + auto. Qed. Lemma transl_stmt_Sloop_loop_correct: @@ -1107,34 +1105,15 @@ Lemma transl_stmt_Sloop_loop_correct: t = t1 ** t2 -> transl_stmt_correct sp e m (Sloop sl) t e2 m2 out. Proof. - intros; red; intros. - generalize TE. simpl. monadSimpl. subst s2; subst n0. intros. - assert (MWF0: map_wf map s0). apply map_wf_incr with s. - eapply reserve_instr_incr; eauto. - assumption. - assert (OUT0: outcome_node Out_normal n nexits nret n). - unfold outcome_node. auto. - assert (RRG0: return_reg_ok s0 map rret). - apply return_reg_ok_incr with s. - eapply reserve_instr_incr; eauto. - assumption. - generalize (H0 _ _ _ _ _ _ _ _ _ _ MWF0 EQ0 ME OUT0 RRG0). - intros [rs1 [EX1 [ME1 MR1]]]. - generalize (H2 _ _ _ _ _ _ _ _ _ _ MWF TE ME1 OUT RRG). - intros [rs2 [EX2 [ME2 MR2]]]. - exists rs2. - split. eapply exec_trans. - apply exec_instrs_extends with s1. - eapply update_instr_extends. - eexact EQ. eauto with rtlg. eexact EQ1. eexact EX1. - apply exec_trans with E0 ns rs1 m1 t2. - apply exec_one. apply exec_Inop. - generalize EQ1. unfold update_instr. - case (plt n (st_nextnode s1)); intro; monadSimpl. - rewrite <- H5. simpl. apply PTree.gss. - exact EX2. - reflexivity. traceEq. - tauto. + intros; red; intros; inversion TE. subst. + exploit H0; eauto. intros [rs1 [st1 [OUT1 [EX1 ME1]]]]. inv OUT1. + exploit H2; eauto. intros [rs2 [st2 [OUT2 [EX2 ME2]]]]. + exists rs2; exists st2. + split. eauto. + split. eapply star_trans. eexact EX1. + eapply star_left. apply exec_Inop; eauto. eexact EX2. + reflexivity. traceEq. + auto. Qed. Lemma transl_stmt_Sloop_stop_correct: @@ -1145,25 +1124,12 @@ Lemma transl_stmt_Sloop_stop_correct: out <> Out_normal -> transl_stmt_correct sp e m (Sloop sl) t e1 m1 out. Proof. - intros; red; intros. - simpl in TE. monadInv TE. subst s2; subst n0. - assert (MWF0: map_wf map s0). apply map_wf_incr with s. - eapply reserve_instr_incr; eauto. assumption. - assert (OUT0: outcome_node out n nexits nret nd). - generalize OUT. unfold outcome_node. - destruct out; auto. elim H1; auto. - assert (RRG0: return_reg_ok s0 map rret). - apply return_reg_ok_incr with s. - eapply reserve_instr_incr; eauto. - assumption. - generalize (H0 _ _ _ _ _ _ _ _ _ _ MWF0 EQ0 ME OUT0 RRG0). - intros [rs1 [EX1 [ME1 MR1]]]. - exists rs1. split. - apply exec_instrs_extends with s1. - eapply update_instr_extends. - eexact EQ. eauto with rtlg. eexact EQ1. eexact EX1. - tauto. -Qed. + intros; red; intros; inv TE. + exploit H0; eauto. intros [rs1 [st1 [OUT1 [EX1 ME1]]]]. + exists rs1; exists st1. + split. eapply state_for_outcome_stop; eauto. + auto. +Qed. Lemma transl_stmt_Sblock_correct: forall (sp: val) (e : env) (m : mem) (sl : stmt) (t: trace) @@ -1172,65 +1138,59 @@ Lemma transl_stmt_Sblock_correct: transl_stmt_correct sp e m sl t e1 m1 out -> transl_stmt_correct sp e m (Sblock sl) t e1 m1 (outcome_block out). Proof. - intros; red; intros. simpl in TE. - assert (OUT': outcome_node out ncont (ncont :: nexits) nret nd). - generalize OUT. unfold outcome_node, outcome_block. - destruct out. + intros; red; intros; inv TE. + exploit H0; eauto. intros [rs1 [st1 [OUT1 [EX1 ME1]]]]. + exists rs1; exists st1. + split. inv OUT1; simpl; try (econstructor; eauto). + destruct n; simpl in H1. + inv H1. constructor. + constructor. auto. auto. - destruct n. simpl. intro; unfold value; congruence. - simpl. auto. - auto. - generalize (H0 _ _ _ _ _ _ _ _ _ _ MWF TE ME OUT' RRG). - intros [rs1 [EX1 [ME1 MR1]]]. - exists rs1. - split. assumption. - split. assumption. - generalize MR1. unfold match_return_outcome, outcome_block. - destruct out; auto. - destruct n; simpl; auto. -Qed. - -Lemma transl_exit_correct: - forall nexits ex s nd s', - transl_exit nexits ex s = OK nd s' -> - nth_error nexits ex = Some nd. -Proof. - intros until s'. unfold transl_exit. - case (nth_error nexits ex); intros; simplify_eq H; congruence. Qed. Lemma transl_stmt_Sexit_correct: forall (sp: val) (e : env) (m : mem) (n : nat), transl_stmt_correct sp e m (Sexit n) E0 e m (Out_exit n). Proof. - intros; red; intros. - simpl in TE. simpl in OUT. - generalize (transl_exit_correct _ _ _ _ _ TE); intro. - assert (ns = nd). congruence. subst ns. - exists rs. simpl. intuition. apply exec_refl. + intros; red; intros; inv TE. + exists rs; econstructor. + split. econstructor; eauto. + split. apply star_refl. + auto. Qed. Lemma transl_switch_correct: - forall sp rs m r i nexits nd default cases s ns s', - transl_switch r nexits cases default s = OK ns s' -> - nth_error nexits (switch_target i default cases) = Some nd -> + forall cs sp rs m i code r nexits t ns, + tr_switch code r nexits t ns -> rs#r = Vint i -> - exec_instrs tge s'.(st_code) sp ns rs m E0 nd rs m. + exists nd, + star step tge (State cs code sp ns rs m) E0 (State cs code sp nd rs m) /\ + nth_error nexits (comptree_match i t) = Some nd. Proof. - induction cases; simpl; intros. - generalize (transl_exit_correct _ _ _ _ _ H). intros. - assert (ns = nd). congruence. subst ns. apply exec_refl. - destruct a as [key1 exit1]. monadInv H. clear H. intro EQ1. - caseEq (Int.eq i key1); intro IEQ; rewrite IEQ in H0. - (* i = key1 *) - apply exec_trans with E0 n0 rs m E0. apply exec_one. - eapply exec_Icond_true. eauto with rtlg. simpl. rewrite H1. congruence. - generalize (transl_exit_correct _ _ _ _ _ EQ0); intro. - assert (n0 = nd). congruence. subst n0. apply exec_refl. traceEq. - (* i <> key1 *) - apply exec_trans with E0 n rs m E0. apply exec_one. - eapply exec_Icond_false. eauto with rtlg. simpl. rewrite H1. congruence. - apply exec_instrs_incr with s0; eauto with rtlg. traceEq. + induction 1; intros; simpl. + exists n. split. apply star_refl. auto. + + caseEq (Int.eq i key); intros. + exists nfound; split. + apply star_one. eapply exec_Icond_true; eauto. + simpl. rewrite H2. congruence. auto. + exploit IHtr_switch; eauto. intros [nd [EX MATCH]]. + exists nd; split. + eapply star_step. eapply exec_Icond_false; eauto. + simpl. rewrite H2. congruence. eexact EX. traceEq. + auto. + + caseEq (Int.ltu i key); intros. + exploit IHtr_switch1; eauto. intros [nd [EX MATCH]]. + exists nd; split. + eapply star_step. eapply exec_Icond_true; eauto. + simpl. rewrite H2. congruence. eexact EX. traceEq. + auto. + exploit IHtr_switch2; eauto. intros [nd [EX MATCH]]. + exists nd; split. + eapply star_step. eapply exec_Icond_false; eauto. + simpl. rewrite H2. congruence. eexact EX. traceEq. + auto. Qed. Lemma transl_stmt_Sswitch_correct: @@ -1242,32 +1202,25 @@ Lemma transl_stmt_Sswitch_correct: transl_stmt_correct sp e m (Sswitch a cases default) t1 e m1 (Out_exit (switch_target n default cases)). Proof. - intros; red; intros. monadInv TE. clear TE; intros EQ1. - simpl in OUT. - assert (state_incr s s1). eauto with rtlg. - - red in H0. - assert (MWF1: map_wf map s1). eauto with rtlg. - assert (TRG1: target_reg_ok s1 map a r). eauto with rtlg. - destruct (H0 _ _ _ _ _ _ _ MWF1 EQ1 ME TRG1) - as [rs' [EXEC1 [ME1 [RES1 OTHER1]]]]. - simpl. exists rs'. - (* execution *) - split. eapply exec_trans. eexact EXEC1. - apply exec_instrs_incr with s1. eauto with rtlg. - eapply transl_switch_correct; eauto. traceEq. - (* match_env & match_reg *) - tauto. + intros; red; intros; inv TE. + exploit H0; eauto. intros [rs1 [EX1 [ME1 [RES1 OTHER1]]]]. + exploit transl_switch_correct; eauto. intros [nd [EX2 MO2]]. + exists rs1; econstructor. + split. econstructor. + rewrite (validate_switch_correct _ _ _ H4 n). eauto. + split. eapply star_trans. eexact EX1. eexact EX2. traceEq. + auto. Qed. Lemma transl_stmt_Sreturn_none_correct: forall (sp: val) (e : env) (m : mem), transl_stmt_correct sp e m (Sreturn None) E0 e m (Out_return None). Proof. - intros; red; intros. generalize TE. simpl. - destruct rret; monadSimpl. - simpl in OUT. subst ns; subst nret. - exists rs. intuition. apply exec_refl. + intros; red; intros; inv TE. + exists rs; econstructor. + split. constructor. auto. + split. apply star_refl. + auto. Qed. Lemma transl_stmt_Sreturn_some_correct: @@ -1277,33 +1230,59 @@ Lemma transl_stmt_Sreturn_some_correct: transl_expr_correct sp nil e m a t m1 v -> transl_stmt_correct sp e m (Sreturn (Some a)) t e m1 (Out_return (Some v)). Proof. - intros; red; intros. generalize TE; simpl. - destruct rret. intro EQ. - assert (TRG: target_reg_ok s map a r). - inversion RRG. apply target_reg_other; auto. - generalize (H0 _ _ _ _ _ _ _ MWF EQ ME TRG). - intros [rs1 [EX1 [ME1 [RES1 OTHER1]]]]. - simpl in OUT. subst nd. exists rs1. tauto. - - monadSimpl. + intros; red; intros; inv TE. + exploit H0; eauto. intros [rs1 [EX1 [ME1 [RES1 OTHER1]]]]. + exists rs1; econstructor. + split. econstructor. reflexivity. auto. + eauto. +Qed. + +Lemma transl_stmt_Stailcall_correct: + forall (sp : block) (e : env) (m : mem) (sig : signature) (a : expr) + (bl : exprlist) (t t1 : trace) (m1 : mem) (t2 : trace) (m2 : mem) + (t3 : trace) (m3 : mem) (vf : val) (vargs : list val) (vres : val) + (f : CminorSel.fundef), + eval_expr ge (Vptr sp Int.zero) nil e m a t1 m1 vf -> + transl_expr_correct (Vptr sp Int.zero) nil e m a t1 m1 vf -> + eval_exprlist ge (Vptr sp Int.zero) nil e m1 bl t2 m2 vargs -> + transl_exprlist_correct (Vptr sp Int.zero) nil e m1 bl t2 m2 vargs -> + Genv.find_funct ge vf = Some f -> + CminorSel.funsig f = sig -> + eval_funcall ge (free m2 sp) f vargs t3 m3 vres -> + transl_function_correct (free m2 sp) f vargs t3 m3 vres -> + t = t1 ** t2 ** t3 -> + transl_stmt_correct (Vptr sp Int.zero) e m (Stailcall sig a bl) + t e m3 (Out_tailcall_return vres). +Proof. + intros; red; intros; inv TE. + exploit H0; eauto. intros [rs1 [EX1 [ME1 [RES1 OTHER1]]]]. + exploit H2; eauto. intros [rs2 [EX2 [ME2 [RES2 OTHER2]]]]. + exploit functions_translated; eauto. intros [tf [TFIND TF]]. + exploit H6; eauto. intro EXF. + exists rs2; econstructor. + split. constructor. + split. + eapply star_trans. eexact EX1. + eapply star_trans. eexact EX2. + eapply star_step. + eapply exec_Itailcall; eauto. + simpl. rewrite OTHER2. rewrite RES1. eauto. simpl; tauto. + eapply sig_transl_function; eauto. + rewrite RES2. eexact EXF. + reflexivity. reflexivity. traceEq. + auto. Qed. (** The correctness of the translation then follows by application - of the mutual induction principle for Cminor evaluation derivations + of the mutual induction principle for CminorSel evaluation derivations to the lemmas above. *) -Scheme eval_expr_ind_5 := Minimality for eval_expr Sort Prop - with eval_condexpr_ind_5 := Minimality for eval_condexpr Sort Prop - with eval_exprlist_ind_5 := Minimality for eval_exprlist Sort Prop - with eval_funcall_ind_5 := Minimality for eval_funcall Sort Prop - with exec_stmt_ind_5 := Minimality for exec_stmt Sort Prop. - Theorem transl_function_correctness: forall m f vargs t m' vres, eval_funcall ge m f vargs t m' vres -> transl_function_correct m f vargs t m' vres. Proof - (eval_funcall_ind_5 ge + (eval_funcall_ind5 ge transl_expr_correct transl_condition_correct transl_exprlist_correct @@ -1339,26 +1318,35 @@ Proof transl_stmt_Sexit_correct transl_stmt_Sswitch_correct transl_stmt_Sreturn_none_correct - transl_stmt_Sreturn_some_correct). + transl_stmt_Sreturn_some_correct + transl_stmt_Stailcall_correct). + +Require Import Smallstep. + +(** The correctness of the translation follows: if the original CminorSel + program executes with trace [t] and exit code [r], then the generated + RTL program terminates with the same trace and exit code. *) Theorem transl_program_correct: - forall (t: trace) (r: val), - Cminor.exec_program prog t r -> - RTL.exec_program tprog t r. + forall (t: trace) (r: int), + CminorSel.exec_program prog t (Vint r) -> + RTL.exec_program tprog (Terminates t r). Proof. intros t r [b [f [m [SYMB [FUNC [SIG EVAL]]]]]]. generalize (function_ptr_translated _ _ FUNC). intros [tf [TFIND TRANSLF]]. - red; exists b; exists tf; exists m. - split. rewrite symbols_preserved. - replace (prog_main tprog) with (prog_main prog). - assumption. + exploit transl_function_correctness; eauto. intro EX. + econstructor. + econstructor. + rewrite symbols_preserved. + replace (prog_main tprog) with (prog_main prog). eauto. symmetry; apply transform_partial_program_main with transl_fundef. exact TRANSL. - split. exact TFIND. - split. generalize (sig_transl_function _ _ TRANSLF). congruence. + eexact TFIND. + generalize (sig_transl_function _ _ TRANSLF). congruence. unfold fundef; rewrite (Genv.init_mem_transf_partial transl_fundef prog TRANSL). - exact (transl_function_correctness _ _ _ _ _ _ EVAL _ TRANSLF). + eexact EX. + constructor. Qed. End CORRECTNESS. diff --git a/backend/RTLgenproof1.v b/backend/RTLgenproof1.v deleted file mode 100644 index 8e12e798..00000000 --- a/backend/RTLgenproof1.v +++ /dev/null @@ -1,1367 +0,0 @@ -(** Correctness proof for RTL generation: auxiliary results. *) - -Require Import Coqlib. -Require Import Maps. -Require Import AST. -Require Import Integers. -Require Import Values. -Require Import Events. -Require Import Mem. -Require Import Globalenvs. -Require Import Op. -Require Import Registers. -Require Import Cminor. -Require Import RTL. -Require Import RTLgen. - -(** * Reasoning about monadic computations *) - -(** The tactics below simplify hypotheses of the form [f ... = OK x s] - where [f] is a monadic computation. For instance, the hypothesis - [(do x <- a; b) s = OK y s'] will generate the additional witnesses - [x], [s1] and the additional hypotheses - [a s = OK x s1] and [b x s1 = OK y s'], reflecting the fact that - both monadic computations [a] and [b] succeeded. -*) - -Ltac monadSimpl1 := - match goal with - | [ |- (bind ?F ?G ?S = OK ?X ?S') -> _ ] => - unfold bind at 1; - generalize (refl_equal (F S)); - pattern (F S) at -1 in |- *; - case (F S); - [ intro; intro; discriminate - | (let s := fresh "s" in - (let EQ := fresh "EQ" in - (intro; intros s EQ; - try monadSimpl1))) ] - | [ |- (bind2 ?F ?G ?S = OK ?X ?S') -> _ ] => - unfold bind2 at 1; unfold bind at 1; - generalize (refl_equal (F S)); - pattern (F S) at -1 in |- *; - case (F S); - [ intro; intro; discriminate - | let xy := fresh "xy" in - (let x := fresh "x" in - (let y := fresh "y" in - (let s := fresh "s" in - (let EQ := fresh "EQ" in - (intros xy s EQ; destruct xy as [x y]; simpl; - try monadSimpl1))))) ] - | [ |- (error _ _ = OK _ _) -> _ ] => - unfold error; monadSimpl1 - | [ |- (ret _ _ = OK _ _) -> _ ] => - unfold ret; monadSimpl1 - | [ |- (Error _ = OK _ _) -> _ ] => - intro; discriminate - | [ |- (OK _ _ = OK _ _) -> _ ] => - let h := fresh "H" in - (intro h; injection h; intro; intro; clear h) - end. - -Ltac monadSimpl := - match goal with - | [ |- (bind ?F ?G ?S = OK ?X ?S') -> _ ] => monadSimpl1 - | [ |- (bind2 ?F ?G ?S = OK ?X ?S') -> _ ] => monadSimpl1 - | [ |- (error _ _ = OK _ _) -> _ ] => monadSimpl1 - | [ |- (ret _ _ = OK _ _) -> _ ] => monadSimpl1 - | [ |- (Error _ = OK _ _) -> _ ] => monadSimpl1 - | [ |- (OK _ _ = OK _ _) -> _ ] => monadSimpl1 - | [ |- (?F _ _ _ _ _ _ _ = OK _ _) -> _ ] => unfold F; monadSimpl1 - | [ |- (?F _ _ _ _ _ _ = OK _ _) -> _ ] => unfold F; monadSimpl1 - | [ |- (?F _ _ _ _ _ = OK _ _) -> _ ] => unfold F; monadSimpl1 - | [ |- (?F _ _ _ _ = OK _ _) -> _ ] => unfold F; monadSimpl1 - | [ |- (?F _ _ _ = OK _ _) -> _ ] => unfold F; monadSimpl1 - | [ |- (?F _ _ = OK _ _) -> _ ] => unfold F; monadSimpl1 - | [ |- (?F _ = OK _ _) -> _ ] => unfold F; monadSimpl1 - end. - -Ltac monadInv H := - generalize H; monadSimpl. - -(** * Monotonicity properties of the state *) - -(** Operations over the global state satisfy a crucial monotonicity property: - nodes are only added to the CFG, but never removed nor their instructions - changed; similarly, fresh nodes and fresh registers are only consumed, - but never reused. This property is captured by the following predicate - over states, which we show is a partial order. *) - -Inductive state_incr: state -> state -> Prop := - state_incr_intro: - forall (s1 s2: state), - Ple s1.(st_nextnode) s2.(st_nextnode) -> - Ple s1.(st_nextreg) s2.(st_nextreg) -> - (forall pc, Plt pc s1.(st_nextnode) -> s2.(st_code)!pc = s1.(st_code)!pc) -> - state_incr s1 s2. - -Lemma instr_at_incr: - forall s1 s2 n i, - s1.(st_code)!n = i -> i <> None -> state_incr s1 s2 -> - s2.(st_code)!n = i. -Proof. - intros. inversion H1. - rewrite <- H. apply H4. elim (st_wf s1 n); intro. - assumption. elim H0. congruence. -Qed. - -Lemma state_incr_refl: - forall s, state_incr s s. -Proof. - intros. apply state_incr_intro. - apply Ple_refl. apply Ple_refl. intros; auto. -Qed. -Hint Resolve state_incr_refl: rtlg. - -Lemma state_incr_trans: - forall s1 s2 s3, state_incr s1 s2 -> state_incr s2 s3 -> state_incr s1 s3. -Proof. - intros. inversion H. inversion H0. apply state_incr_intro. - apply Ple_trans with (st_nextnode s2); assumption. - apply Ple_trans with (st_nextreg s2); assumption. - intros. transitivity (s2.(st_code)!pc). - apply H8. apply Plt_Ple_trans with s1.(st_nextnode); auto. - apply H3; auto. -Qed. -Hint Resolve state_incr_trans: rtlg. - -Lemma state_incr_trans2: - forall s1 s2 s3 s4, - state_incr s1 s2 -> state_incr s2 s3 -> state_incr s3 s4 -> - state_incr s1 s4. -Proof. - intros; eauto with rtlg. -Qed. - -Lemma state_incr_trans3: - forall s1 s2 s3 s4 s5, - state_incr s1 s2 -> state_incr s2 s3 -> state_incr s3 s4 -> state_incr s4 s5 -> - state_incr s1 s5. -Proof. - intros; eauto with rtlg. -Qed. - -Lemma state_incr_trans4: - forall s1 s2 s3 s4 s5 s6, - state_incr s1 s2 -> state_incr s2 s3 -> state_incr s3 s4 -> - state_incr s4 s5 -> state_incr s5 s6 -> - state_incr s1 s6. -Proof. - intros; eauto with rtlg. -Qed. - -Lemma state_incr_trans5: - forall s1 s2 s3 s4 s5 s6 s7, - state_incr s1 s2 -> state_incr s2 s3 -> state_incr s3 s4 -> - state_incr s4 s5 -> state_incr s5 s6 -> state_incr s6 s7 -> - state_incr s1 s7. -Proof. - intros; eauto 6 with rtlg. -Qed. - -Lemma state_incr_trans6: - forall s1 s2 s3 s4 s5 s6 s7 s8, - state_incr s1 s2 -> state_incr s2 s3 -> state_incr s3 s4 -> - state_incr s4 s5 -> state_incr s5 s6 -> state_incr s6 s7 -> - state_incr s7 s8 -> state_incr s1 s8. -Proof. - intros; eauto 7 with rtlg. -Qed. - -(** The following relation between two states is a weaker version of - [state_incr]. It permits changing the contents at an already reserved - graph node, but only from [None] to [Some i]. *) - -Definition state_extends (s1 s2: state): Prop := - forall pc, - s1.(st_code)!pc = None \/ s2.(st_code)!pc = s1.(st_code)!pc. - -Lemma state_incr_extends: - forall s1 s2, - state_incr s1 s2 -> state_extends s1 s2. -Proof. - unfold state_extends; intros. inversion H. - case (plt pc s1.(st_nextnode)); intro. - right; apply H2; auto. - left. elim (s1.(st_wf) pc); intro. - elim (n H5). auto. -Qed. -Hint Resolve state_incr_extends. - -(** A crucial property of states is the following: if an RTL execution - is possible (does not get stuck) in the CFG of a given state [s1] - the same execution is possible and leads to the same results in - the CFG of any state [s2] that extends [s1] in the sense of the - [state_extends] predicate. *) - -Section EXEC_INSTR_EXTENDS. - -Variable s1 s2: state. -Hypothesis EXT: state_extends s1 s2. - -Lemma exec_instr_not_halt: - forall ge c sp pc rs m t pc' rs' m', - exec_instr ge c sp pc rs m t pc' rs' m' -> c!pc <> None. -Proof. - induction 1; rewrite H; discriminate. -Qed. - -Lemma exec_instr_in_s2: - forall ge sp pc rs m t pc' rs' m', - exec_instr ge s1.(st_code) sp pc rs m t pc' rs' m' -> - s2.(st_code)!pc = s1.(st_code)!pc. -Proof. - intros. - elim (EXT pc); intro. - elim (exec_instr_not_halt _ _ _ _ _ _ _ _ _ _ H H0). - assumption. -Qed. - -Lemma exec_instr_extends_rec: - forall ge c sp pc rs m t pc' rs' m', - exec_instr ge c sp pc rs m t pc' rs' m' -> - forall c', c!pc = c'!pc -> - exec_instr ge c' sp pc rs m t pc' rs' m'. -Proof. - induction 1; intros. - apply exec_Inop. congruence. - apply exec_Iop with op args. congruence. auto. - apply exec_Iload with chunk addr args a. congruence. auto. auto. - apply exec_Istore with chunk addr args src a. - congruence. auto. auto. - apply exec_Icall with sig ros args f; auto. congruence. - apply exec_Ialloc with arg sz; auto. congruence. - apply exec_Icond_true with cond args ifnot; auto. congruence. - apply exec_Icond_false with cond args ifso; auto. congruence. -Qed. - -Lemma exec_instr_extends: - forall ge sp pc rs m t pc' rs' m', - exec_instr ge s1.(st_code) sp pc rs m t pc' rs' m' -> - exec_instr ge s2.(st_code) sp pc rs m t pc' rs' m'. -Proof. - intros. - apply exec_instr_extends_rec with (st_code s1). - assumption. - symmetry. eapply exec_instr_in_s2. eexact H. -Qed. - -Lemma exec_instrs_extends_rec: - forall ge c sp pc rs m t pc' rs' m', - exec_instrs ge c sp pc rs m t pc' rs' m' -> - c = s1.(st_code) -> - exec_instrs ge s2.(st_code) sp pc rs m t pc' rs' m'. -Proof. - induction 1; intros. - apply exec_refl. - apply exec_one. apply exec_instr_extends; auto. rewrite <- H0; auto. - apply exec_trans with t1 pc2 rs2 m2 t2; auto. -Qed. - -Lemma exec_instrs_extends: - forall ge sp pc rs m t pc' rs' m', - exec_instrs ge s1.(st_code) sp pc rs m t pc' rs' m' -> - exec_instrs ge s2.(st_code) sp pc rs m t pc' rs' m'. -Proof. - intros. - apply exec_instrs_extends_rec with (st_code s1); auto. -Qed. - -End EXEC_INSTR_EXTENDS. - -(** Since [state_incr s1 s2] implies [state_extends s1 s2], we also have - that any RTL execution possible in the CFG of [s1] is also possible - in the CFG of [s2], provided that [state_incr s1 s2]. - In particular, any RTL execution that is possible in a partially - constructed CFG remains possible in the final CFG obtained at - the end of the translation of the current function. *) - -Section EXEC_INSTR_INCR. - -Variable s1 s2: state. -Hypothesis INCR: state_incr s1 s2. - -Lemma exec_instr_incr: - forall ge sp pc rs m t pc' rs' m', - exec_instr ge s1.(st_code) sp pc rs m t pc' rs' m' -> - exec_instr ge s2.(st_code) sp pc rs m t pc' rs' m'. -Proof. - intros. - apply exec_instr_extends with s1. - apply state_incr_extends; auto. - auto. -Qed. - -Lemma exec_instrs_incr: - forall ge sp pc rs m t pc' rs' m', - exec_instrs ge s1.(st_code) sp pc rs m t pc' rs' m' -> - exec_instrs ge s2.(st_code) sp pc rs m t pc' rs' m'. -Proof. - intros. - apply exec_instrs_extends with s1. - apply state_incr_extends; auto. - auto. -Qed. - -End EXEC_INSTR_INCR. - -(** * Validity and freshness of registers *) - -(** An RTL pseudo-register is valid in a given state if it was created - earlier, that is, it is less than the next fresh register of the state. - Otherwise, the pseudo-register is said to be fresh. *) - -Definition reg_valid (r: reg) (s: state) : Prop := - Plt r s.(st_nextreg). - -Definition reg_fresh (r: reg) (s: state) : Prop := - ~(Plt r s.(st_nextreg)). - -Lemma valid_fresh_absurd: - forall r s, reg_valid r s -> reg_fresh r s -> False. -Proof. - intros r s. unfold reg_valid, reg_fresh; case r; tauto. -Qed. -Hint Resolve valid_fresh_absurd: rtlg. - -Lemma valid_fresh_different: - forall r1 r2 s, reg_valid r1 s -> reg_fresh r2 s -> r1 <> r2. -Proof. - unfold not; intros. subst r2. eauto with rtlg. -Qed. -Hint Resolve valid_fresh_different: rtlg. - -Lemma reg_valid_incr: - forall r s1 s2, state_incr s1 s2 -> reg_valid r s1 -> reg_valid r s2. -Proof. - intros r s1 s2 INCR. - inversion INCR. - unfold reg_valid. intros; apply Plt_Ple_trans with (st_nextreg s1); auto. -Qed. -Hint Resolve reg_valid_incr: rtlg. - -Lemma reg_fresh_decr: - forall r s1 s2, state_incr s1 s2 -> reg_fresh r s2 -> reg_fresh r s1. -Proof. - intros r s1 s2 INCR. inversion INCR. - unfold reg_fresh; unfold not; intros. - apply H4. apply Plt_Ple_trans with (st_nextreg s1); auto. -Qed. -Hint Resolve reg_fresh_decr: rtlg. - -(** * Well-formedness of compilation environments *) - -(** A compilation environment (mapping) is well-formed in a given state if - the following properties hold: -- The registers associated with Cminor local variables and let-bound variables - are valid in the state. -- Two distinct Cminor local variables are mapped to distinct pseudo-registers. -- A Cminor local variable and a let-bound variable are mapped to - distinct pseudo-registers. -*) - -Record map_wf (m: mapping) (s: state) : Prop := - mk_map_wf { - map_wf_var_valid: - (forall id r, m.(map_vars)!id = Some r -> reg_valid r s); - map_wf_letvar_valid: - (forall r, In r m.(map_letvars) -> reg_valid r s); - map_wf_inj: - (forall id1 id2 r, - m.(map_vars)!id1 = Some r -> m.(map_vars)!id2 = Some r -> id1 = id2); - map_wf_disj: - (forall id r, - m.(map_vars)!id = Some r -> In r m.(map_letvars) -> False) - }. -Hint Resolve map_wf_var_valid - map_wf_letvar_valid - map_wf_inj map_wf_disj: rtlg. - -Lemma map_wf_incr: - forall s1 s2 m, - state_incr s1 s2 -> map_wf m s1 -> map_wf m s2. -Proof. - intros. apply mk_map_wf; intros; eauto with rtlg. -Qed. -Hint Resolve map_wf_incr: rtlg. - -(** A register is ``in'' a mapping if it is associated with a Cminor - local or let-bound variable. *) - -Definition reg_in_map (m: mapping) (r: reg) : Prop := - (exists id, m.(map_vars)!id = Some r) \/ In r m.(map_letvars). - -Lemma reg_in_map_valid: - forall m s r, - map_wf m s -> reg_in_map m r -> reg_valid r s. -Proof. - intros. elim H0. - intros [id EQ]. eauto with rtlg. - intro IN. eauto with rtlg. -Qed. -Hint Resolve reg_in_map_valid: rtlg. - -(** * Properties of basic operations over the state *) - -(** Properties of [add_instr]. *) - -Lemma add_instr_incr: - forall s1 s2 i n, - add_instr i s1 = OK n s2 -> state_incr s1 s2. -Proof. - intros until n; monadSimpl. - subst s2; apply state_incr_intro; simpl. - apply Ple_succ. - apply Ple_refl. - intros. apply PTree.gso; apply Plt_ne; auto. -Qed. -Hint Resolve add_instr_incr: rtlg. - -Lemma add_instr_at: - forall s1 s2 i n, - add_instr i s1 = OK n s2 -> s2.(st_code)!n = Some i. -Proof. - intros until n; monadSimpl. - subst n; subst s2; simpl. apply PTree.gss. -Qed. -Hint Resolve add_instr_at. - -(** Properties of [reserve_instr] and [update_instr]. *) - -Lemma reserve_instr_incr: - forall s1 s2 n, - reserve_instr s1 = OK n s2 -> state_incr s1 s2. -Proof. - intros until n; monadSimpl. subst s2. - apply state_incr_intro; simpl. - apply Ple_succ. - apply Ple_refl. - auto. -Qed. - -Lemma update_instr_incr: - forall s1 s2 s3 s4 i n t, - reserve_instr s1 = OK n s2 -> - state_incr s2 s3 -> - update_instr n i s3 = OK t s4 -> - state_incr s1 s4. -Proof. - intros. - monadInv H. - generalize H1; unfold update_instr. - case (plt n (st_nextnode s3)); intro. - monadSimpl. inversion H0. - subst s4; apply state_incr_intro; simpl. - apply Plt_Ple. apply Plt_Ple_trans with (st_nextnode s2). - subst s2; simpl; apply Plt_succ. assumption. - rewrite <- H3 in H7; simpl in H7. assumption. - intros. rewrite PTree.gso. - rewrite <- H3 in H8; simpl in H8. apply H8. - apply Plt_trans_succ; assumption. - subst n; apply Plt_ne; assumption. - intros; discriminate. -Qed. - -Lemma update_instr_extends: - forall s1 s2 s3 s4 i n t, - reserve_instr s1 = OK n s2 -> - state_incr s2 s3 -> - update_instr n i s3 = OK t s4 -> - state_extends s3 s4. -Proof. - intros. - monadInv H. - red; intros. - case (peq pc n); intro. - subst pc. left. inversion H0. rewrite H6. - rewrite <- H3; simpl. - elim (s1.(st_wf) n); intro. - rewrite <- H4 in H9. elim (Plt_strict _ H9). - auto. - rewrite <- H4. rewrite <- H3; simpl. apply Plt_succ. - generalize H1; unfold update_instr. - case (plt n s3.(st_nextnode)); intro; monadSimpl. - right; rewrite <- H5; simpl. apply PTree.gso; auto. -Qed. - -(** Properties of [new_reg]. *) - -Lemma new_reg_incr: - forall s1 s2 r, new_reg s1 = OK r s2 -> state_incr s1 s2. -Proof. - intros until r. monadSimpl. - subst s2; apply state_incr_intro; simpl. - apply Ple_refl. apply Ple_succ. auto. -Qed. -Hint Resolve new_reg_incr: rtlg. - -Lemma new_reg_valid: - forall s1 s2 r, - new_reg s1 = OK r s2 -> reg_valid r s2. -Proof. - intros until r. monadSimpl. subst s2; subst r. - unfold reg_valid; unfold reg_valid; simpl. - apply Plt_succ. -Qed. -Hint Resolve new_reg_valid: rtlg. - -Lemma new_reg_fresh: - forall s1 s2 r, - new_reg s1 = OK r s2 -> reg_fresh r s1. -Proof. - intros until r. monadSimpl. subst s2; subst r. - unfold reg_fresh; simpl. - exact (Plt_strict _). -Qed. -Hint Resolve new_reg_fresh: rtlg. - -Lemma new_reg_not_in_map: - forall s1 s2 m r, - new_reg s1 = OK r s2 -> map_wf m s1 -> ~(reg_in_map m r). -Proof. - unfold not; intros; eauto with rtlg. -Qed. -Hint Resolve new_reg_not_in_map: rtlg. - -(** * Properties of operations over compilation environments *) - -Lemma init_mapping_wf: - forall s, map_wf init_mapping s. -Proof. - intro. unfold init_mapping; apply mk_map_wf; simpl; intros. - rewrite PTree.gempty in H; discriminate. - contradiction. - rewrite PTree.gempty in H; discriminate. - tauto. -Qed. - -(** Properties of [find_var]. *) - -Lemma find_var_incr: - forall s1 s2 map name r, - find_var map name s1 = OK r s2 -> state_incr s1 s2. -Proof. - intros until r. unfold find_var. - case (map_vars map)!name. - intro; monadSimpl. subst s2; auto with rtlg. - monadSimpl. -Qed. -Hint Resolve find_var_incr: rtlg. - -Lemma find_var_in_map: - forall s1 s2 map name r, - find_var map name s1 = OK r s2 -> map_wf map s1 -> reg_in_map map r. -Proof. - intros until r. unfold find_var; caseEq (map.(map_vars)!name). - intros r0 eq. monadSimpl; intros. subst r0. - left. exists name; auto. - intro; monadSimpl. -Qed. -Hint Resolve find_var_in_map: rtlg. - -Lemma find_var_valid: - forall s1 s2 map name r, - find_var map name s1 = OK r s2 -> map_wf map s1 -> reg_valid r s1. -Proof. - eauto with rtlg. -Qed. -Hint Resolve find_var_valid: rtlg. - - -(** Properties of [find_letvar]. *) - -Lemma find_letvar_incr: - forall s1 s2 map idx r, - find_letvar map idx s1 = OK r s2 -> state_incr s1 s2. -Proof. - intros until r. unfold find_letvar. - case (nth_error (map_letvars map) idx). - intro; monadSimpl. subst s2; auto with rtlg. - monadSimpl. -Qed. -Hint Resolve find_letvar_incr: rtlg. - -Lemma find_letvar_in_map: - forall s1 s2 map idx r, - find_letvar map idx s1 = OK r s2 -> map_wf map s1 -> reg_in_map map r. -Proof. - intros until r. unfold find_letvar. - caseEq (nth_error (map_letvars map) idx). - intros r0 EQ; monadSimpl. intros. right. - subst r0; apply nth_error_in with idx; auto. - intro; monadSimpl. -Qed. -Hint Resolve find_letvar_in_map: rtlg. - -Lemma find_letvar_valid: - forall s1 s2 map idx r, - find_letvar map idx s1 = OK r s2 -> map_wf map s1 -> reg_valid r s1. -Proof. - eauto with rtlg. -Qed. -Hint Resolve find_letvar_valid: rtlg. - -(** Properties of [add_var]. *) - -Lemma add_var_valid: - forall s1 s2 map1 map2 name r, - add_var map1 name s1 = OK (r, map2) s2 -> reg_valid r s2. -Proof. - intros until r. monadSimpl. intro. subst r0; subst s. - eauto with rtlg. -Qed. - -Lemma add_var_incr: - forall s1 s2 map name rm, - add_var map name s1 = OK rm s2 -> state_incr s1 s2. -Proof. - intros until rm; monadSimpl. subst s2. eauto with rtlg. -Qed. -Hint Resolve add_var_incr: rtlg. - -Lemma add_var_wf: - forall s1 s2 map name r map', - add_var map name s1 = OK (r,map') s2 -> map_wf map s1 -> map_wf map' s2. -Proof. - intros until map'; monadSimpl; intros. - subst r0; subst s; subst map'; apply mk_map_wf; simpl. - - intros id r'. rewrite PTree.gsspec. - case (peq id name); intros. - injection H; intros; subst r'. eauto with rtlg. - eauto with rtlg. - eauto with rtlg. - - intros id1 id2 r'. - repeat (rewrite PTree.gsspec). - case (peq id1 name); case (peq id2 name); intros. - congruence. - rewrite <- H in H0. byContradiction; eauto with rtlg. - rewrite <- H0 in H. byContradiction; eauto with rtlg. - eauto with rtlg. - - intros id r'. case (peq id name); intro. - subst id. rewrite PTree.gss. intro E; injection E; intro; subst r'. - intro; eauto with rtlg. - - rewrite PTree.gso; auto. eauto with rtlg. -Qed. -Hint Resolve add_var_wf: rtlg. - -Lemma add_var_find: - forall s1 s2 map name r map', - add_var map name s1 = OK (r,map') s2 -> map'.(map_vars)!name = Some r. -Proof. - intros until map'. - monadSimpl. - intro; subst r0. - subst map'; simpl in |- *. - apply PTree.gss. -Qed. - -Lemma add_vars_incr: - forall names s1 s2 map r, - add_vars map names s1 = OK r s2 -> state_incr s1 s2. -Proof. - induction names; simpl. - intros until r; monadSimpl; intros. subst s2; eauto with rtlg. - intros until r; monadSimpl; intros. - subst s0; eauto with rtlg. -Qed. - -Lemma add_vars_valid: - forall namel s1 s2 map1 map2 rl, - add_vars map1 namel s1 = OK (rl, map2) s2 -> - forall r, In r rl -> reg_valid r s2. -Proof. - induction namel; simpl; intros. - monadInv H. intro. subst rl. elim H0. - monadInv H. intro EQ1. subst rl; subst s0; subst y0. elim H0. - intro; subst r. eapply add_var_valid. eexact EQ0. - intro. apply reg_valid_incr with s. eauto with rtlg. - eauto. -Qed. - -Lemma add_vars_wf: - forall names s1 s2 map map' rl, - add_vars map names s1 = OK (rl,map') s2 -> - map_wf map s1 -> map_wf map' s2. -Proof. - induction names; simpl. - intros until rl; monadSimpl; intros. - subst s2; subst map'; assumption. - intros until rl; monadSimpl; intros. subst y0; subst s0. - eapply add_var_wf. eexact EQ0. - eapply IHnames. eexact EQ. auto. -Qed. -Hint Resolve add_vars_wf: rtlg. - -Lemma add_var_letenv: - forall map1 i s1 r map2 s2, - add_var map1 i s1 = OK (r, map2) s2 -> - map2.(map_letvars) = map1.(map_letvars). -Proof. - intros until s2. monadSimpl. intro. subst map2; reflexivity. -Qed. - -(** Properties of [add_letvar]. *) - -Lemma add_letvar_wf: - forall map s r, - map_wf map s -> - reg_valid r s -> - ~(reg_in_map map r) -> - map_wf (add_letvar map r) s. -Proof. - intros. unfold add_letvar; apply mk_map_wf; simpl. - exact (map_wf_var_valid map s H). - intros r' [EQ| IN]. - subst r'; assumption. - eapply map_wf_letvar_valid; eauto. - exact (map_wf_inj map s H). - intros. elim H3; intro. - subst r0. apply H1. left. exists id; auto. - eapply map_wf_disj; eauto. -Qed. - -(** * Properties of [alloc_reg] and [alloc_regs] *) - -Lemma alloc_reg_incr: - forall a s1 s2 map r, - alloc_reg map a s1 = OK r s2 -> state_incr s1 s2. -Proof. - intros until r. unfold alloc_reg. - case a; eauto with rtlg. -Qed. -Hint Resolve alloc_reg_incr: rtlg. - -Lemma alloc_reg_valid: - forall a s1 s2 map r, - map_wf map s1 -> - alloc_reg map a s1 = OK r s2 -> reg_valid r s2. -Proof. - intros until r. unfold alloc_reg. - case a; eauto with rtlg. -Qed. -Hint Resolve alloc_reg_valid: rtlg. - -Lemma alloc_reg_fresh_or_in_map: - forall map a s r s', - map_wf map s -> - alloc_reg map a s = OK r s' -> - reg_in_map map r \/ reg_fresh r s. -Proof. - intros until s'. unfold alloc_reg. - destruct a; intros; try (right; eauto with rtlg; fail). - left; eauto with rtlg. - left; eauto with rtlg. -Qed. - -Lemma add_vars_letenv: - forall il map1 s1 rl map2 s2, - add_vars map1 il s1 = OK (rl, map2) s2 -> - map2.(map_letvars) = map1.(map_letvars). -Proof. - induction il; simpl; intros. - monadInv H. intro. subst map2; reflexivity. - monadInv H. intro EQ1. transitivity (map_letvars y). - subst y0. eapply add_var_letenv; eauto. - eauto. -Qed. - -(** A register is an adequate target for holding the value of an - expression if -- either the register is associated with a Cminor let-bound variable - or a Cminor local variable; -- or the register is valid and not associated with any Cminor variable. *) - -Inductive target_reg_ok: state -> mapping -> expr -> reg -> Prop := - | target_reg_var: - forall s map id r, - map.(map_vars)!id = Some r -> - target_reg_ok s map (Evar id) r - | target_reg_letvar: - forall s map idx r, - nth_error map.(map_letvars) idx = Some r -> - target_reg_ok s map (Eletvar idx) r - | target_reg_other: - forall s map a r, - ~(reg_in_map map r) -> - reg_valid r s -> - target_reg_ok s map a r. - -Lemma target_reg_ok_incr: - forall s1 s2 map e r, - state_incr s1 s2 -> - target_reg_ok s1 map e r -> - target_reg_ok s2 map e r. -Proof. - intros. inversion H0. - apply target_reg_var; auto. - apply target_reg_letvar; auto. - apply target_reg_other; eauto with rtlg. -Qed. -Hint Resolve target_reg_ok_incr: rtlg. - -Lemma target_reg_valid: - forall s map e r, - map_wf map s -> - target_reg_ok s map e r -> - reg_valid r s. -Proof. - intros. inversion H0; eauto with rtlg coqlib. -Qed. -Hint Resolve target_reg_valid: rtlg. - -Lemma alloc_reg_target_ok: - forall a s1 s2 map r, - map_wf map s1 -> - alloc_reg map a s1 = OK r s2 -> - target_reg_ok s2 map a r. -Proof. - intros until r; intro MWF. unfold alloc_reg. - case a; intros; try (eapply target_reg_other; eauto with rtlg; fail). - apply target_reg_var. - generalize H; unfold find_var. - case (map_vars map)!i. - intro. monadSimpl. congruence. - monadSimpl. - apply target_reg_letvar. - generalize H. unfold find_letvar. - case (nth_error (map_letvars map) n). - intro; monadSimpl; congruence. - monadSimpl. -Qed. -Hint Resolve alloc_reg_target_ok: rtlg. - -Lemma alloc_regs_incr: - forall al s1 s2 map rl, - alloc_regs map al s1 = OK rl s2 -> state_incr s1 s2. -Proof. - induction al; simpl; intros. - monadInv H. subst s2. eauto with rtlg. - monadInv H. subst s2. eauto with rtlg. -Qed. -Hint Resolve alloc_regs_incr: rtlg. - -Lemma alloc_regs_valid: - forall al s1 s2 map rl, - map_wf map s1 -> - alloc_regs map al s1 = OK rl s2 -> - forall r, In r rl -> reg_valid r s2. -Proof. - induction al; simpl; intros. - monadInv H0. subst rl. elim H1. - monadInv H0. subst rl; subst s0. - elim H1; intro. - subst r0. eauto with rtlg. - eauto with rtlg. -Qed. -Hint Resolve alloc_regs_valid: rtlg. - -Lemma alloc_regs_fresh_or_in_map: - forall map al s rl s', - map_wf map s -> - alloc_regs map al s = OK rl s' -> - forall r, In r rl -> reg_in_map map r \/ reg_fresh r s. -Proof. - induction al; simpl; intros. - monadInv H0. subst rl. elim H1. - monadInv H0. subst rl. elim (in_inv H1); intro. - subst r. - assert (MWF: map_wf map s0). eauto with rtlg. - elim (alloc_reg_fresh_or_in_map map e s0 r0 s1 MWF EQ0); intro. - left; assumption. right; eauto with rtlg. - eauto with rtlg. -Qed. - -Inductive target_regs_ok: state -> mapping -> exprlist -> list reg -> Prop := - | target_regs_nil: - forall s map, - target_regs_ok s map Enil nil - | target_regs_cons: - forall s map a r al rl, - reg_in_map map r \/ ~(In r rl) -> - target_reg_ok s map a r -> - target_regs_ok s map al rl -> - target_regs_ok s map (Econs a al) (r :: rl). - -Lemma target_regs_ok_incr: - forall s1 map al rl, - target_regs_ok s1 map al rl -> - forall s2, - state_incr s1 s2 -> - target_regs_ok s2 map al rl. -Proof. - induction 1; intros. - apply target_regs_nil. - apply target_regs_cons; eauto with rtlg. -Qed. -Hint Resolve target_regs_ok_incr: rtlg. - -Lemma target_regs_valid: - forall s map al rl, - target_regs_ok s map al rl -> - map_wf map s -> - forall r, In r rl -> reg_valid r s. -Proof. - induction 1; simpl; intros. - contradiction. - elim H3; intro. - subst r0. eauto with rtlg. - auto. -Qed. -Hint Resolve target_regs_valid: rtlg. - -Lemma alloc_regs_target_ok: - forall al s1 s2 map rl, - map_wf map s1 -> - alloc_regs map al s1 = OK rl s2 -> - target_regs_ok s2 map al rl. -Proof. - induction al; simpl; intros. - monadInv H0. subst rl; apply target_regs_nil. - monadInv H0. subst s0; subst rl. - apply target_regs_cons; eauto 6 with rtlg. - assert (MWF: map_wf map s). eauto with rtlg. - elim (alloc_reg_fresh_or_in_map map e s r s2 MWF EQ0); intro. - left; assumption. right; red; intro; eauto with rtlg. -Qed. -Hint Resolve alloc_regs_target_ok: rtlg. - -(** The following predicate is a variant of [target_reg_ok] used - to characterize registers that are adequate for holding the return - value of a function. *) - -Inductive return_reg_ok: state -> mapping -> option reg -> Prop := - | return_reg_ok_none: - forall s map, - return_reg_ok s map None - | return_reg_ok_some: - forall s map r, - ~(reg_in_map map r) -> reg_valid r s -> - return_reg_ok s map (Some r). - -Lemma return_reg_ok_incr: - forall s1 s2 map or, - state_incr s1 s2 -> - return_reg_ok s1 map or -> - return_reg_ok s2 map or. -Proof. - intros. inversion H0; constructor. - assumption. eauto with rtlg. -Qed. -Hint Resolve return_reg_ok_incr: rtlg. - -Lemma new_reg_return_ok: - forall s1 r s2 map sig, - new_reg s1 = OK r s2 -> - map_wf map s1 -> - return_reg_ok s2 map (ret_reg sig r). -Proof. - intros. unfold ret_reg. destruct (sig_res sig); constructor. - eauto with rtlg. eauto with rtlg. -Qed. - -(** * Correspondence between Cminor environments and RTL register sets *) - -(** An RTL register environment matches a Cminor local environment and - let-environment if the value of every local or let-bound variable in - the Cminor environments is identical to the value of the - corresponding pseudo-register in the RTL register environment. *) - -Record match_env - (map: mapping) (e: Cminor.env) (le: Cminor.letenv) (rs: regset) : Prop := - mk_match_env { - me_vars: - (forall id v, - e!id = Some v -> exists r, map.(map_vars)!id = Some r /\ rs#r = v); - me_letvars: - rs##(map.(map_letvars)) = le - }. - -Lemma match_env_find_reg: - forall map id s1 s2 r e le rs v, - find_var map id s1 = OK r s2 -> - match_env map e le rs -> - e!id = Some v -> - rs#r = v. -Proof. - intros until v. - unfold find_var. caseEq (map.(map_vars)!id). - intros r' EQ. monadSimpl. subst r'. intros. - generalize (me_vars _ _ _ _ H _ _ H1). intros [r' [EQ' RS]]. - rewrite EQ' in EQ; injection EQ; intro; subst r'. - assumption. - intro; monadSimpl. -Qed. -Hint Resolve match_env_find_reg: rtlg. - -Lemma match_env_invariant: - forall map e le rs rs', - match_env map e le rs -> - (forall r, (reg_in_map map r) -> rs'#r = rs#r) -> - match_env map e le rs'. -Proof. - intros. apply mk_match_env. - intros id v' E. - generalize (me_vars _ _ _ _ H _ _ E). intros (r', (M, R)). - exists r'. split. auto. rewrite <- R. apply H0. - left. exists id. auto. - transitivity rs ## (map_letvars map). - apply list_map_exten. intros. - symmetry. apply H0. right. auto. - exact (me_letvars _ _ _ _ H). -Qed. - -(** Matching between environments is preserved when an unmapped register - (not corresponding to any Cminor variable) is assigned in the RTL - execution. *) - -Lemma match_env_update_temp: - forall map e le rs r v, - match_env map e le rs -> - ~(reg_in_map map r) -> - match_env map e le (rs#r <- v). -Proof. - intros. apply match_env_invariant with rs; auto. - intros. case (Reg.eq r r0); intro. - subst r0; contradiction. - apply Regmap.gso; auto. -Qed. -Hint Resolve match_env_update_temp: rtlg. - -(** Matching between environments is preserved by simultaneous - assignment to a Cminor local variable (in the Cminor environments) - and to the corresponding RTL pseudo-register (in the RTL register - environment). *) - -Lemma match_env_update_var: - forall map e le rs rs' id r v s s', - map_wf map s -> - find_var map id s = OK r s' -> - match_env map e le rs -> - rs'#r = v -> - (forall x, x <> r -> rs'#x = rs#x) -> - match_env map (PTree.set id v e) le rs'. -Proof. - intros until s'; intro MWF. - unfold find_var in |- *. caseEq (map_vars map)!id. - intros. monadInv H0. subst r0. apply mk_match_env. - intros id' v' E. case (peq id' id); intros. - subst id'. rewrite PTree.gss in E. injection E; intro; subst v'. - exists r. split. auto. auto. - rewrite PTree.gso in E; auto. - elim (me_vars _ _ _ _ H1 _ _ E). intros r' (M, R). - exists r'. split. assumption. rewrite <- R; apply H3; auto. - red in |- *; intro. subst r'. apply n. eauto with rtlg. - transitivity rs ## (map_letvars map). - apply list_map_exten. intros. symmetry. apply H3. - red in |- *; intro. subst x. eauto with rtlg. - exact (me_letvars _ _ _ _ H1). - intro; monadSimpl. -Qed. - -Lemma match_env_letvar: - forall map e le rs r v, - match_env map e le rs -> - rs#r = v -> - match_env (add_letvar map r) e (v :: le) rs. -Proof. - intros. unfold add_letvar in |- *; apply mk_match_env; simpl in |- *. - exact (me_vars _ _ _ _ H). - rewrite H0. rewrite (me_letvars _ _ _ _ H). auto. -Qed. - -Lemma match_env_exten: - forall map e le rs1 rs2, - (forall r, rs2#r = rs1#r) -> - match_env map e le rs1 -> - match_env map e le rs2. -Proof. - intros. apply mk_match_env. - intros. generalize (me_vars _ _ _ _ H0 _ _ H1). intros (r, (M1, M2)). - exists r. split. assumption. subst v. apply H. - transitivity rs1 ## (map_letvars map). - apply list_map_exten. intros. symmetry in |- *. apply H. - exact (me_letvars _ _ _ _ H0). -Qed. - -Lemma match_env_empty: - forall map, - map.(map_letvars) = nil -> - match_env map (PTree.empty val) nil (Regmap.init Vundef). -Proof. - intros. apply mk_match_env. - intros. rewrite PTree.gempty in H0. discriminate. - rewrite H. reflexivity. -Qed. - -(** The assignment of function arguments to local variables (on the Cminor - side) and pseudo-registers (on the RTL side) preserves matching - between environments. *) - -Lemma match_set_params_init_regs: - forall il rl s1 map2 s2 vl, - add_vars init_mapping il s1 = OK (rl, map2) s2 -> - match_env map2 (set_params vl il) nil (init_regs vl rl) - /\ (forall r, reg_fresh r s2 -> (init_regs vl rl)#r = Vundef). -Proof. - induction il; simpl in |- *; intros. - - monadInv H. intro; subst rl; simpl in |- *. - split. apply match_env_empty. subst map2; auto. - intros. apply Regmap.gi. - - monadInv H. intro EQ1; subst s0; subst y0; subst rl. clear H. - monadInv EQ0. intro EQ2. subst x0; subst s0. simpl. - - assert (LV : map_letvars map2 = nil). - transitivity (map_letvars y). - eapply add_var_letenv; eauto. - transitivity (map_letvars init_mapping). - eapply add_vars_letenv; eauto. - reflexivity. - - destruct vl. - (* vl = nil *) - generalize (IHil _ _ _ _ nil EQ). intros [ME UNDEF]. split. - constructor. intros id v. subst map2. simpl. - repeat rewrite PTree.gsspec; case (peq id a); intros. - exists r; split. auto. rewrite Regmap.gi. congruence. - destruct (me_vars _ _ _ _ ME id v H) as (r', (MV, IR)). - exists r'. split. auto. - replace (init_regs nil x) with (Regmap.init Vundef) in IR. auto. - destruct x; reflexivity. - rewrite LV; reflexivity. - intros. apply Regmap.gi. - (* vl = v :: vl *) - generalize (IHil _ _ _ _ vl EQ). intros [ME UNDEF]. split. - constructor. intros id v1. subst map2. simpl. - repeat rewrite PTree.gsspec; case (peq id a); intros. - exists r; split. auto. rewrite Regmap.gss. congruence. - destruct (me_vars _ _ _ _ ME id v1 H) as (r', (MV, IR)). - exists r'. split. auto. rewrite Regmap.gso. auto. - apply valid_fresh_different with s. - assert (MWF : map_wf y s). - eapply add_vars_wf; eauto. apply init_mapping_wf. - eauto with rtlg. eauto with rtlg. - rewrite LV; reflexivity. - intros. rewrite Regmap.gso. apply UNDEF. eauto with rtlg. - apply sym_not_equal. eauto with rtlg. -Qed. - -Lemma match_set_locals: - forall map1 s1, - map_wf map1 s1 -> - forall il rl map2 s2 e le rs, - match_env map1 e le rs -> - (forall r, reg_fresh r s1 -> rs#r = Vundef) -> - add_vars map1 il s1 = OK (rl, map2) s2 -> - match_env map2 (set_locals il e) le rs. -Proof. - induction il; simpl in *; intros. - - monadInv H2. intros; subst map2; auto. - - monadInv H2. intros. subst s0; subst y0. - assert (match_env y (set_locals il e) le rs). - eapply IHil; eauto. - monadInv EQ0. intro. subst s0; subst x0. rewrite <- H7. - constructor. - intros id v. simpl. repeat rewrite PTree.gsspec. - case (peq id a); intros. - exists r. split. auto. injection H5; intro; subst v. - apply H1. apply reg_fresh_decr with s. - eapply add_vars_incr; eauto. - eauto with rtlg. - eapply me_vars; eauto. - simpl. eapply me_letvars; eauto. -Qed. - -Lemma match_init_env_init_reg: - forall params s0 rparams map1 s1 vars rvars map2 s2 vparams, - add_vars init_mapping params s0 = OK (rparams, map1) s1 -> - add_vars map1 vars s1 = OK (rvars, map2) s2 -> - match_env map2 (set_locals vars (set_params vparams params)) - nil (init_regs vparams rparams). -Proof. - intros. - generalize (match_set_params_init_regs _ _ _ _ _ vparams H). - intros [A B]. - eapply match_set_locals; eauto. - eapply add_vars_wf; eauto. apply init_mapping_wf. -Qed. - -(** * Monotonicity properties of the state for the translation functions *) - -(** We show that the translation functions modify the state monotonically - (in the sense of the [state_incr] relation). *) - -Lemma add_move_incr: - forall r1 r2 nd s ns s', - add_move r1 r2 nd s = OK ns s' -> - state_incr s s'. -Proof. - intros until s'. unfold add_move. - case (Reg.eq r1 r2); intro. - monadSimpl. subst s'; auto with rtlg. - intro; eauto with rtlg. -Qed. -Hint Resolve add_move_incr: rtlg. - -Scheme expr_ind3 := Induction for expr Sort Prop - with condexpr_ind3 := Induction for condexpr Sort Prop - with exprlist_ind3 := Induction for exprlist Sort Prop. - -Lemma expr_condexpr_exprlist_ind: -forall (P : expr -> Prop) (P0 : condexpr -> Prop) - (P1 : exprlist -> Prop), - (forall i : ident, P (Evar i)) -> - (forall (o : operation) (e : exprlist), P1 e -> P (Eop o e)) -> - (forall (m : memory_chunk) (a : addressing) (e : exprlist), - P1 e -> P (Eload m a e)) -> - (forall (m : memory_chunk) (a : addressing) (e : exprlist), - P1 e -> forall e0 : expr, P e0 -> P (Estore m a e e0)) -> - (forall (s : signature) (e : expr), - P e -> forall e0 : exprlist, P1 e0 -> P (Ecall s e e0)) -> - (forall c : condexpr, - P0 c -> - forall e : expr, - P e -> forall e0 : expr, P e0 -> P (Econdition c e e0)) -> - (forall e : expr, P e -> forall e0 : expr, P e0 -> P (Elet e e0)) -> - (forall n : nat, P (Eletvar n)) -> - (forall e : expr, P e -> P (Ealloc e)) -> - P0 CEtrue -> - P0 CEfalse -> - (forall (c : condition) (e : exprlist), P1 e -> P0 (CEcond c e)) -> - (forall c : condexpr, - P0 c -> - forall c0 : condexpr, - P0 c0 -> forall c1 : condexpr, P0 c1 -> P0 (CEcondition c c0 c1)) -> - P1 Enil -> - (forall e : expr, - P e -> forall e0 : exprlist, P1 e0 -> P1 (Econs e e0)) -> - (forall e : expr, P e) /\ - (forall ce : condexpr, P0 ce) /\ - (forall el : exprlist, P1 el). -Proof. - intros. split. apply (expr_ind3 P P0 P1); assumption. - split. apply (condexpr_ind3 P P0 P1); assumption. - apply (exprlist_ind3 P P0 P1); assumption. -Qed. - -Definition transl_expr_incr_pred (a: expr) : Prop := - forall map rd nd s ns s', - transl_expr map a rd nd s = OK ns s' -> state_incr s s'. -Definition transl_condition_incr_pred (c: condexpr) : Prop := - forall map ntrue nfalse s ns s', - transl_condition map c ntrue nfalse s = OK ns s' -> state_incr s s'. -Definition transl_exprlist_incr_pred (al: exprlist) : Prop := - forall map rl nd s ns s', - transl_exprlist map al rl nd s = OK ns s' -> state_incr s s'. - -Lemma transl_expr_condition_exprlist_incr: - (forall a, transl_expr_incr_pred a) /\ - (forall c, transl_condition_incr_pred c) /\ - (forall al, transl_exprlist_incr_pred al). -Proof. - apply expr_condexpr_exprlist_ind; - unfold transl_expr_incr_pred, - transl_condition_incr_pred, - transl_exprlist_incr_pred; - simpl; intros; - try (monadInv H); try (monadInv H0); - try (monadInv H1); try (monadInv H2); - eauto 6 with rtlg. - - intro EQ2. - apply state_incr_trans3 with s0 s1 s2; eauto with rtlg. - - intro EQ4. - apply state_incr_trans4 with s1 s2 s3 s4; eauto with rtlg. - - subst s'; auto with rtlg. - subst s'; auto with rtlg. - destruct rl; monadInv H. subst s'; auto with rtlg. - destruct rl; monadInv H1. eauto with rtlg. -Qed. - -Lemma transl_expr_incr: - forall a map rd nd s ns s', - transl_expr map a rd nd s = OK ns s' -> state_incr s s'. -Proof (proj1 transl_expr_condition_exprlist_incr). - -Lemma transl_condition_incr: - forall a map ntrue nfalse s ns s', - transl_condition map a ntrue nfalse s = OK ns s' -> state_incr s s'. -Proof (proj1 (proj2 transl_expr_condition_exprlist_incr)). - -Lemma transl_exprlist_incr: - forall al map rl nd s ns s', - transl_exprlist map al rl nd s = OK ns s' -> state_incr s s'. -Proof (proj2 (proj2 transl_expr_condition_exprlist_incr)). - -Hint Resolve transl_expr_incr transl_condition_incr transl_exprlist_incr: rtlg. - -Lemma transl_exit_incr: - forall nexits n s ns s', - transl_exit nexits n s = OK ns s' -> - state_incr s s'. -Proof. - intros until s'. unfold transl_exit. - destruct (nth_error nexits n); intros; simplify_eq H; intros; subst s'. - auto with rtlg. -Qed. - -Hint Resolve transl_exit_incr: rtlg. - -Lemma transl_switch_incr: - forall r nexits default cases s n s', - transl_switch r nexits cases default s = OK n s' -> - state_incr s s'. -Proof. - induction cases; simpl; intros. - eauto with rtlg. - destruct a as [key1 exit1]. - monadInv H. intros EQ2. - apply state_incr_trans with s0. eauto. - eauto with rtlg. -Qed. - -Hint Resolve transl_switch_incr: rtlg. - -Lemma transl_stmt_incr: - forall a map nd nexits nret rret s ns s', - transl_stmt map a nd nexits nret rret s = OK ns s' -> - state_incr s s'. -Proof. - induction a; simpl; intros. - - monadInv H. subst s'. auto with rtlg. - - monadInv H. eauto with rtlg. - - monadInv H. intro. apply state_incr_trans3 with s0 s1 s2; eauto with rtlg. - - monadInv H. eauto with rtlg. - - generalize H. case (more_likely c a1 a2); monadSimpl; eauto 6 with rtlg. - - monadInv H. subst s'. - apply update_instr_incr with s0 s1 (Inop n0) n u; eauto with rtlg. - - eauto. - - eauto with rtlg. - - monadInv H. eauto 6 with rtlg. - - generalize H. destruct o; destruct rret; try monadSimpl. - eauto with rtlg. - subst s'; auto with rtlg. -Qed. - -Hint Resolve transl_stmt_incr: rtlg. - diff --git a/backend/RTLgenspec.v b/backend/RTLgenspec.v new file mode 100644 index 00000000..c46bdbba --- /dev/null +++ b/backend/RTLgenspec.v @@ -0,0 +1,1455 @@ +(** Abstract specification of RTL generation *) + +(** In this module, we define inductive predicates that specify the + translations from Cminor to RTL performed by the functions in module + [RTLgen]. We then show that these functions satisfy these relational + specifications. The relational specifications will then be used + instead of the actual functions to show semantic equivalence between + the source Cminor code and the the generated RTL code + (see module [RTLgenproof]). *) + +Require Import Coqlib. +Require Errors. +Require Import Maps. +Require Import AST. +Require Import Integers. +Require Import Values. +Require Import Events. +Require Import Mem. +Require Import Globalenvs. +Require Import Switch. +Require Import Op. +Require Import Registers. +Require Import CminorSel. +Require Import RTL. +Require Import RTLgen. + +(** * Reasoning about monadic computations *) + +(** The tactics below simplify hypotheses of the form [f ... = OK x s] + where [f] is a monadic computation. For instance, the hypothesis + [(do x <- a; b) s = OK y s'] will generate the additional witnesses + [x], [s1] and the additional hypotheses + [a s = OK x s1] and [b x s1 = OK y s'], reflecting the fact that + both monadic computations [a] and [b] succeeded. +*) + +Remark bind_inversion: + forall (A B: Set) (f: mon A) (g: A -> mon B) (y: B) (s1 s3: state), + bind f g s1 = OK y s3 -> + exists x, exists s2, f s1 = OK x s2 /\ g x s2 = OK y s3. +Proof. + intros until s3. unfold bind. destruct (f s1); intros. + discriminate. + exists a; exists s; auto. +Qed. + +Remark bind2_inversion: + forall (A B C: Set) (f: mon (A*B)) (g: A -> B -> mon C) + (z: C) (s1 s3: state), + bind2 f g s1 = OK z s3 -> + exists x, exists y, exists s2, f s1 = OK (x, y) s2 /\ g x y s2 = OK z s3. +Proof. + intros until s3. unfold bind2, bind. destruct (f s1). congruence. + destruct p as [x y]; simpl; intro. + exists x; exists y; exists s; auto. +Qed. + +Ltac monadInv1 H := + match type of H with + | (OK _ _ = OK _ _) => + inversion H; clear H; try subst + | (Error _ _ = OK _ _) => + discriminate + | (ret _ _ = OK _ _) => + inversion H; clear H; try subst + | (error _ _ = OK _ _) => + discriminate + | (bind ?F ?G ?S = OK ?X ?S') => + let x := fresh "x" in ( + let s := fresh "s" in ( + let EQ1 := fresh "EQ" in ( + let EQ2 := fresh "EQ" in ( + destruct (bind_inversion _ _ F G X S S' H) as [x [s [EQ1 EQ2]]]; + clear H; + try (monadInv1 EQ2))))) + | (bind2 ?F ?G ?S = OK ?X ?S') => + let x1 := fresh "x" in ( + let x2 := fresh "x" in ( + let s := fresh "s" in ( + let EQ1 := fresh "EQ" in ( + let EQ2 := fresh "EQ" in ( + destruct (bind2_inversion _ _ _ F G X S S' H) as [x1 [x2 [s [EQ1 EQ2]]]]; + clear H; + try (monadInv1 EQ2)))))) + end. + +Ltac monadInv H := + match type of H with + | (ret _ _ = OK _ _) => monadInv1 H + | (error _ _ = OK _ _) => monadInv1 H + | (bind ?F ?G ?S = OK ?X ?S') => monadInv1 H + | (bind2 ?F ?G ?S = OK ?X ?S') => monadInv1 H + | (?F _ _ _ _ _ _ _ _ = OK _ _) => + ((progress simpl in H) || unfold F in H); monadInv1 H + | (?F _ _ _ _ _ _ _ = OK _ _) => + ((progress simpl in H) || unfold F in H); monadInv1 H + | (?F _ _ _ _ _ _ = OK _ _) => + ((progress simpl in H) || unfold F in H); monadInv1 H + | (?F _ _ _ _ _ = OK _ _) => + ((progress simpl in H) || unfold F in H); monadInv1 H + | (?F _ _ _ _ = OK _ _) => + ((progress simpl in H) || unfold F in H); monadInv1 H + | (?F _ _ _ = OK _ _) => + ((progress simpl in H) || unfold F in H); monadInv1 H + | (?F _ _ = OK _ _) => + ((progress simpl in H) || unfold F in H); monadInv1 H + | (?F _ = OK _ _) => + ((progress simpl in H) || unfold F in H); monadInv1 H + end. + +(** * Monotonicity properties of the state *) + +(** Operations over the global state satisfy a crucial monotonicity property: + nodes are only added to the CFG, but never removed nor their instructions + changed; similarly, fresh nodes and fresh registers are only consumed, + but never reused. This property is captured by the following predicate + over states, which we show is a partial order. *) + +Inductive state_incr: state -> state -> Prop := + state_incr_intro: + forall (s1 s2: state), + Ple s1.(st_nextnode) s2.(st_nextnode) -> + Ple s1.(st_nextreg) s2.(st_nextreg) -> + (forall pc, Plt pc s1.(st_nextnode) -> s2.(st_code)!pc = s1.(st_code)!pc) -> + state_incr s1 s2. + +Lemma instr_at_incr: + forall s1 s2 n i, + state_incr s1 s2 -> s1.(st_code)!n = Some i -> s2.(st_code)!n = Some i. +Proof. + intros. inversion H. + rewrite H3. auto. elim (st_wf s1 n); intro. + assumption. congruence. +Qed. + +Lemma state_incr_refl: + forall s, state_incr s s. +Proof. + intros. apply state_incr_intro. + apply Ple_refl. apply Ple_refl. intros; auto. +Qed. +Hint Resolve state_incr_refl: rtlg. + +Lemma state_incr_trans: + forall s1 s2 s3, state_incr s1 s2 -> state_incr s2 s3 -> state_incr s1 s3. +Proof. + intros. inversion H. inversion H0. apply state_incr_intro. + apply Ple_trans with (st_nextnode s2); assumption. + apply Ple_trans with (st_nextreg s2); assumption. + intros. transitivity (s2.(st_code)!pc). + apply H8. apply Plt_Ple_trans with s1.(st_nextnode); auto. + apply H3; auto. +Qed. +Hint Resolve state_incr_trans: rtlg. + +(** The following relation between two states is a weaker version of + [state_incr]. It permits changing the contents at an already reserved + graph node, but only from [None] to [Some i]. *) + +Definition state_extends (s1 s2: state): Prop := + forall pc, + s1.(st_code)!pc = None \/ s2.(st_code)!pc = s1.(st_code)!pc. + +Lemma instr_at_extends: + forall s1 s2 pc i, + state_extends s1 s2 -> + s1.(st_code)!pc = Some i -> s2.(st_code)!pc = Some i. +Proof. + intros. elim (H pc); intro. congruence. congruence. +Qed. + +Lemma state_incr_extends: + forall s1 s2, + state_incr s1 s2 -> state_extends s1 s2. +Proof. + unfold state_extends; intros. inversion H. + case (plt pc s1.(st_nextnode)); intro. + right; apply H2; auto. + left. elim (s1.(st_wf) pc); intro. + elim (n H5). auto. +Qed. +Hint Resolve state_incr_extends. + +(** * Validity and freshness of registers *) + +(** An RTL pseudo-register is valid in a given state if it was created + earlier, that is, it is less than the next fresh register of the state. + Otherwise, the pseudo-register is said to be fresh. *) + +Definition reg_valid (r: reg) (s: state) : Prop := + Plt r s.(st_nextreg). + +Definition reg_fresh (r: reg) (s: state) : Prop := + ~(Plt r s.(st_nextreg)). + +Lemma valid_fresh_absurd: + forall r s, reg_valid r s -> reg_fresh r s -> False. +Proof. + intros r s. unfold reg_valid, reg_fresh; case r; tauto. +Qed. +Hint Resolve valid_fresh_absurd: rtlg. + +Lemma valid_fresh_different: + forall r1 r2 s, reg_valid r1 s -> reg_fresh r2 s -> r1 <> r2. +Proof. + unfold not; intros. subst r2. eauto with rtlg. +Qed. +Hint Resolve valid_fresh_different: rtlg. + +Lemma reg_valid_incr: + forall r s1 s2, state_incr s1 s2 -> reg_valid r s1 -> reg_valid r s2. +Proof. + intros r s1 s2 INCR. + inversion INCR. + unfold reg_valid. intros; apply Plt_Ple_trans with (st_nextreg s1); auto. +Qed. +Hint Resolve reg_valid_incr: rtlg. + +Lemma reg_fresh_decr: + forall r s1 s2, state_incr s1 s2 -> reg_fresh r s2 -> reg_fresh r s1. +Proof. + intros r s1 s2 INCR. inversion INCR. + unfold reg_fresh; unfold not; intros. + apply H4. apply Plt_Ple_trans with (st_nextreg s1); auto. +Qed. +Hint Resolve reg_fresh_decr: rtlg. + +(** Validity of a list of registers. *) + +Definition regs_valid (rl: list reg) (s: state) : Prop := + forall r, In r rl -> reg_valid r s. + +Lemma regs_valid_nil: + forall s, regs_valid nil s. +Proof. + intros; red; intros. elim H. +Qed. +Hint Resolve regs_valid_nil: rtlg. + +Lemma regs_valid_cons: + forall r1 rl s, + reg_valid r1 s -> regs_valid rl s -> regs_valid (r1 :: rl) s. +Proof. + intros; red; intros. elim H1; intro. subst r1; auto. auto. +Qed. + +Lemma regs_valid_incr: + forall s1 s2 rl, state_incr s1 s2 -> regs_valid rl s1 -> regs_valid rl s2. +Proof. + unfold regs_valid; intros; eauto with rtlg. +Qed. +Hint Resolve regs_valid_incr: rtlg. + +(** A register is ``in'' a mapping if it is associated with a Cminor + local or let-bound variable. *) + +Definition reg_in_map (m: mapping) (r: reg) : Prop := + (exists id, m.(map_vars)!id = Some r) \/ In r m.(map_letvars). + +(** A compilation environment (mapping) is valid in a given state if + the registers associated with Cminor local variables and let-bound variables + are valid in the state. *) + +Definition map_valid (m: mapping) (s: state) : Prop := + forall r, reg_in_map m r -> reg_valid r s. + +Lemma map_valid_incr: + forall s1 s2 m, + state_incr s1 s2 -> map_valid m s1 -> map_valid m s2. +Proof. + unfold map_valid; intros; eauto with rtlg. +Qed. +Hint Resolve map_valid_incr: rtlg. + +(** * Properties of basic operations over the state *) + +(** Properties of [add_instr]. *) + +Lemma add_instr_incr: + forall s1 s2 i n, + add_instr i s1 = OK n s2 -> state_incr s1 s2. +Proof. + intros. monadInv H. + apply state_incr_intro; simpl. + apply Ple_succ. + apply Ple_refl. + intros. apply PTree.gso; apply Plt_ne; auto. +Qed. +Hint Resolve add_instr_incr: rtlg. + +Lemma add_instr_at: + forall s1 s2 i n, + add_instr i s1 = OK n s2 -> s2.(st_code)!n = Some i. +Proof. + intros. monadInv H. simpl. apply PTree.gss. +Qed. +Hint Resolve add_instr_at. + +(** Properties of [reserve_instr] and [update_instr]. *) + +Lemma reserve_instr_incr: + forall s1 s2 n, + reserve_instr s1 = OK n s2 -> state_incr s1 s2. +Proof. + intros. monadInv H. + apply state_incr_intro; simpl. + apply Ple_succ. + apply Ple_refl. + auto. +Qed. + +Lemma update_instr_incr: + forall s1 s2 s3 s4 i n t, + reserve_instr s1 = OK n s2 -> + state_incr s2 s3 -> + update_instr n i s3 = OK t s4 -> + state_incr s1 s4. +Proof. + intros. + generalize H1; clear H1; unfold update_instr. + case (plt n (st_nextnode s3)); intros. 2: discriminate. + inv H1. inv H0. monadInv H; simpl in *. + apply state_incr_intro; simpl. + eapply Ple_trans; eauto. apply Plt_Ple. apply Plt_succ. + auto. + intros. rewrite PTree.gso. + apply H3. apply Plt_trans_succ; auto. + apply Plt_ne. auto. +Qed. + +Lemma update_instr_extends: + forall s1 s2 s3 s4 i n t, + reserve_instr s1 = OK n s2 -> + state_incr s2 s3 -> + update_instr n i s3 = OK t s4 -> + state_extends s3 s4. +Proof. + intros. injection H. intros EQ1 EQ2. + red; intros. + case (peq pc n); intro. + subst pc. left. inversion H0. rewrite H4. rewrite <- EQ1; simpl. + destruct (s1.(st_wf) n). rewrite <- EQ2 in H7. elim (Plt_strict _ H7). + auto. + rewrite <- EQ1; rewrite <- EQ2; simpl. apply Plt_succ. + generalize H1; unfold update_instr. + case (plt n s3.(st_nextnode)); intros; inv H2. + right; simpl. apply PTree.gso; auto. +Qed. + +(** Properties of [new_reg]. *) + +Lemma new_reg_incr: + forall s1 s2 r, new_reg s1 = OK r s2 -> state_incr s1 s2. +Proof. + intros. monadInv H. + apply state_incr_intro; simpl. + apply Ple_refl. apply Ple_succ. auto. +Qed. +Hint Resolve new_reg_incr: rtlg. + +Lemma new_reg_valid: + forall s1 s2 r, + new_reg s1 = OK r s2 -> reg_valid r s2. +Proof. + intros. monadInv H. + unfold reg_valid; simpl. apply Plt_succ. +Qed. +Hint Resolve new_reg_valid: rtlg. + +Lemma new_reg_fresh: + forall s1 s2 r, + new_reg s1 = OK r s2 -> reg_fresh r s1. +Proof. + intros. monadInv H. + unfold reg_fresh; simpl. + exact (Plt_strict _). +Qed. +Hint Resolve new_reg_fresh: rtlg. + +Lemma new_reg_not_in_map: + forall s1 s2 m r, + new_reg s1 = OK r s2 -> map_valid m s1 -> ~(reg_in_map m r). +Proof. + unfold not; intros; eauto with rtlg. +Qed. +Hint Resolve new_reg_not_in_map: rtlg. + +(** * Properties of operations over compilation environments *) + +Lemma init_mapping_valid: + forall s, map_valid init_mapping s. +Proof. + unfold map_valid, init_mapping. + intros s r [[id A] | B]. + simpl in A. rewrite PTree.gempty in A; discriminate. + simpl in B. tauto. +Qed. + +(** Properties of [find_var]. *) + +Lemma find_var_incr: + forall s1 s2 map name r, + find_var map name s1 = OK r s2 -> state_incr s1 s2. +Proof. + intros until r. unfold find_var. + case (map_vars map)!name; intros; monadInv H. + auto with rtlg. +Qed. +Hint Resolve find_var_incr: rtlg. + +Lemma find_var_in_map: + forall s1 s2 map name r, + find_var map name s1 = OK r s2 -> reg_in_map map r. +Proof. + intros until r. unfold find_var; caseEq (map.(map_vars)!name). + intros. inv H0. left; exists name; auto. + intros. inv H0. +Qed. +Hint Resolve find_var_in_map: rtlg. + +Lemma find_var_valid: + forall s1 s2 map name r, + find_var map name s1 = OK r s2 -> map_valid map s1 -> reg_valid r s1. +Proof. + eauto with rtlg. +Qed. +Hint Resolve find_var_valid: rtlg. + +(** Properties of [find_letvar]. *) + +Lemma find_letvar_incr: + forall s1 s2 map idx r, + find_letvar map idx s1 = OK r s2 -> state_incr s1 s2. +Proof. + intros until r. unfold find_letvar. + case (nth_error (map_letvars map) idx); intros; monadInv H. + auto with rtlg. +Qed. +Hint Resolve find_letvar_incr: rtlg. + +Lemma find_letvar_in_map: + forall s1 s2 map idx r, + find_letvar map idx s1 = OK r s2 -> reg_in_map map r. +Proof. + intros until r. unfold find_letvar. + caseEq (nth_error (map_letvars map) idx); intros; monadInv H0. + right; apply nth_error_in with idx; auto. +Qed. +Hint Resolve find_letvar_in_map: rtlg. + +Lemma find_letvar_valid: + forall s1 s2 map idx r, + find_letvar map idx s1 = OK r s2 -> map_valid map s1 -> reg_valid r s1. +Proof. + eauto with rtlg. +Qed. +Hint Resolve find_letvar_valid: rtlg. + +(** Properties of [add_var]. *) + +Lemma add_var_valid: + forall s1 s2 map1 map2 name r, + add_var map1 name s1 = OK (r, map2) s2 -> + map_valid map1 s1 -> + reg_valid r s2 /\ map_valid map2 s2. +Proof. + intros. monadInv H. + split. eauto with rtlg. + inversion EQ. subst. red. intros r' [[id A] | B]. + simpl in A. rewrite PTree.gsspec in A. destruct (peq id name). + inv A. eauto with rtlg. + apply reg_valid_incr with s1. eauto with rtlg. + apply H0. left; exists id; auto. + simpl in B. apply reg_valid_incr with s1. eauto with rtlg. + apply H0. right; auto. +Qed. + +Lemma add_var_incr: + forall s1 s2 map name rm, + add_var map name s1 = OK rm s2 -> state_incr s1 s2. +Proof. + intros. monadInv H. eauto with rtlg. +Qed. +Hint Resolve add_var_incr: rtlg. + +Lemma add_var_find: + forall s1 s2 map name r map', + add_var map name s1 = OK (r,map') s2 -> map'.(map_vars)!name = Some r. +Proof. + intros. monadInv H. simpl. apply PTree.gss. +Qed. + +Lemma add_vars_incr: + forall names s1 s2 map r, + add_vars map names s1 = OK r s2 -> state_incr s1 s2. +Proof. + induction names; simpl; intros; monadInv H. + auto with rtlg. + eauto with rtlg. +Qed. + +Lemma add_vars_valid: + forall namel s1 s2 map1 map2 rl, + add_vars map1 namel s1 = OK (rl, map2) s2 -> + map_valid map1 s1 -> + regs_valid rl s2 /\ map_valid map2 s2. +Proof. + induction namel; simpl; intros; monadInv H. + split. red; simpl; intros; tauto. auto. + exploit IHnamel; eauto. intros [A B]. + exploit add_var_valid; eauto. intros [C D]. + exploit add_var_incr; eauto. intros INCR. + split. apply regs_valid_cons; eauto with rtlg. + auto. +Qed. + +Lemma add_var_letenv: + forall map1 i s1 r map2 s2, + add_var map1 i s1 = OK (r, map2) s2 -> + map2.(map_letvars) = map1.(map_letvars). +Proof. + intros; monadInv H. reflexivity. +Qed. + +Lemma add_vars_letenv: + forall il map1 s1 rl map2 s2, + add_vars map1 il s1 = OK (rl, map2) s2 -> + map2.(map_letvars) = map1.(map_letvars). +Proof. + induction il; simpl; intros; monadInv H. + reflexivity. + transitivity (map_letvars x0). + eapply add_var_letenv; eauto. + eauto. +Qed. + +(** Properties of [add_letvar]. *) + +Lemma add_letvar_valid: + forall map s r, + map_valid map s -> + reg_valid r s -> + map_valid (add_letvar map r) s. +Proof. + intros; red; intros. + destruct H1 as [[id A]|B]. + simpl in A. apply H. left; exists id; auto. + simpl in B. elim B; intro. + subst r0; auto. apply H. right; auto. +Qed. + +(** * Properties of [alloc_reg] and [alloc_regs] *) + +Lemma alloc_reg_incr: + forall a s1 s2 map r, + alloc_reg map a s1 = OK r s2 -> state_incr s1 s2. +Proof. + intros until r. unfold alloc_reg. + case a; eauto with rtlg. +Qed. +Hint Resolve alloc_reg_incr: rtlg. + +Lemma alloc_reg_valid: + forall a s1 s2 map r, + map_valid map s1 -> + alloc_reg map a s1 = OK r s2 -> reg_valid r s2. +Proof. + intros until r. unfold alloc_reg. + case a; eauto with rtlg. +Qed. +Hint Resolve alloc_reg_valid: rtlg. + +Lemma alloc_reg_fresh_or_in_map: + forall map a s r s', + map_valid map s -> + alloc_reg map a s = OK r s' -> + reg_in_map map r \/ reg_fresh r s. +Proof. + intros until s'. unfold alloc_reg. + destruct a; intros; try (right; eauto with rtlg; fail). + left; eauto with rtlg. + left; eauto with rtlg. +Qed. + +Lemma alloc_regs_incr: + forall al s1 s2 map rl, + alloc_regs map al s1 = OK rl s2 -> state_incr s1 s2. +Proof. + induction al; simpl; intros; monadInv H; eauto with rtlg. +Qed. +Hint Resolve alloc_regs_incr: rtlg. + +Lemma alloc_regs_valid: + forall al s1 s2 map rl, + map_valid map s1 -> + alloc_regs map al s1 = OK rl s2 -> + regs_valid rl s2. +Proof. + induction al; simpl; intros; monadInv H0. + apply regs_valid_nil. + apply regs_valid_cons. eauto with rtlg. eauto with rtlg. +Qed. +Hint Resolve alloc_regs_valid: rtlg. + +Lemma alloc_regs_fresh_or_in_map: + forall map al s rl s', + map_valid map s -> + alloc_regs map al s = OK rl s' -> + forall r, In r rl -> reg_in_map map r \/ reg_fresh r s. +Proof. + induction al; simpl; intros; monadInv H0. + elim H1. + elim H1; intro. + subst r. + eapply alloc_reg_fresh_or_in_map; eauto. + exploit IHal. apply map_valid_incr with s0; eauto with rtlg. eauto. eauto. + intros [A|B]. auto. right; eauto with rtlg. +Qed. + +(** A register is an adequate target for holding the value of an + expression if +- either the register is associated with a Cminor let-bound variable + or a Cminor local variable; +- or the register is not associated with any Cminor variable + and does not belong to the preserved set [pr]. *) + +Inductive target_reg_ok (map: mapping) (pr: list reg): expr -> reg -> Prop := + | target_reg_var: + forall id r, + map.(map_vars)!id = Some r -> + target_reg_ok map pr (Evar id) r + | target_reg_letvar: + forall idx r, + nth_error map.(map_letvars) idx = Some r -> + target_reg_ok map pr (Eletvar idx) r + | target_reg_other: + forall a r, + ~(reg_in_map map r) -> ~In r pr -> + target_reg_ok map pr a r. + +Inductive target_regs_ok (map: mapping) (pr: list reg): exprlist -> list reg -> Prop := + | target_regs_nil: + target_regs_ok map pr Enil nil + | target_regs_cons: forall a1 al r1 rl, + target_reg_ok map pr a1 r1 -> + target_regs_ok map (r1 :: pr) al rl -> + target_regs_ok map pr (Econs a1 al) (r1 :: rl). + +Lemma target_reg_ok_append: + forall map pr a r, + target_reg_ok map pr a r -> + forall pr', + (forall r', In r' pr' -> reg_in_map map r' \/ r' <> r) -> + target_reg_ok map (pr' ++ pr) a r. +Proof. + induction 1; intros. + constructor; auto. + constructor; auto. + constructor; auto. red; intros. + elim (in_app_or _ _ _ H2); intro. + generalize (H1 _ H3). tauto. tauto. +Qed. + +Lemma target_reg_ok_cons: + forall map pr a r, + target_reg_ok map pr a r -> + forall r', + reg_in_map map r' \/ r' <> r -> + target_reg_ok map (r' :: pr) a r. +Proof. + intros. change (r' :: pr) with ((r' :: nil) ++ pr). + apply target_reg_ok_append; auto. + intros r'' [A|B]. subst r''; auto. contradiction. +Qed. + +Lemma new_reg_target_ok: + forall map pr s1 a r s2, + map_valid map s1 -> + regs_valid pr s1 -> + new_reg s1 = OK r s2 -> + target_reg_ok map pr a r. +Proof. + intros. constructor. + red; intro. apply valid_fresh_absurd with r s1. + eauto with rtlg. eauto with rtlg. + red; intro. apply valid_fresh_absurd with r s1. + auto. eauto with rtlg. +Qed. + +Lemma alloc_reg_target_ok: + forall map pr s1 a r s2, + map_valid map s1 -> + regs_valid pr s1 -> + alloc_reg map a s1 = OK r s2 -> + target_reg_ok map pr a r. +Proof. + intros. unfold alloc_reg in H1. destruct a; + try (eapply new_reg_target_ok; eauto; fail). + (* Evar *) + generalize H1; unfold find_var. caseEq (map_vars map)!i; intros. + inv H3. constructor. auto. inv H3. + (* Elet *) + generalize H1; unfold find_letvar. caseEq (nth_error (map_letvars map) n); intros. + inv H3. constructor. auto. inv H3. +Qed. + +Lemma alloc_regs_target_ok: + forall map al pr s1 rl s2, + map_valid map s1 -> + regs_valid pr s1 -> + alloc_regs map al s1 = OK rl s2 -> + target_regs_ok map pr al rl. +Proof. + induction al; intros; monadInv H1. + constructor. + constructor. + eapply alloc_reg_target_ok; eauto. + apply IHal with s s2; eauto with rtlg. + apply regs_valid_cons; eauto with rtlg. +Qed. + +Hint Resolve new_reg_target_ok alloc_reg_target_ok alloc_regs_target_ok: rtlg. + +(** The following predicate is a variant of [target_reg_ok] used + to characterize registers that are adequate for holding the return + value of a function. *) + +Inductive return_reg_ok: state -> mapping -> option reg -> Prop := + | return_reg_ok_none: + forall s map, + return_reg_ok s map None + | return_reg_ok_some: + forall s map r, + ~(reg_in_map map r) -> reg_valid r s -> + return_reg_ok s map (Some r). + +Lemma return_reg_ok_incr: + forall s map rret, return_reg_ok s map rret -> + forall s', state_incr s s' -> return_reg_ok s' map rret. +Proof. + induction 1; intros; econstructor; eauto with rtlg. +Qed. +Hint Resolve return_reg_ok_incr: rtlg. + +Lemma new_reg_return_ok: + forall s1 r s2 map sig, + new_reg s1 = OK r s2 -> + map_valid map s1 -> + return_reg_ok s2 map (ret_reg sig r). +Proof. + intros. unfold ret_reg. destruct (sig_res sig); constructor. + eauto with rtlg. eauto with rtlg. +Qed. + +(** * Relational specification of the translation *) + +(** We now define inductive predicates that characterize the fact that + the control-flow graph produced by compilation of a Cminor function + contains sub-graphs that correspond to the translation of each + Cminor expression or statement in the original code. *) + +(** [tr_move c ns rs nd rd] holds if the graph [c], between nodes [ns] + and [nd], contains instructions that move the value of register [rs] + to register [rd]. *) + +Inductive tr_move (c: code): + node -> reg -> node -> reg -> Prop := + | tr_move_0: forall n r, + tr_move c n r n r + | tr_move_1: forall ns rs nd rd, + c!ns = Some (Iop Omove (rs :: nil) rd nd) -> + tr_move c ns rs nd rd. + +(** [tr_expr c map pr expr ns nd rd] holds if the graph [c], + between nodes [ns] and [nd], contains instructions that compute the + value of the Cminor expression [expr] and deposit this value in + register [rd]. [map] is a mapping from Cminor variables to the + corresponding RTL registers. [pr] is a list of RTL registers whose + values must be preserved during this computation. All registers + mentioned in [map] must also be preserved during this computation. + To ensure this, we demand that the result registers of the instructions + appearing on the path from [ns] to [nd] are neither in [pr] nor in [map]. +*) + +Inductive tr_expr (c: code): + mapping -> list reg -> expr -> node -> node -> reg -> Prop := + | tr_Evar: forall map pr id ns nd r rd, + map.(map_vars)!id = Some r -> + (rd = r \/ ~reg_in_map map rd /\ ~In rd pr) -> + tr_move c ns r nd rd -> + tr_expr c map pr (Evar id) ns nd rd + | tr_Eop: forall map pr op al ns nd rd n1 rl, + tr_exprlist c map pr al ns n1 rl -> + c!n1 = Some (Iop op rl rd nd) -> + ~reg_in_map map rd -> ~In rd pr -> + tr_expr c map pr (Eop op al) ns nd rd + | tr_Eload: forall map pr chunk addr al ns nd rd n1 rl, + tr_exprlist c map pr al ns n1 rl -> + c!n1 = Some (Iload chunk addr rl rd nd) -> + ~reg_in_map map rd -> ~In rd pr -> + tr_expr c map pr (Eload chunk addr al) ns nd rd + | tr_Estore: forall map pr chunk addr al b ns nd rd n1 rl n2, + tr_exprlist c map pr al ns n1 rl -> + tr_expr c map (rl ++ pr) b n1 n2 rd -> + c!n2 = Some (Istore chunk addr rl rd nd) -> + tr_expr c map pr (Estore chunk addr al b) ns nd rd + | tr_Ecall: forall map pr sig b cl ns nd rd n1 rf n2 rargs, + tr_expr c map pr b ns n1 rf -> + tr_exprlist c map (rf :: pr) cl n1 n2 rargs -> + c!n2 = Some (Icall sig (inl _ rf) rargs rd nd) -> + ~reg_in_map map rd -> ~In rd pr -> + tr_expr c map pr (Ecall sig b cl) ns nd rd + | tr_Econdition: forall map pr b ifso ifnot ns nd rd ntrue nfalse, + tr_condition c map pr b ns ntrue nfalse -> + tr_expr c map pr ifso ntrue nd rd -> + tr_expr c map pr ifnot nfalse nd rd -> + tr_expr c map pr (Econdition b ifso ifnot) ns nd rd + | tr_Elet: forall map pr b1 b2 ns nd rd n1 r, + ~reg_in_map map r -> + tr_expr c map pr b1 ns n1 r -> + tr_expr c (add_letvar map r) pr b2 n1 nd rd -> + tr_expr c map pr (Elet b1 b2) ns nd rd + | tr_Eletvar: forall map pr n ns nd rd r, + List.nth_error map.(map_letvars) n = Some r -> + (rd = r \/ ~reg_in_map map rd /\ ~In rd pr) -> + tr_move c ns r nd rd -> + tr_expr c map pr (Eletvar n) ns nd rd + | tr_Ealloc: forall map pr a ns nd rd n1 r, + tr_expr c map pr a ns n1 r -> + c!n1 = Some (Ialloc r rd nd) -> + ~reg_in_map map rd -> ~In rd pr -> + tr_expr c map pr (Ealloc a) ns nd rd + +(** [tr_expr c map pr cond ns ntrue nfalse rd] holds if the graph [c], + starting at node [ns], contains instructions that compute the truth + value of the Cminor conditional expression [cond] and terminate + on node [ntrue] if the condition holds and on node [nfalse] otherwise. *) + +with tr_condition (c: code): + mapping -> list reg -> condexpr -> node -> node -> node -> Prop := + | tr_CEtrue: forall map pr ntrue nfalse, + tr_condition c map pr CEtrue ntrue ntrue nfalse + | tr_CEfalse: forall map pr ntrue nfalse, + tr_condition c map pr CEfalse nfalse ntrue nfalse + | tr_CEcond: forall map pr cond bl ns ntrue nfalse n1 rl, + tr_exprlist c map pr bl ns n1 rl -> + c!n1 = Some (Icond cond rl ntrue nfalse) -> + tr_condition c map pr (CEcond cond bl) ns ntrue nfalse + | tr_CEcondition: forall map pr b ifso ifnot ns ntrue nfalse ntrue' nfalse', + tr_condition c map pr b ns ntrue' nfalse' -> + tr_condition c map pr ifso ntrue' ntrue nfalse -> + tr_condition c map pr ifnot nfalse' ntrue nfalse -> + tr_condition c map pr (CEcondition b ifso ifnot) ns ntrue nfalse + +(** [tr_exprlist c map pr exprs ns nd rds] holds if the graph [c], + between nodes [ns] and [nd], contains instructions that compute the values + of the list of Cminor expression [exprlist] and deposit these values + in registers [rds]. *) + +with tr_exprlist (c: code): + mapping -> list reg -> exprlist -> node -> node -> list reg -> Prop := + | tr_Enil: forall map pr n, + tr_exprlist c map pr Enil n n nil + | tr_Econs: forall map pr a1 al ns nd r1 rl n1, + tr_expr c map pr a1 ns n1 r1 -> + tr_exprlist c map (r1 :: pr) al n1 nd rl -> + tr_exprlist c map pr (Econs a1 al) ns nd (r1 :: rl). + +(** Auxiliary for the compilation of [switch] statements. *) + +Inductive tr_switch + (c: code) (r: reg) (nexits: list node): + comptree -> node -> Prop := + | tr_switch_action: forall act n, + nth_error nexits act = Some n -> + tr_switch c r nexits (CTaction act) n + | tr_switch_ifeq: forall key act t' n ncont nfound, + tr_switch c r nexits t' ncont -> + nth_error nexits act = Some nfound -> + c!n = Some(Icond (Ccompimm Ceq key) (r :: nil) nfound ncont) -> + tr_switch c r nexits (CTifeq key act t') n + | tr_switch_iflt: forall key t1 t2 n n1 n2, + tr_switch c r nexits t1 n1 -> + tr_switch c r nexits t2 n2 -> + c!n = Some(Icond (Ccompuimm Clt key) (r :: nil) n1 n2) -> + tr_switch c r nexits (CTiflt key t1 t2) n. + +(** [tr_stmt c map stmt ns ncont nexits nret rret] holds if the graph [c], + starting at node [ns], contains instructions that perform the Cminor + statement [stmt]. These instructions branch to node [ncont] if + the statement terminates normally, to the [n]-th node in [nexits] + if the statement terminates prematurely on a [exit n] statement, + and to [nret] if the statement terminates prematurely on a [return] + statement. Moreover, if the [return] statement has an argument, + its value is deposited in register [rret]. *) + +Inductive tr_stmt (c: code) (map: mapping): + stmt -> node -> node -> list node -> node -> option reg -> Prop := + | tr_Sskip: forall ns nexits nret rret, + tr_stmt c map Sskip ns ns nexits nret rret + | tr_Sexpr: forall a ns nd nexits nret rret r, + tr_expr c map nil a ns nd r -> + tr_stmt c map (Sexpr a) ns nd nexits nret rret + | tr_Sassign: forall id a ns nd nexits nret rret rv rt n, + map.(map_vars)!id = Some rv -> + tr_move c n rt nd rv -> + tr_expr c map nil a ns n rt -> + tr_stmt c map (Sassign id a) ns nd nexits nret rret + | tr_Sseq: forall s1 s2 ns nd nexits nret rret n, + tr_stmt c map s2 n nd nexits nret rret -> + tr_stmt c map s1 ns n nexits nret rret -> + tr_stmt c map (Sseq s1 s2) ns nd nexits nret rret + | tr_Sifthenelse: forall a strue sfalse ns nd nexits nret rret ntrue nfalse, + tr_stmt c map strue ntrue nd nexits nret rret -> + tr_stmt c map sfalse nfalse nd nexits nret rret -> + tr_condition c map nil a ns ntrue nfalse -> + tr_stmt c map (Sifthenelse a strue sfalse) ns nd nexits nret rret + | tr_Sloop: forall sbody ns nd nexits nret rret nloop, + tr_stmt c map sbody ns nloop nexits nret rret -> + c!nloop = Some(Inop ns) -> + tr_stmt c map (Sloop sbody) ns nd nexits nret rret + | tr_Sblock: forall sbody ns nd nexits nret rret, + tr_stmt c map sbody ns nd (nd :: nexits) nret rret -> + tr_stmt c map (Sblock sbody) ns nd nexits nret rret + | tr_Sexit: forall n ns nd nexits nret rret, + nth_error nexits n = Some ns -> + tr_stmt c map (Sexit n) ns nd nexits nret rret + | tr_Sswitch: forall a cases default ns nd nexits nret rret n r t, + validate_switch default cases t = true -> + tr_expr c map nil a ns n r -> + tr_switch c r nexits t n -> + tr_stmt c map (Sswitch a cases default) ns nd nexits nret rret + | tr_Sreturn_none: forall nret nd nexits, + tr_stmt c map (Sreturn None) nret nd nexits nret None + | tr_Sreturn_some: forall a ns nd nexits nret rret, + tr_expr c map nil a ns nret rret -> + tr_stmt c map (Sreturn (Some a)) ns nd nexits nret (Some rret) + | tr_Stailcall: forall sig b cl ns nd nexits nret rret n1 rf n2 rargs, + tr_expr c map nil b ns n1 rf -> + tr_exprlist c map (rf :: nil) cl n1 n2 rargs -> + c!n2 = Some (Itailcall sig (inl _ rf) rargs) -> + tr_stmt c map (Stailcall sig b cl) ns nd nexits nret rret. + +(** [tr_function f tf] specifies the RTL function [tf] that + [RTLgen.transl_function] returns. *) + +Inductive tr_function: CminorSel.function -> RTL.function -> Prop := + | tr_function_intro: + forall f code rparams map1 s1 rvars map2 s2 nentry nret rret orret nextnode wfcode, + add_vars init_mapping f.(CminorSel.fn_params) init_state = OK (rparams, map1) s1 -> + add_vars map1 f.(CminorSel.fn_vars) s1 = OK (rvars, map2) s2 -> + orret = ret_reg f.(CminorSel.fn_sig) rret -> + tr_stmt code map2 f.(CminorSel.fn_body) nentry nret nil nret orret -> + code!nret = Some(Ireturn orret) -> + tr_function f (RTL.mkfunction + f.(CminorSel.fn_sig) + rparams + f.(CminorSel.fn_stackspace) + code + nentry + nextnode + wfcode). + +(** * Correctness proof of the translation functions *) + +(** We now show that the translation functions in module [RTLgen] + satisfy the specifications given above as inductive predicates. *) + +Scheme tr_expr_ind3 := Minimality for tr_expr Sort Prop + with tr_condition_ind3 := Minimality for tr_condition Sort Prop + with tr_exprlist_ind3 := Minimality for tr_exprlist Sort Prop. + +Definition tr_expr_condition_exprlist_ind3 + (c: code) + (P : mapping -> list reg -> expr -> node -> node -> reg -> Prop) + (P0 : mapping -> list reg -> condexpr -> node -> node -> node -> Prop) + (P1 : mapping -> list reg -> exprlist -> node -> node -> list reg -> Prop) := + fun a b c' d e f g h i j k l m n o => + conj (tr_expr_ind3 c P P0 P1 a b c' d e f g h i j k l m n o) + (conj (tr_condition_ind3 c P P0 P1 a b c' d e f g h i j k l m n o) + (tr_exprlist_ind3 c P P0 P1 a b c' d e f g h i j k l m n o)). + +Lemma tr_move_extends: + forall s1 s2, state_extends s1 s2 -> + forall ns rs nd rd, + tr_move s1.(st_code) ns rs nd rd -> + tr_move s2.(st_code) ns rs nd rd. +Proof. + induction 2; econstructor; eauto. + eapply instr_at_extends; eauto. +Qed. + +Lemma tr_expr_condition_exprlist_extends: + forall s1 s2, state_extends s1 s2 -> + (forall map pr a ns nd rd, + tr_expr s1.(st_code) map pr a ns nd rd -> + tr_expr s2.(st_code) map pr a ns nd rd) +/\(forall map pr a ns ntrue nfalse, + tr_condition s1.(st_code) map pr a ns ntrue nfalse -> + tr_condition s2.(st_code) map pr a ns ntrue nfalse) +/\(forall map pr al ns nd rl, + tr_exprlist s1.(st_code) map pr al ns nd rl -> + tr_exprlist s2.(st_code) map pr al ns nd rl). +Proof. + intros s1 s2 EXT. + pose (AT := fun pc i => instr_at_extends s1 s2 pc i EXT). + apply tr_expr_condition_exprlist_ind3; intros; econstructor; eauto. + eapply tr_move_extends; eauto. + eapply tr_move_extends; eauto. +Qed. + +Lemma tr_expr_incr: + forall s1 s2, state_incr s1 s2 -> + forall map pr a ns nd rd, + tr_expr s1.(st_code) map pr a ns nd rd -> + tr_expr s2.(st_code) map pr a ns nd rd. +Proof. + intros. + exploit tr_expr_condition_exprlist_extends. + apply state_incr_extends; eauto. intros [A [B C]]. eauto. +Qed. + +Lemma tr_condition_incr: + forall s1 s2, state_incr s1 s2 -> + forall map pr a ns ntrue nfalse, + tr_condition s1.(st_code) map pr a ns ntrue nfalse -> + tr_condition s2.(st_code) map pr a ns ntrue nfalse. +Proof. + intros. + exploit tr_expr_condition_exprlist_extends. + apply state_incr_extends; eauto. intros [A [B C]]. eauto. +Qed. + +Lemma tr_exprlist_incr: + forall s1 s2, state_incr s1 s2 -> + forall map pr al ns nd rl, + tr_exprlist s1.(st_code) map pr al ns nd rl -> + tr_exprlist s2.(st_code) map pr al ns nd rl. +Proof. + intros. + exploit tr_expr_condition_exprlist_extends. + apply state_incr_extends; eauto. intros [A [B C]]. eauto. +Qed. + +Scheme expr_ind3 := Induction for expr Sort Prop + with condexpr_ind3 := Induction for condexpr Sort Prop + with exprlist_ind3 := Induction for exprlist Sort Prop. + +Definition expr_condexpr_exprlist_ind + (P1: expr -> Prop) (P2: condexpr -> Prop) (P3: exprlist -> Prop) := + fun a b c d e f g h i j k l m n o => + conj (expr_ind3 P1 P2 P3 a b c d e f g h i j k l m n o) + (conj (condexpr_ind3 P1 P2 P3 a b c d e f g h i j k l m n o) + (exprlist_ind3 P1 P2 P3 a b c d e f g h i j k l m n o)). + +Lemma add_move_charact: + forall s ns rs nd rd s', + add_move rs rd nd s = OK ns s' -> + tr_move s'.(st_code) ns rs nd rd /\ state_incr s s'. +Proof. + intros. unfold add_move in H. destruct (Reg.eq rs rd). + inv H. split. constructor. auto with rtlg. + split. constructor. eauto with rtlg. eauto with rtlg. +Qed. + +Lemma transl_expr_condexpr_list_charact: + (forall a map rd nd s ns s' pr + (TR: transl_expr map a rd nd s = OK ns s') + (WF: map_valid map s) + (OK: target_reg_ok map pr a rd) + (VALID: regs_valid pr s) + (VALID2: reg_valid rd s), + tr_expr s'.(st_code) map pr a ns nd rd + /\ state_incr s s') +/\ + (forall a map ntrue nfalse s ns s' pr + (TR: transl_condition map a ntrue nfalse s = OK ns s') + (WF: map_valid map s) + (VALID: regs_valid pr s), + tr_condition s'.(st_code) map pr a ns ntrue nfalse + /\ state_incr s s') +/\ + (forall al map rl nd s ns s' pr + (TR: transl_exprlist map al rl nd s = OK ns s') + (WF: map_valid map s) + (OK: target_regs_ok map pr al rl) + (VALID1: regs_valid pr s) + (VALID2: regs_valid rl s), + tr_exprlist s'.(st_code) map pr al ns nd rl + /\ state_incr s s'). +Proof. + apply expr_condexpr_exprlist_ind; intros; try (monadInv TR). + (* Evar *) + generalize EQ; unfold find_var. caseEq (map_vars map)!i; intros; inv EQ1. + exploit add_move_charact; eauto. + intros [A B]. + split. econstructor; eauto. + inv OK. left; congruence. right; eauto. + auto. + (* Eop *) + inv OK. + exploit (H _ _ _ _ _ _ pr EQ2); eauto with rtlg. intros [A B]. + split. econstructor; eauto. + eapply instr_at_incr; eauto. + apply state_incr_trans with s1; eauto with rtlg. + (* Eload *) + inv OK. + exploit (H _ _ _ _ _ _ pr EQ2); eauto with rtlg. intros [A B]. + split. econstructor; eauto. + eapply instr_at_incr; eauto. + apply state_incr_trans with s1; eauto with rtlg. + (* Estore *) + inv OK. + assert (state_incr s s1). eauto with rtlg. + exploit (H0 _ _ _ _ _ _ (x ++ pr) EQ0). + eauto with rtlg. + apply target_reg_ok_append. constructor; auto. + intros. exploit alloc_regs_fresh_or_in_map; eauto. + intros [A|B]. auto. right. apply sym_not_equal. + eapply valid_fresh_different; eauto with rtlg. + red; intros. elim (in_app_or _ _ _ H4); intro. + exploit alloc_regs_valid; eauto with rtlg. + generalize (VALID _ H5). eauto with rtlg. + eauto with rtlg. + intros [A B]. + exploit (H _ _ _ _ _ _ pr EQ3); eauto with rtlg. + intros [C D]. + split. econstructor; eauto. + apply tr_expr_incr with s2; eauto with rtlg. + apply instr_at_incr with s1; eauto with rtlg. + eauto with rtlg. + (* Ecall *) + inv OK. + assert (state_incr s0 s3). + apply state_incr_trans with s1. eauto with rtlg. + apply state_incr_trans with s2; eauto with rtlg. + assert (regs_valid (x :: pr) s1). + apply regs_valid_cons; eauto with rtlg. + exploit (H0 _ _ _ _ _ _ (x :: pr) EQ2). + eauto with rtlg. + apply alloc_regs_target_ok with s1 s2; eauto with rtlg. + eauto with rtlg. + apply regs_valid_incr with s2; eauto with rtlg. + intros [A B]. + exploit (H _ _ _ _ _ _ pr EQ4). + eauto with rtlg. + eauto with rtlg. + apply regs_valid_incr with s0; eauto with rtlg. + apply reg_valid_incr with s1; eauto with rtlg. + intros [C D]. + split. econstructor; eauto. + apply tr_exprlist_incr with s4; eauto. + apply instr_at_incr with s3; eauto with rtlg. + eauto with rtlg. + (* Econdition *) + inv OK. + exploit (H1 _ _ _ _ _ _ pr EQ); eauto with rtlg. + constructor; auto. + intros [A B]. + exploit (H0 _ _ _ _ _ _ pr EQ1); eauto with rtlg. + constructor; auto. + intros [C D]. + exploit (H _ _ _ _ _ _ pr EQ2); eauto with rtlg. + intros [E F]. + split. econstructor; eauto. + apply tr_expr_incr with s1; auto. + apply tr_expr_incr with s0; eauto with rtlg. + apply state_incr_trans with s0; auto. + apply state_incr_trans with s1; auto. + (* Elet *) + inv OK. + exploit (H0 _ _ _ _ _ _ pr EQ1). + apply add_letvar_valid; eauto with rtlg. + constructor; auto. + red; unfold reg_in_map. simpl. intros [[id A] | [B | C]]. + elim H1. left; exists id; auto. + subst x. apply valid_fresh_absurd with rd s. auto. eauto with rtlg. + elim H1. right; auto. + eauto with rtlg. eauto with rtlg. + intros [A B]. + exploit (H _ _ _ _ _ _ pr EQ2); eauto with rtlg. intros [C D]. + split. econstructor. + eapply new_reg_not_in_map; eauto with rtlg. eauto. + apply tr_expr_incr with s1; auto. + eauto with rtlg. + (* Eletvar *) + generalize EQ; unfold find_letvar. caseEq (nth_error (map_letvars map) n); intros; inv EQ0. + monadInv EQ1. + exploit add_move_charact; eauto. + intros [A B]. + split. econstructor; eauto. + inv OK. left; congruence. right; eauto. + auto. + monadInv EQ1. + (* Ealloc *) + inv OK. + exploit (H _ _ _ _ _ _ pr EQ2); eauto with rtlg. + intros [A B]. + split. econstructor; eauto. + eapply instr_at_incr; eauto. + apply state_incr_trans with s1; eauto with rtlg. + + (* CEtrue *) + split. constructor. auto with rtlg. + (* CEfalse *) + split. constructor. auto with rtlg. + (* CEcond *) + exploit (H _ _ _ _ _ _ pr EQ2); eauto with rtlg. + intros [A B]. + split. econstructor; eauto. + apply instr_at_incr with s1; eauto with rtlg. + eauto with rtlg. + (* CEcondition *) + exploit (H1 _ _ _ _ _ _ pr EQ); eauto with rtlg. + intros [A B]. + exploit (H0 _ _ _ _ _ _ pr EQ1); eauto with rtlg. + intros [C D]. + exploit (H _ _ _ _ _ _ pr EQ2); eauto with rtlg. + intros [E F]. + split. econstructor; eauto. + apply tr_condition_incr with s1; eauto with rtlg. + apply tr_condition_incr with s0; eauto with rtlg. + eauto with rtlg. + + (* Enil *) + destruct rl; inv TR. split. constructor. eauto with rtlg. + (* Econs *) + destruct rl; simpl in TR; monadInv TR. inv OK. + exploit H0; eauto. + apply regs_valid_cons. apply VALID2. auto with coqlib. auto. + red; intros; apply VALID2; auto with coqlib. + intros [A B]. + exploit H; eauto. + eauto with rtlg. + eauto with rtlg. + generalize (VALID2 r (in_eq _ _)). eauto with rtlg. + intros [C D]. + split. econstructor; eauto. + apply tr_exprlist_incr with s0; auto. + apply state_incr_trans with s0; eauto with rtlg. +Qed. + +Lemma transl_expr_charact: + forall a map rd nd s ns s' + (TR: transl_expr map a rd nd s = OK ns s') + (WF: map_valid map s) + (OK: target_reg_ok map nil a rd) + (VALID2: reg_valid rd s), + tr_expr s'.(st_code) map nil a ns nd rd + /\ state_incr s s'. +Proof. + destruct transl_expr_condexpr_list_charact as [A [B C]]. + intros. eapply A; eauto with rtlg. +Qed. + +Lemma transl_condexpr_charact: + forall a map ntrue nfalse s ns s' + (TR: transl_condition map a ntrue nfalse s = OK ns s') + (WF: map_valid map s), + tr_condition s'.(st_code) map nil a ns ntrue nfalse + /\ state_incr s s'. +Proof. + destruct transl_expr_condexpr_list_charact as [A [B C]]. + intros. eapply B; eauto with rtlg. +Qed. + +Lemma tr_switch_extends: + forall s1 s2, state_extends s1 s2 -> + forall r nexits t ns, + tr_switch s1.(st_code) r nexits t ns -> + tr_switch s2.(st_code) r nexits t ns. +Proof. + induction 2; econstructor; eauto with rtlg. + eapply instr_at_extends; eauto. + eapply instr_at_extends; eauto. +Qed. + +Lemma tr_stmt_extends: + forall s1 s2, state_extends s1 s2 -> + forall map s ns nd nexits nret rret, + tr_stmt s1.(st_code) map s ns nd nexits nret rret -> + tr_stmt s2.(st_code) map s ns nd nexits nret rret. +Proof. + intros s1 s2 EXT. + destruct (tr_expr_condition_exprlist_extends s1 s2 EXT) as [A [B C]]. + pose (AT := fun pc i => instr_at_extends s1 s2 pc i EXT). + induction 1; econstructor; eauto. + eapply tr_move_extends; eauto. + eapply tr_switch_extends; eauto. +Qed. + +Lemma tr_stmt_incr: + forall s1 s2, state_incr s1 s2 -> + forall map s ns nd nexits nret rret, + tr_stmt s1.(st_code) map s ns nd nexits nret rret -> + tr_stmt s2.(st_code) map s ns nd nexits nret rret. +Proof. + intros. eapply tr_stmt_extends; eauto with rtlg. +Qed. + +Lemma transl_exit_charact: + forall nexits n s ne s', + transl_exit nexits n s = OK ne s' -> + nth_error nexits n = Some ne /\ s' = s. +Proof. + intros until s'. unfold transl_exit. + destruct (nth_error nexits n); intro; monadInv H. auto. +Qed. + +Lemma transl_switch_charact: + forall r nexits t s ns s', + transl_switch r nexits t s = OK ns s' -> + tr_switch s'.(st_code) r nexits t ns /\ state_incr s s'. +Proof. + induction t; simpl; intros. + exploit transl_exit_charact; eauto. intros [A B]. + split. econstructor; eauto. subst s'; auto with rtlg. + + monadInv H. + exploit transl_exit_charact; eauto. intros [A B]. subst s1. + exploit IHt; eauto. intros [C D]. + split. econstructor; eauto with rtlg. + apply tr_switch_extends with s0; eauto with rtlg. + eauto with rtlg. + + monadInv H. + exploit IHt2; eauto. intros [A B]. + exploit IHt1; eauto. intros [C D]. + split. econstructor. + apply tr_switch_extends with s1; eauto with rtlg. + apply tr_switch_extends with s0; eauto with rtlg. + eauto with rtlg. + eauto with rtlg. +Qed. + +Lemma transl_stmt_charact: + forall map stmt nd nexits nret rret s ns s' + (TR: transl_stmt map stmt nd nexits nret rret s = OK ns s') + (WF: map_valid map s) + (OK: return_reg_ok s map rret), + tr_stmt s'.(st_code) map stmt ns nd nexits nret rret + /\ state_incr s s'. +Proof. + induction stmt; intros; simpl in TR; try (monadInv TR). + (* Sskip *) + split. constructor. auto with rtlg. + (* Sexpr *) + exploit transl_expr_charact; eauto with rtlg. intros [A B]. + split. econstructor; eauto. eauto with rtlg. + (* Sassign *) + exploit add_move_charact; eauto. intros [A B]. + exploit transl_expr_charact; eauto with rtlg. + apply map_valid_incr with s; eauto with rtlg. + intros [C D]. + generalize EQ. unfold find_var. caseEq (map_vars map)!i; intros; inv EQ2. + split. econstructor; eauto. + apply tr_move_extends with s2; eauto with rtlg. + eauto with rtlg. + (* Sseq *) + exploit IHstmt2; eauto with rtlg. intros [A B]. + exploit IHstmt1; eauto with rtlg. intros [C D]. + split. econstructor; eauto. apply tr_stmt_incr with s0; eauto with rtlg. + eauto with rtlg. + (* Sifthenelse *) + destruct (more_likely c stmt1 stmt2); monadInv TR. + exploit IHstmt2; eauto. intros [A B]. + exploit IHstmt1; eauto with rtlg. intros [C D]. + exploit transl_condexpr_charact; eauto with rtlg. intros [E F]. + split. econstructor; eauto. + apply tr_stmt_incr with s1; eauto with rtlg. + apply tr_stmt_incr with s0; eauto with rtlg. + eauto with rtlg. + exploit IHstmt1; eauto. intros [A B]. + exploit IHstmt2; eauto with rtlg. intros [C D]. + exploit transl_condexpr_charact; eauto with rtlg. intros [E F]. + split. econstructor; eauto. + apply tr_stmt_incr with s0; eauto with rtlg. + apply tr_stmt_incr with s1; eauto with rtlg. + eauto with rtlg. + (* Sloop *) + assert (state_incr s s0). + eapply reserve_instr_incr; eauto. + exploit IHstmt; eauto with rtlg. intros [A B]. + split. econstructor. + apply tr_stmt_extends with s1; eauto. + eapply update_instr_extends; eauto. + unfold update_instr in EQ0. + destruct (plt x (st_nextnode s1)); inv EQ0. + simpl. apply PTree.gss. + eapply update_instr_incr; eauto. + (* Sblock *) + exploit IHstmt; eauto. intros [A B]. + split. econstructor; eauto. auto. + (* Sexit *) + exploit transl_exit_charact; eauto. intros [A B]. subst s'. + split. econstructor; eauto. auto with rtlg. + (* Sswitch *) + generalize TR; clear TR. + set (t := compile_switch n l). + caseEq (validate_switch n l t); intro VALID; intros. + monadInv TR. + exploit transl_switch_charact; eauto with rtlg. intros [A B]. + exploit transl_expr_charact; eauto with rtlg. intros [C D]. + split. econstructor; eauto with rtlg. + apply tr_switch_extends with s1; eauto with rtlg. + eauto with rtlg. + monadInv TR. + (* Sreturn *) + destruct o; destruct rret; inv TR. + inv OK. + exploit transl_expr_charact; eauto with rtlg. + constructor. auto. simpl; tauto. + intros [A B]. + split. econstructor; eauto. auto. + split. constructor. auto with rtlg. + (* Stailcall *) + assert (state_incr s0 s2) by eauto with rtlg. + destruct transl_expr_condexpr_list_charact as [A [B C]]. + exploit (C _ _ _ _ _ _ _ (x ::nil) EQ2); eauto with rtlg. + apply alloc_regs_target_ok with s1 s2; eauto with rtlg. + apply regs_valid_cons. eauto with rtlg. apply regs_valid_nil. + apply regs_valid_cons. apply reg_valid_incr with s1; eauto with rtlg. + apply regs_valid_nil. + apply regs_valid_incr with s2; eauto with rtlg. + intros [D E]. + exploit (A _ _ _ _ _ _ _ nil EQ4); eauto with rtlg. + apply reg_valid_incr with s1; eauto with rtlg. + intros [F G]. + split. econstructor; eauto. + apply tr_exprlist_incr with s4; eauto. + apply instr_at_incr with s3; eauto with rtlg. + eauto with rtlg. +Qed. + +Lemma transl_function_charact: + forall f tf, + transl_function f = Errors.OK tf -> + tr_function f tf. +Proof. + intros until tf. unfold transl_function. + caseEq (transl_fun f init_state). congruence. + intros [nentry rparams] sfinal TR E. inv E. + monadInv TR. + exploit add_vars_valid. eexact EQ. apply init_mapping_valid. + intros [A B]. + exploit add_vars_valid. eexact EQ1. auto. + intros [C D]. + exploit transl_stmt_charact; eauto with rtlg. + unfold ret_reg. destruct (sig_res (CminorSel.fn_sig f)). + constructor. eauto with rtlg. eauto with rtlg. + constructor. + intros [E F]. + eapply tr_function_intro; eauto with rtlg. + apply instr_at_incr with s2; eauto with rtlg. +Qed. diff --git a/backend/RTLtyping.v b/backend/RTLtyping.v index 97d063ac..40567491 100644 --- a/backend/RTLtyping.v +++ b/backend/RTLtyping.v @@ -1,6 +1,7 @@ (** Typing rules and a type inference algorithm for RTL. *) Require Import Coqlib. +Require Import Errors. Require Import Maps. Require Import AST. Require Import Op. @@ -22,15 +23,17 @@ Require Conventions. enabling each pseudo-register to be mapped to a single hardware register or stack location of the correct type. - - The typing judgement for instructions is of the form [wt_instr f env instr], - where [f] is the current function (used to type-check [Ireturn] - instructions) and [env] is a typing environment associating types to - pseudo-registers. Since pseudo-registers have unique types throughout - the function, the typing environment does not change during type-checking - of individual instructions. One point to note is that we have two - polymorphic operators, [Omove] and [Oundef], which can work both - over integers and floats. + Finally, we also check that the successors of instructions + are valid, i.e. refer to non-empty nodes in the CFG. + + The typing judgement for instructions is of the form [wt_instr f env + instr], where [f] is the current function (used to type-check + [Ireturn] instructions) and [env] is a typing environment + associating types to pseudo-registers. Since pseudo-registers have + unique types throughout the function, the typing environment does + not change during type-checking of individual instructions. One + point to note is that we have one polymorphic operator, [Omove], + which can work over both integers and floats. *) Definition regenv := reg -> typ. @@ -38,51 +41,67 @@ Definition regenv := reg -> typ. Section WT_INSTR. Variable env: regenv. -Variable funsig: signature. +Variable funct: function. + +Definition valid_successor (s: node) : Prop := + exists i, funct.(fn_code)!s = Some i. Inductive wt_instr : instruction -> Prop := | wt_Inop: forall s, + valid_successor s -> wt_instr (Inop s) | wt_Iopmove: forall r1 r s, env r1 = env r -> + valid_successor s -> wt_instr (Iop Omove (r1 :: nil) r s) - | wt_Iopundef: - forall r s, - wt_instr (Iop Oundef nil r s) | wt_Iop: forall op args res s, - op <> Omove -> op <> Oundef -> + op <> Omove -> (List.map env args, env res) = type_of_operation op -> + valid_successor s -> wt_instr (Iop op args res s) | wt_Iload: forall chunk addr args dst s, List.map env args = type_of_addressing addr -> env dst = type_of_chunk chunk -> + valid_successor s -> wt_instr (Iload chunk addr args dst s) | wt_Istore: forall chunk addr args src s, List.map env args = type_of_addressing addr -> env src = type_of_chunk chunk -> + valid_successor s -> wt_instr (Istore chunk addr args src s) | wt_Icall: forall sig ros args res s, match ros with inl r => env r = Tint | inr s => True end -> List.map env args = sig.(sig_args) -> - env res = match sig.(sig_res) with None => Tint | Some ty => ty end -> + env res = proj_sig_res sig -> + valid_successor s -> wt_instr (Icall sig ros args res s) + | wt_Itailcall: + forall sig ros args, + match ros with inl r => env r = Tint | inr s => True end -> + sig.(sig_res) = funct.(fn_sig).(sig_res) -> + List.map env args = sig.(sig_args) -> + Conventions.tailcall_possible sig -> + wt_instr (Itailcall sig ros args) | wt_Ialloc: forall arg res s, env arg = Tint -> env res = Tint -> + valid_successor s -> wt_instr (Ialloc arg res s) | wt_Icond: forall cond args s1 s2, List.map env args = type_of_condition cond -> + valid_successor s1 -> + valid_successor s2 -> wt_instr (Icond cond args s1 s2) | wt_Ireturn: forall optres, - option_map env optres = funsig.(sig_res) -> + option_map env optres = funct.(fn_sig).(sig_res) -> wt_instr (Ireturn optres). End WT_INSTR. @@ -90,7 +109,7 @@ End WT_INSTR. (** A function [f] is well-typed w.r.t. a typing environment [env], written [wt_function env f], if all instructions are well-typed, parameters agree in types with the function signature, and - names of parameters are pairwise distinct. *) + parameters are pairwise distinct. *) Record wt_function (f: function) (env: regenv): Prop := mk_wt_function { @@ -100,7 +119,9 @@ Record wt_function (f: function) (env: regenv): Prop := list_norepet f.(fn_params); wt_instrs: forall pc instr, - f.(fn_code)!pc = Some instr -> wt_instr env f.(fn_sig) instr + f.(fn_code)!pc = Some instr -> wt_instr env f instr; + wt_entrypoint: + valid_successor f f.(fn_entrypoint) }. Inductive wt_fundef: fundef -> Prop := @@ -142,6 +163,9 @@ Variable env: regenv. Lemma typ_eq: forall (t1 t2: typ), {t1=t2} + {t1<>t2}. Proof. decide equality. Qed. +Lemma opt_typ_eq: forall (t1 t2: option typ), {t1=t2} + {t1<>t2}. +Proof. decide equality. apply typ_eq. Qed. + Definition check_reg (r: reg) (ty: typ): bool := if typ_eq (env r) ty then true else false. @@ -156,34 +180,47 @@ Definition check_op (op: operation) (args: list reg) (res: reg): bool := let (targs, tres) := type_of_operation op in check_regs args targs && check_reg res tres. +Definition check_successor (s: node) : bool := + match funct.(fn_code)!s with None => false | Some i => true end. + Definition check_instr (i: instruction) : bool := match i with - | Inop _ => - true - | Iop Omove (arg::nil) res _ => - if typ_eq (env arg) (env res) then true else false - | Iop Omove args res _ => - false - | Iop Oundef nil res _ => - true - | Iop Oundef args res _ => + | Inop s => + check_successor s + | Iop Omove (arg::nil) res s => + if typ_eq (env arg) (env res) + then check_successor s + else false + | Iop Omove args res s => false - | Iop op args res _ => - check_op op args res - | Iload chunk addr args dst _ => + | Iop op args res s => + check_op op args res && check_successor s + | Iload chunk addr args dst s => check_regs args (type_of_addressing addr) && check_reg dst (type_of_chunk chunk) - | Istore chunk addr args src _ => + && check_successor s + | Istore chunk addr args src s => check_regs args (type_of_addressing addr) && check_reg src (type_of_chunk chunk) - | Icall sig ros args res _ => + && check_successor s + | Icall sig ros args res s => + match ros with inl r => check_reg r Tint | inr s => true end + && check_regs args sig.(sig_args) + && check_reg res (proj_sig_res sig) + && check_successor s + | Itailcall sig ros args => match ros with inl r => check_reg r Tint | inr s => true end && check_regs args sig.(sig_args) - && check_reg res (match sig.(sig_res) with None => Tint | Some ty => ty end) - | Ialloc arg res _ => - check_reg arg Tint && check_reg res Tint - | Icond cond args _ _ => + && opt_typ_eq sig.(sig_res) funct.(fn_sig).(sig_res) + && zeq (Conventions.size_arguments sig) 14 + | Ialloc arg res s => + check_reg arg Tint + && check_reg res Tint + && check_successor s + | Icond cond args s1 s2 => check_regs args (type_of_condition cond) + && check_successor s1 + && check_successor s2 | Ireturn optres => match optres, funct.(fn_sig).(sig_res) with | None, None => true @@ -203,6 +240,14 @@ Fixpoint check_instrs (instrs: list (node * instruction)) : bool := (** ** Correctness of the type-checking algorithm *) +Ltac elimAndb := + match goal with + | [ H: _ && _ = true |- _ ] => + elim (andb_prop _ _ H); clear H; intros; elimAndb + | _ => + idtac + end. + Lemma check_reg_correct: forall r ty, check_reg r ty = true -> env r = ty. Proof. @@ -215,8 +260,8 @@ Lemma check_regs_correct: Proof. induction rl; destruct tyl; simpl; intros. auto. discriminate. discriminate. - elim (andb_prop _ _ H); intros. - rewrite (check_reg_correct _ _ H0). rewrite (IHrl tyl H1). auto. + elimAndb. + rewrite (check_reg_correct _ _ H). rewrite (IHrl tyl H0). auto. Qed. Lemma check_op_correct: @@ -225,45 +270,65 @@ Lemma check_op_correct: (List.map env args, env res) = type_of_operation op. Proof. unfold check_op; intros. - destruct (type_of_operation op) as [targs tres]. - elim (andb_prop _ _ H); intros. - rewrite (check_regs_correct _ _ H0). - rewrite (check_reg_correct _ _ H1). + destruct (type_of_operation op) as [targs tres]. + elimAndb. + rewrite (check_regs_correct _ _ H). + rewrite (check_reg_correct _ _ H0). auto. Qed. +Lemma check_successor_correct: + forall s, + check_successor s = true -> valid_successor funct s. +Proof. + intro; unfold check_successor, valid_successor. + destruct (fn_code funct)!s; intro. + exists i; auto. + discriminate. +Qed. + Lemma check_instr_correct: - forall i, check_instr i = true -> wt_instr env funct.(fn_sig) i. + forall i, check_instr i = true -> wt_instr env funct i. Proof. - unfold check_instr; intros; destruct i. + unfold check_instr; intros; destruct i; elimAndb. (* nop *) - constructor. + constructor. apply check_successor_correct; auto. (* op *) - destruct o; - try (apply wt_Iop; [congruence|congruence|apply check_op_correct;auto]). + destruct o; elimAndb; + try (apply wt_Iop; [ congruence + | apply check_op_correct; auto + | apply check_successor_correct; auto ]). destruct l; try discriminate. destruct l; try discriminate. destruct (typ_eq (env r0) (env r)); try discriminate. - apply wt_Iopmove; auto. - destruct l; try discriminate. - apply wt_Iopundef. + apply wt_Iopmove; auto. apply check_successor_correct; auto. (* load *) - elim (andb_prop _ _ H); intros. constructor. apply check_regs_correct; auto. apply check_reg_correct; auto. + apply check_successor_correct; auto. (* store *) - elim (andb_prop _ _ H); intros. constructor. apply check_regs_correct; auto. apply check_reg_correct; auto. + apply check_successor_correct; auto. (* call *) - elim (andb_prop _ _ H); clear H; intros. - elim (andb_prop _ _ H); clear H; intros. constructor. destruct s0; auto. apply check_reg_correct; auto. apply check_regs_correct; auto. apply check_reg_correct; auto. + apply check_successor_correct; auto. + (* tailcall *) + constructor. + destruct s0; auto. apply check_reg_correct; auto. + eapply proj_sumbool_true; eauto. + apply check_regs_correct; auto. + rewrite Conventions.tailcall_possible_size. + eapply proj_sumbool_true; eauto. (* alloc *) - elim (andb_prop _ _ H); intros. - constructor; apply check_reg_correct; auto. + constructor. + apply check_reg_correct; auto. + apply check_reg_correct; auto. + apply check_successor_correct; auto. (* cond *) constructor. apply check_regs_correct; auto. + apply check_successor_correct; auto. + apply check_successor_correct; auto. (* return *) constructor. destruct o; simpl; destruct funct.(fn_sig).(sig_res); try discriminate. @@ -274,11 +339,11 @@ Qed. Lemma check_instrs_correct: forall instrs, check_instrs instrs = true -> - forall pc i, In (pc, i) instrs -> wt_instr env funct.(fn_sig) i. + forall pc i, In (pc, i) instrs -> wt_instr env funct i. Proof. induction instrs; simpl; intros. elim H0. - destruct a as [pc' i']. elim (andb_prop _ _ H); clear H; intros. + destruct a as [pc' i']. elimAndb. elim H0; intro. inversion H2; subst pc' i'. apply check_instr_correct; auto. eauto. @@ -288,20 +353,24 @@ End TYPECHECKING. (** ** The type inference function **) -Definition type_function (f: function): option regenv := +Open Scope string_scope. + +Definition type_function (f: function): res regenv := let instrs := PTree.elements f.(fn_code) in match infer_type_environment f instrs with - | None => None + | None => Error (msg "RTL type inference error") | Some env => if check_regs env f.(fn_params) f.(fn_sig).(sig_args) && check_params_norepet f.(fn_params) && check_instrs f env instrs - then Some env else None + && check_successor f f.(fn_entrypoint) + then OK env + else Error (msg "RTL type checking error") end. Lemma type_function_correct: forall f env, - type_function f = Some env -> + type_function f = OK env -> wt_function f env. Proof. unfold type_function; intros until env. @@ -311,6 +380,7 @@ Proof. caseEq (check_regs env' f.(fn_params) f.(fn_sig).(sig_args)); intro; simpl; try congruence. caseEq (check_params_norepet f.(fn_params)); intro; simpl; try congruence. caseEq (check_instrs f env' instrs); intro; simpl; try congruence. + caseEq (check_successor f (fn_entrypoint f)); intro; simpl; try congruence. intro EQ; inversion EQ; subst env'. constructor. apply check_regs_correct; auto. @@ -318,6 +388,7 @@ Proof. destruct (list_norepet_dec Reg.eq (fn_params f)). auto. discriminate. intros. eapply check_instrs_correct. eauto. unfold instrs. apply PTree.elements_correct. eauto. + apply check_successor_correct. auto. congruence. Qed. @@ -330,7 +401,8 @@ Qed. property: if the execution does not fail because of a failed run-time test, the result values and register states match the static typing assumptions. This preservation property will be useful - later for the proof of semantic equivalence between [Machabstr] and [Mach]. + later for the proof of semantic equivalence between + [Machabstr] and [Machconcr]. Even though we do not need it for [RTL], we show preservation for [RTL] here, as a warm-up exercise and because some of the lemmas will be useful later. *) @@ -340,6 +412,7 @@ Require Import Values. Require Import Mem. Require Import Integers. Require Import Events. +Require Import Smallstep. Definition wt_regset (env: regenv) (rs: regset) : Prop := forall r, Val.has_type (rs#r) (env r). @@ -385,6 +458,36 @@ Proof. induction 1. inversion H0; exact I. Qed. +Inductive wt_stackframes: list stackframe -> option typ -> Prop := + | wt_stackframes_nil: + wt_stackframes nil (Some Tint) + | wt_stackframes_cons: + forall s res f sp pc rs env tyres, + wt_function f env -> + wt_regset env rs -> + env res = match tyres with None => Tint | Some t => t end -> + wt_stackframes s (sig_res (fn_sig f)) -> + wt_stackframes (Stackframe res (fn_code f) sp pc rs :: s) tyres. + +Inductive wt_state: state -> Prop := + | wt_state_intro: + forall s f sp pc rs m env + (WT_STK: wt_stackframes s (sig_res (fn_sig f))) + (WT_FN: wt_function f env) + (WT_RS: wt_regset env rs), + wt_state (State s (fn_code f) sp pc rs m) + | wt_state_call: + forall s f args m, + wt_stackframes s (sig_res (funsig f)) -> + wt_fundef f -> + Val.has_type_list args (sig_args (funsig f)) -> + wt_state (Callstate s f args m) + | wt_state_return: + forall s v m tyres, + wt_stackframes s tyres -> + Val.has_type v (match tyres with None => Tint | Some t => t end) -> + wt_state (Returnstate s v m). + Section SUBJECT_REDUCTION. Variable p: program. @@ -393,90 +496,77 @@ Hypothesis wt_p: wt_program p. Let ge := Genv.globalenv p. -Definition exec_instr_subject_reduction - (c: code) (sp: val) - (pc: node) (rs: regset) (m: mem) (t: trace) - (pc': node) (rs': regset) (m': mem) : Prop := - forall env f - (CODE: c = fn_code f) - (WT_FN: wt_function f env) - (WT_RS: wt_regset env rs), - wt_regset env rs'. - -Definition exec_function_subject_reduction - (f: fundef) (args: list val) (m: mem) (t: trace) (res: val) (m': mem) : Prop := - wt_fundef f -> - Val.has_type_list args (sig_args (funsig f)) -> - Val.has_type res (proj_sig_res (funsig f)). - Lemma subject_reduction: - forall f args m t res m', - exec_function ge f args m t res m' -> - exec_function_subject_reduction f args m t res m'. + forall st1 t st2, step ge st1 t st2 -> + forall (WT: wt_state st1), wt_state st2. Proof. - apply (exec_function_ind_3 ge - exec_instr_subject_reduction - exec_instr_subject_reduction - exec_function_subject_reduction); - intros; red; intros; - try (rewrite CODE in H; - generalize (wt_instrs _ _ WT_FN pc _ H); + induction 1; intros; inv WT; + try (generalize (wt_instrs _ _ WT_FN pc _ H); intro WT_INSTR; - inversion WT_INSTR). - - assumption. - + inv WT_INSTR). + (* Inop *) + econstructor; eauto. + (* Iop *) + econstructor; eauto. apply wt_regset_assign. auto. - subst op. subst args. simpl in H0. injection H0; intro. - subst v. rewrite <- H2. apply WT_RS. - - apply wt_regset_assign. auto. - subst op; subst args; simpl in H0. injection H0; intro; subst v. - simpl; auto. - + simpl in H0. inv H0. rewrite <- H3. apply WT_RS. + econstructor; eauto. apply wt_regset_assign. auto. replace (env res) with (snd (type_of_operation op)). - apply type_of_operation_sound with fundef ge rs##args sp; auto. - rewrite <- H7. reflexivity. - + apply type_of_operation_sound with fundef ge rs##args sp m; auto. + rewrite <- H6. reflexivity. + (* Iload *) + econstructor; eauto. apply wt_regset_assign. auto. rewrite H8. eapply type_of_chunk_correct; eauto. - - assumption. - - apply wt_regset_assign. auto. rewrite H11. rewrite <- H1. + (* Istore *) + econstructor; eauto. + (* Icall *) assert (wt_fundef f). destruct ros; simpl in H0. pattern f. apply Genv.find_funct_prop with fundef unit p (rs#r). exact wt_p. exact H0. - caseEq (Genv.find_symbol ge i); intros; rewrite H12 in H0. + caseEq (Genv.find_symbol ge i); intros; rewrite H1 in H0. pattern f. apply Genv.find_funct_ptr_prop with fundef unit p b. exact wt_p. exact H0. discriminate. - eapply H3. auto. rewrite H1. rewrite <- H10. - apply wt_regset_list; auto. - - apply wt_regset_assign. auto. rewrite H6; exact I. - - assumption. - assumption. - assumption. - eauto. - eauto. - - inversion H4; subst f0. - assert (WT_INIT: wt_regset env (init_regs args (fn_params f))). - apply wt_init_regs. rewrite (wt_params _ _ H7). assumption. - generalize (H1 env f (refl_equal (fn_code f)) H7 WT_INIT). - intro WT_RS. - generalize (wt_instrs _ _ H7 pc _ H2). - intro WT_INSTR; inversion WT_INSTR. - unfold proj_sig_res; simpl. - destruct or; simpl in H3; simpl in H8; rewrite <- H8. - rewrite H3. apply WT_RS. - rewrite H3. simpl; auto. - - simpl. eapply wt_event_match; eauto. -Qed. + econstructor; eauto. + econstructor; eauto. + rewrite <- H7. apply wt_regset_list. auto. + (* Itailcall *) + assert (wt_fundef f). + destruct ros; simpl in H0. + pattern f. apply Genv.find_funct_prop with fundef unit p (rs#r). + exact wt_p. exact H0. + caseEq (Genv.find_symbol ge i); intros; rewrite H1 in H0. + pattern f. apply Genv.find_funct_ptr_prop with fundef unit p b. + exact wt_p. exact H0. + discriminate. + econstructor; eauto. + rewrite H5; auto. + rewrite <- H6. apply wt_regset_list. auto. + (* Ialloc *) + econstructor; eauto. + apply wt_regset_assign. auto. rewrite H6; exact I. + (* Icond *) + econstructor; eauto. + econstructor; eauto. + (* Ireturn *) + econstructor; eauto. + destruct or; simpl in *. + rewrite <- H1. apply WT_RS. exact I. + (* internal function *) + simpl in *. inv H5. inversion H1; subst. + econstructor; eauto. + apply wt_init_regs; auto. rewrite wt_params0; auto. + (* external function *) + simpl in *. inv H5. + econstructor; eauto. + change (Val.has_type res (proj_sig_res (ef_sig ef))). + eapply wt_event_match; eauto. + (* return *) + inv H1. econstructor; eauto. + apply wt_regset_assign; auto. congruence. +Qed. End SUBJECT_REDUCTION. diff --git a/backend/Registers.v b/backend/Registers.v index 578e4b87..e4b7b000 100644 --- a/backend/Registers.v +++ b/backend/Registers.v @@ -1,8 +1,9 @@ (** Pseudo-registers and register states. - This library defines the type of pseudo-registers used in the RTL - intermediate language, and of mappings from pseudo-registers to - values as used in the dynamic semantics of RTL. *) + This library defines the type of pseudo-registers (also known as + "temporaries" in compiler literature) used in the RTL + intermediate language. We also define finite sets and finite maps + over pseudo-registers. *) Require Import Coqlib. Require Import AST. diff --git a/backend/Reload.v b/backend/Reload.v new file mode 100644 index 00000000..58e17ff5 --- /dev/null +++ b/backend/Reload.v @@ -0,0 +1,211 @@ +(** Reloading, spilling, and explication of calling conventions. *) + +Require Import Coqlib. +Require Import Maps. +Require Import AST. +Require Import Integers. +Require Import Values. +Require Import Globalenvs. +Require Import Op. +Require Import Locations. +Require Import LTLin. +Require Import Conventions. +Require Import Parallelmove. +Require Import Linear. + +(** * Spilling and reloading *) + +(** Operations in the Linear language, like those of the target processor, + operate only over machine registers, but not over stack slots. + Consider the LTLin instruction +<< + r1 <- Lop(Oadd, r1 :: r2 :: nil) +>> + and assume that [r1] and [r2] are assigned to stack locations [S s1] + and [S s2], respectively. The translated LTL code must load these + stack locations into temporary integer registers (this is called + ``reloading''), perform the [Oadd] operation over these temporaries, + leave the result in a temporary, then store the temporary back to + stack location [S s1] (this is called ``spilling''). In other term, + the generated Linear code has the following shape: +<< + IT1 <- Lgetstack s1; + IT2 <- Lgetstack s2; + IT1 <- Lop(Oadd, IT1 :: IT2 :: nil); + Lsetstack s1 IT1; +>> + This section provides functions that assist in choosing appropriate + temporaries and inserting the required spilling and reloading + operations. *) + +(** ** Allocation of temporary registers for reloading and spilling. *) + +(** [reg_for l] returns a machine register appropriate for working + over the location [l]: either the machine register [m] if [l = R m], + or a temporary register of [l]'s type if [l] is a stack slot. *) + +Definition reg_for (l: loc) : mreg := + match l with + | R r => r + | S s => match slot_type s with Tint => IT1 | Tfloat => FT1 end + end. + +(** [regs_for ll] is similar, for a list of locations [ll] of length + at most 3. We ensure that distinct temporaries are used for + different elements of [ll]. *) + +Fixpoint regs_for_rec (locs: list loc) (itmps ftmps: list mreg) + {struct locs} : list mreg := + match locs, itmps, ftmps with + | l1 :: ls, it1 :: its, ft1 :: fts => + match l1 with + | R r => r + | S s => match slot_type s with Tint => it1 | Tfloat => ft1 end + end + :: regs_for_rec ls its fts + | _, _, _ => nil + end. + +Definition regs_for (locs: list loc) := + regs_for_rec locs (IT1 :: IT2 :: IT3 :: nil) (FT1 :: FT2 :: FT3 :: nil). + +(** ** Insertion of Linear reloads, stores and moves *) + +(** [add_spill src dst k] prepends to [k] the instructions needed + to assign location [dst] the value of machine register [mreg]. *) + +Definition add_spill (src: mreg) (dst: loc) (k: code) := + match dst with + | R rd => if mreg_eq src rd then k else Lop Omove (src :: nil) rd :: k + | S sl => Lsetstack src sl :: k + end. + +(** [add_reload src dst k] prepends to [k] the instructions needed + to assign machine register [mreg] the value of the location [src]. *) + +Definition add_reload (src: loc) (dst: mreg) (k: code) := + match src with + | R rs => if mreg_eq rs dst then k else Lop Omove (rs :: nil) dst :: k + | S sl => Lgetstack sl dst :: k + end. + +(** [add_reloads] is similar for a list of locations (as sources) + and a list of machine registers (as destinations). *) + +Fixpoint add_reloads (srcs: list loc) (dsts: list mreg) (k: code) + {struct srcs} : code := + match srcs, dsts with + | s1 :: sl, t1 :: tl => add_reload s1 t1 (add_reloads sl tl k) + | _, _ => k + end. + +(** [add_move src dst k] prepends to [k] the instructions that copy + the value of location [src] into location [dst]. *) + +Definition add_move (src dst: loc) (k: code) := + if Loc.eq src dst then k else + match src, dst with + | R rs, _ => + add_spill rs dst k + | _, R rd => + add_reload src rd k + | S ss, S sd => + let tmp := + match slot_type ss with Tint => IT1 | Tfloat => FT1 end in + add_reload src tmp (add_spill tmp dst k) + end. + +(** [parallel_move srcs dsts k] is similar, but for a list of + source locations and a list of destination locations of the same + length. This is a parallel move, meaning that some of the + destinations can also occur as sources. *) + +Definition parallel_move (srcs dsts: list loc) (k: code) : code := + List.fold_right + (fun p k => add_move (fst p) (snd p) k) + k (parmove srcs dsts). + +(** * Code transformation *) + +(** We insert appropriate reload, spill and parallel move operations + around each of the instructions of the source code. *) + +Definition transf_instr + (f: LTLin.function) (instr: LTLin.instruction) (k: code) : code := + match instr with + | LTLin.Lop op args res => + match is_move_operation op args with + | Some src => + add_move src res k + | None => + let rargs := regs_for args in + let rres := reg_for res in + add_reloads args rargs (Lop op rargs rres :: add_spill rres res k) + end + | LTLin.Lload chunk addr args dst => + let rargs := regs_for args in + let rdst := reg_for dst in + add_reloads args rargs + (Lload chunk addr rargs rdst :: add_spill rdst dst k) + | LTLin.Lstore chunk addr args src => + match regs_for (src :: args) with + | nil => nil (* never happens *) + | rsrc :: rargs => + add_reloads (src :: args) (rsrc :: rargs) + (Lstore chunk addr rargs rsrc :: k) + end + | LTLin.Lcall sig los args res => + let largs := loc_arguments sig in + let rres := loc_result sig in + match los with + | inl fn => + add_reload fn IT3 + (parallel_move args largs + (Lcall sig (inl _ IT3) :: add_spill rres res k)) + | inr id => + parallel_move args largs + (Lcall sig (inr _ id) :: add_spill rres res k) + end + | LTLin.Ltailcall sig los args => + let largs := loc_arguments sig in + match los with + | inl fn => + add_reload fn IT3 + (parallel_move args largs + (Ltailcall sig (inl _ IT3) :: k)) + | inr id => + parallel_move args largs + (Ltailcall sig (inr _ id) :: k) + end + | LTLin.Lalloc arg res => + add_reload arg loc_alloc_argument + (Lalloc :: add_spill loc_alloc_result res k) + | LTLin.Llabel lbl => + Llabel lbl :: k + | LTLin.Lgoto lbl => + Lgoto lbl :: k + | LTLin.Lcond cond args lbl => + let rargs := regs_for args in + add_reloads args rargs (Lcond cond rargs lbl :: k) + | LTLin.Lreturn None => + Lreturn :: k + | LTLin.Lreturn (Some loc) => + add_reload loc (loc_result (LTLin.fn_sig f)) (Lreturn :: k) + end. + +Definition transf_code (f: LTLin.function) (c: LTLin.code) : code := + List.fold_right (transf_instr f) nil c. + +Definition transf_function (f: LTLin.function) : function := + mkfunction + (LTLin.fn_sig f) + (LTLin.fn_stacksize f) + (parallel_move (loc_parameters (LTLin.fn_sig f)) (LTLin.fn_params f) + (transf_code f (LTLin.fn_code f))). + +Definition transf_fundef (fd: LTLin.fundef) : Linear.fundef := + transf_fundef transf_function fd. + +Definition transf_program (p: LTLin.program) : Linear.program := + transform_program transf_fundef p. + diff --git a/backend/Reloadproof.v b/backend/Reloadproof.v new file mode 100644 index 00000000..e9ced51f --- /dev/null +++ b/backend/Reloadproof.v @@ -0,0 +1,1230 @@ +(** Correctness proof for the [Reload] pass. *) + +Require Import Coqlib. +Require Import Maps. +Require Import AST. +Require Import Integers. +Require Import Values. +Require Import Mem. +Require Import Events. +Require Import Globalenvs. +Require Import Smallstep. +Require Import Op. +Require Import Locations. +Require Import Conventions. +Require Import Allocproof. +Require Import LTLin. +Require Import LTLintyping. +Require Import Linear. +Require Import Parallelmove. +Require Import Reload. + +(** * Exploitation of the typing hypothesis *) + +(** Reloading is applied to LTLin code that is well-typed in + the sense of [LTLintyping]. We exploit this hypothesis to obtain information on + the number of arguments to operations, addressing modes and conditions. *) + +Remark length_type_of_condition: + forall (c: condition), (List.length (type_of_condition c) <= 3)%nat. +Proof. + destruct c; unfold type_of_condition; simpl; omega. +Qed. + +Remark length_type_of_operation: + forall (op: operation), (List.length (fst (type_of_operation op)) <= 3)%nat. +Proof. + destruct op; unfold type_of_operation; simpl; try omega. + apply length_type_of_condition. +Qed. + +Remark length_type_of_addressing: + forall (addr: addressing), (List.length (type_of_addressing addr) <= 2)%nat. +Proof. + destruct addr; unfold type_of_addressing; simpl; omega. +Qed. + +Lemma length_op_args: + forall (op: operation) (args: list loc) (res: loc), + (List.map Loc.type args, Loc.type res) = type_of_operation op -> + (List.length args <= 3)%nat. +Proof. + intros. rewrite <- (list_length_map Loc.type). + generalize (length_type_of_operation op). + rewrite <- H. simpl. auto. +Qed. + +Lemma length_addr_args: + forall (addr: addressing) (args: list loc), + List.map Loc.type args = type_of_addressing addr -> + (List.length args <= 2)%nat. +Proof. + intros. rewrite <- (list_length_map Loc.type). + rewrite H. apply length_type_of_addressing. +Qed. + +Lemma length_cond_args: + forall (cond: condition) (args: list loc), + List.map Loc.type args = type_of_condition cond -> + (List.length args <= 3)%nat. +Proof. + intros. rewrite <- (list_length_map Loc.type). + rewrite H. apply length_type_of_condition. +Qed. + +(** * Correctness of the Linear constructors *) + +(** This section proves theorems that establish the correctness of the + Linear constructor functions such as [add_move]. The theorems are of + the general form ``the generated Linear instructions execute and + modify the location set in the expected way: the result location(s) + contain the expected values; other, non-temporary locations keep + their values''. *) + +Section LINEAR_CONSTRUCTORS. + +Variable ge: genv. +Variable stk: list stackframe. +Variable f: function. +Variable sp: val. + +Lemma reg_for_spec: + forall l, + R(reg_for l) = l \/ In (R (reg_for l)) temporaries. +Proof. + intros. unfold reg_for. destruct l. tauto. + case (slot_type s); simpl; tauto. +Qed. + +Lemma reg_for_diff: + forall l l', + Loc.diff l l' -> Loc.notin l' temporaries -> + Loc.diff (R (reg_for l)) l'. +Proof. + intros. destruct (reg_for_spec l). + rewrite H1; auto. + apply Loc.diff_sym. eapply Loc.in_notin_diff; eauto. +Qed. + +Lemma add_reload_correct: + forall src dst k rs m, + exists rs', + star step ge (State stk f sp (add_reload src dst k) rs m) + E0 (State stk f sp k rs' m) /\ + rs' (R dst) = rs src /\ + forall l, Loc.diff (R dst) l -> rs' l = rs l. +Proof. + intros. unfold add_reload. destruct src. + case (mreg_eq m0 dst); intro. + subst dst. exists rs. split. apply star_refl. tauto. + exists (Locmap.set (R dst) (rs (R m0)) rs). + split. apply star_one; apply exec_Lop. reflexivity. + split. apply Locmap.gss. + intros; apply Locmap.gso; auto. + exists (Locmap.set (R dst) (rs (S s)) rs). + split. apply star_one; apply exec_Lgetstack. + split. apply Locmap.gss. + intros; apply Locmap.gso; auto. +Qed. + +Lemma add_spill_correct: + forall src dst k rs m, + exists rs', + star step ge (State stk f sp (add_spill src dst k) rs m) + E0 (State stk f sp k rs' m) /\ + rs' dst = rs (R src) /\ + forall l, Loc.diff dst l -> rs' l = rs l. +Proof. + intros. unfold add_spill. destruct dst. + case (mreg_eq src m0); intro. + subst src. exists rs. split. apply star_refl. tauto. + exists (Locmap.set (R m0) (rs (R src)) rs). + split. apply star_one. apply exec_Lop. reflexivity. + split. apply Locmap.gss. + intros; apply Locmap.gso; auto. + exists (Locmap.set (S s) (rs (R src)) rs). + split. apply star_one. apply exec_Lsetstack. + split. apply Locmap.gss. + intros; apply Locmap.gso; auto. +Qed. + +Lemma add_reloads_correct_rec: + forall srcs itmps ftmps k rs m, + (List.length srcs <= List.length itmps)%nat -> + (List.length srcs <= List.length ftmps)%nat -> + (forall r, In (R r) srcs -> In r itmps -> False) -> + (forall r, In (R r) srcs -> In r ftmps -> False) -> + list_disjoint itmps ftmps -> + list_norepet itmps -> + list_norepet ftmps -> + exists rs', + star step ge + (State stk f sp (add_reloads srcs (regs_for_rec srcs itmps ftmps) k) rs m) + E0 (State stk f sp k rs' m) /\ + reglist rs' (regs_for_rec srcs itmps ftmps) = map rs srcs /\ + (forall r, ~(In r itmps) -> ~(In r ftmps) -> rs' (R r) = rs (R r)) /\ + (forall s, rs' (S s) = rs (S s)). +Proof. + induction srcs; simpl; intros. + (* base case *) + exists rs. split. apply star_refl. tauto. + (* inductive case *) + destruct itmps; simpl in H. omegaContradiction. + destruct ftmps; simpl in H0. omegaContradiction. + assert (R1: (length srcs <= length itmps)%nat). omega. + assert (R2: (length srcs <= length ftmps)%nat). omega. + assert (R3: forall r, In (R r) srcs -> In r itmps -> False). + intros. apply H1 with r. tauto. auto with coqlib. + assert (R4: forall r, In (R r) srcs -> In r ftmps -> False). + intros. apply H2 with r. tauto. auto with coqlib. + assert (R5: list_disjoint itmps ftmps). + eapply list_disjoint_cons_left. + eapply list_disjoint_cons_right. eauto. + assert (R6: list_norepet itmps). + inversion H4; auto. + assert (R7: list_norepet ftmps). + inversion H5; auto. + destruct a. + (* a is a register *) + generalize (IHsrcs itmps ftmps k rs m R1 R2 R3 R4 R5 R6 R7). + intros [rs' [EX [RES [OTH1 OTH2]]]]. + exists rs'. split. + unfold add_reload. case (mreg_eq m2 m2); intro; tauto. + split. simpl. apply (f_equal2 (@cons val)). + apply OTH1. + red; intro; apply H1 with m2. tauto. auto with coqlib. + red; intro; apply H2 with m2. tauto. auto with coqlib. + assumption. + split. intros. apply OTH1. simpl in H6; tauto. simpl in H7; tauto. + auto. + (* a is a stack location *) + set (tmp := match slot_type s with Tint => m0 | Tfloat => m1 end). + assert (NI: ~(In tmp itmps)). + unfold tmp; case (slot_type s). + inversion H4; auto. + apply list_disjoint_notin with (m1 :: ftmps). + apply list_disjoint_sym. apply list_disjoint_cons_left with m0. + auto. auto with coqlib. + assert (NF: ~(In tmp ftmps)). + unfold tmp; case (slot_type s). + apply list_disjoint_notin with (m0 :: itmps). + apply list_disjoint_cons_right with m1. + auto. auto with coqlib. + inversion H5; auto. + generalize + (add_reload_correct (S s) tmp + (add_reloads srcs (regs_for_rec srcs itmps ftmps) k) rs m). + intros [rs1 [EX1 [RES1 OTH]]]. + generalize (IHsrcs itmps ftmps k rs1 m R1 R2 R3 R4 R5 R6 R7). + intros [rs' [EX [RES [OTH1 OTH2]]]]. + exists rs'. + split. eapply star_trans; eauto. traceEq. + split. simpl. apply (f_equal2 (@cons val)). + rewrite OTH1; auto. + rewrite RES. apply list_map_exten. intros. + symmetry. apply OTH. + destruct x; try exact I. simpl. red; intro; subst m2. + generalize H6; unfold tmp. case (slot_type s). + intro. apply H1 with m0. tauto. auto with coqlib. + intro. apply H2 with m1. tauto. auto with coqlib. + split. intros. simpl in H6; simpl in H7. + rewrite OTH1. apply OTH. + simpl. unfold tmp. case (slot_type s); tauto. + tauto. tauto. + intros. rewrite OTH2. apply OTH. exact I. +Qed. + +Lemma add_reloads_correct: + forall srcs k rs m, + (List.length srcs <= 3)%nat -> + Loc.disjoint srcs temporaries -> + exists rs', + star step ge (State stk f sp (add_reloads srcs (regs_for srcs) k) rs m) + E0 (State stk f sp k rs' m) /\ + reglist rs' (regs_for srcs) = List.map rs srcs /\ + forall l, Loc.notin l temporaries -> rs' l = rs l. +Proof. + intros. + pose (itmps := IT1 :: IT2 :: IT3 :: nil). + pose (ftmps := FT1 :: FT2 :: FT3 :: nil). + assert (R1: (List.length srcs <= List.length itmps)%nat). + unfold itmps; simpl; assumption. + assert (R2: (List.length srcs <= List.length ftmps)%nat). + unfold ftmps; simpl; assumption. + assert (R3: forall r, In (R r) srcs -> In r itmps -> False). + intros. assert (In (R r) temporaries). + simpl in H2; simpl; intuition congruence. + generalize (H0 _ _ H1 H3). simpl. tauto. + assert (R4: forall r, In (R r) srcs -> In r ftmps -> False). + intros. assert (In (R r) temporaries). + simpl in H2; simpl; intuition congruence. + generalize (H0 _ _ H1 H3). simpl. tauto. + assert (R5: list_disjoint itmps ftmps). + red; intros r1 r2; simpl; intuition congruence. + assert (R6: list_norepet itmps). + unfold itmps. NoRepet. + assert (R7: list_norepet ftmps). + unfold ftmps. NoRepet. + generalize (add_reloads_correct_rec srcs itmps ftmps k rs m + R1 R2 R3 R4 R5 R6 R7). + intros [rs' [EX [RES [OTH1 OTH2]]]]. + exists rs'. split. exact EX. + split. exact RES. + intros. destruct l. apply OTH1. + generalize (Loc.notin_not_in _ _ H1). simpl. intuition congruence. + generalize (Loc.notin_not_in _ _ H1). simpl. intuition congruence. + apply OTH2. +Qed. + +Lemma add_move_correct: + forall src dst k rs m, + exists rs', + star step ge (State stk f sp (add_move src dst k) rs m) + E0 (State stk f sp k rs' m) /\ + rs' dst = rs src /\ + forall l, Loc.diff l dst -> Loc.diff l (R IT1) -> Loc.diff l (R FT1) -> rs' l = rs l. +Proof. + intros; unfold add_move. + case (Loc.eq src dst); intro. + subst dst. exists rs. split. apply star_refl. tauto. + destruct src. + (* src is a register *) + generalize (add_spill_correct m0 dst k rs m); intros [rs' [EX [RES OTH]]]. + exists rs'; intuition. apply OTH; apply Loc.diff_sym; auto. + destruct dst. + (* src is a stack slot, dst a register *) + generalize (add_reload_correct (S s) m0 k rs m); intros [rs' [EX [RES OTH]]]. + exists rs'; intuition. apply OTH; apply Loc.diff_sym; auto. + (* src and dst are stack slots *) + set (tmp := match slot_type s with Tint => IT1 | Tfloat => FT1 end). + generalize (add_reload_correct (S s) tmp (add_spill tmp (S s0) k) rs m); + intros [rs1 [EX1 [RES1 OTH1]]]. + generalize (add_spill_correct tmp (S s0) k rs1 m); + intros [rs2 [EX2 [RES2 OTH2]]]. + exists rs2. split. + eapply star_trans; eauto. traceEq. + split. congruence. + intros. rewrite OTH2. apply OTH1. + apply Loc.diff_sym. unfold tmp; case (slot_type s); auto. + apply Loc.diff_sym; auto. +Qed. + +Lemma effect_move_sequence: + forall k moves rs m, + let k' := List.fold_right (fun p k => add_move (fst p) (snd p) k) k moves in + exists rs', + star step ge (State stk f sp k' rs m) + E0 (State stk f sp k rs' m) /\ + effect_seqmove moves rs rs'. +Proof. + induction moves; intros until m; simpl. + exists rs; split. constructor. constructor. + destruct a as [src dst]; simpl. + set (k1 := fold_right + (fun (p : loc * loc) (k : code) => add_move (fst p) (snd p) k) + k moves) in *. + destruct (add_move_correct src dst k1 rs m) as [rs1 [A [B C]]]. + destruct (IHmoves rs1 m) as [rs' [D E]]. + exists rs'; split. + eapply star_trans; eauto. traceEq. + econstructor; eauto. red. tauto. +Qed. + +Lemma parallel_move_correct: + forall srcs dsts k rs m, + List.length srcs = List.length dsts -> + Loc.no_overlap srcs dsts -> + Loc.norepet dsts -> + Loc.disjoint srcs temporaries -> + Loc.disjoint dsts temporaries -> + exists rs', + star step ge (State stk f sp (parallel_move srcs dsts k) rs m) + E0 (State stk f sp k rs' m) /\ + List.map rs' dsts = List.map rs srcs /\ + rs' (R IT3) = rs (R IT3) /\ + forall l, Loc.notin l dsts -> Loc.notin l temporaries -> rs' l = rs l. +Proof. + intros. + generalize (effect_move_sequence k (parmove srcs dsts) rs m). + intros [rs' [EXEC EFFECT]]. + exists rs'. split. exact EXEC. + apply effect_parmove; auto. +Qed. + +Lemma parallel_move_arguments_correct: + forall args sg k rs m, + List.map Loc.type args = sg.(sig_args) -> + locs_acceptable args -> + exists rs', + star step ge (State stk f sp (parallel_move args (loc_arguments sg) k) rs m) + E0 (State stk f sp k rs' m) /\ + List.map rs' (loc_arguments sg) = List.map rs args /\ + rs' (R IT3) = rs (R IT3) /\ + forall l, Loc.notin l (loc_arguments sg) -> Loc.notin l temporaries -> rs' l = rs l. +Proof. + intros. apply parallel_move_correct. + transitivity (length sg.(sig_args)). + rewrite <- H. symmetry; apply list_length_map. + symmetry. apply loc_arguments_length. + apply no_overlap_arguments; auto. + apply loc_arguments_norepet. + apply locs_acceptable_disj_temporaries; auto. + apply loc_arguments_not_temporaries. +Qed. + +Lemma parallel_move_parameters_correct: + forall params sg k rs m, + List.map Loc.type params = sg.(sig_args) -> + locs_acceptable params -> + Loc.norepet params -> + exists rs', + star step ge (State stk f sp (parallel_move (loc_parameters sg) params k) rs m) + E0 (State stk f sp k rs' m) /\ + List.map rs' params = List.map rs (loc_parameters sg) /\ + rs' (R IT3) = rs (R IT3) /\ + forall l, Loc.notin l params -> Loc.notin l temporaries -> rs' l = rs l. +Proof. + intros. apply parallel_move_correct. + transitivity (length sg.(sig_args)). + apply loc_parameters_length. + rewrite <- H. apply list_length_map. + apply no_overlap_parameters; auto. + auto. apply loc_parameters_not_temporaries. + apply locs_acceptable_disj_temporaries; auto. +Qed. + +End LINEAR_CONSTRUCTORS. + +(** * Agreement between values of locations *) + +(** The predicate [agree] states that two location maps + give the same values to all acceptable locations, + that is, non-temporary registers and [Local] stack slots. *) + +Definition agree (rs1 rs2: locset) : Prop := + forall l, loc_acceptable l -> rs2 l = rs1 l. + +Lemma agree_loc: + forall rs1 rs2 l, + agree rs1 rs2 -> loc_acceptable l -> rs2 l = rs1 l. +Proof. + auto. +Qed. + +Lemma agree_locs: + forall rs1 rs2 ll, + agree rs1 rs2 -> locs_acceptable ll -> map rs2 ll = map rs1 ll. +Proof. + induction ll; simpl; intros. + auto. + f_equal. apply H. apply H0; auto with coqlib. + apply IHll; auto. red; intros. apply H0; auto with coqlib. +Qed. + +Lemma agree_exten: + forall rs ls1 ls2, + agree rs ls1 -> + (forall l, Loc.notin l temporaries -> ls2 l = ls1 l) -> + agree rs ls2. +Proof. + intros; red; intros. rewrite H0. auto. + apply temporaries_not_acceptable; auto. +Qed. + +Lemma agree_set: + forall rs1 rs2 rs2' l v, + loc_acceptable l -> + rs2' l = v -> + (forall l', Loc.diff l l' -> Loc.notin l' temporaries -> rs2' l' = rs2 l') -> + agree rs1 rs2 -> agree (Locmap.set l v rs1) rs2'. +Proof. + intros; red; intros. + destruct (Loc.eq l l0). + subst l0. rewrite Locmap.gss. auto. + assert (Loc.diff l l0). eapply loc_acceptable_noteq_diff; eauto. + rewrite Locmap.gso; auto. rewrite H1. auto. auto. + apply temporaries_not_acceptable; auto. +Qed. + +Lemma agree_return_regs: + forall rs1 ls1 rs2 ls2, + agree rs1 ls1 -> agree rs2 ls2 -> + agree (LTL.return_regs rs1 rs2) (LTL.return_regs ls1 ls2). +Proof. + intros; red; intros. unfold LTL.return_regs. + assert (~In l temporaries). + apply Loc.notin_not_in. apply temporaries_not_acceptable; auto. + destruct l. + destruct (In_dec Loc.eq (R m) temporaries). contradiction. + destruct (In_dec Loc.eq (R m) destroyed_at_call); auto. + auto. +Qed. + +Lemma agree_set_result: + forall rs1 ls1 rs2 ls2 sig res ls3, + loc_acceptable res -> agree rs1 ls1 -> agree rs2 ls2 -> + ls3 res = LTL.return_regs ls1 ls2 (R (loc_result sig)) -> + (forall l : loc, Loc.diff res l -> ls3 l = LTL.return_regs ls1 ls2 l) -> + let rs_merge := LTL.return_regs rs1 rs2 in + agree (Locmap.set res (rs_merge (R (loc_result sig))) rs_merge) ls3. +Proof. + intros. apply agree_set with (LTL.return_regs ls1 ls2); auto. + rewrite H2; unfold rs_merge. + repeat rewrite return_regs_result. apply H1. apply loc_result_acceptable. + unfold rs_merge. apply agree_return_regs; auto. +Qed. + +(** [agree_arguments] and [agree_parameters] are two stronger + variants of the predicate [agree]. They additionally demand + equality of the values of locations that are arguments or parameters + (respectively) for a call to a function of signature [sg]. *) + +Definition agree_arguments (sg: signature) (rs1 rs2: locset) : Prop := + forall l, loc_acceptable l \/ In l (loc_arguments sg) -> rs2 l = rs1 l. + +Definition agree_parameters (sg: signature) (rs1 rs2: locset) : Prop := + forall l, loc_acceptable l \/ In l (loc_parameters sg) -> rs2 l = rs1 l. + +Remark parallel_assignment: + forall (P: loc -> Prop) (rs1 rs2 ls1 ls2: locset) srcs dsts, + map rs2 dsts = map rs1 srcs -> + map ls2 dsts = map ls1 srcs -> + (forall l, In l srcs -> P l) -> + (forall l, P l -> ls1 l = rs1 l) -> + (forall l, In l dsts -> ls2 l = rs2 l). +Proof. + induction srcs; destruct dsts; simpl; intros; try congruence. + contradiction. + inv H; inv H0. elim H3; intro. subst l0. + rewrite H5; rewrite H4. auto with coqlib. + eapply IHsrcs; eauto. +Qed. + +Lemma agree_set_arguments: + forall rs1 ls1 ls2 args sg, + agree rs1 ls1 -> + List.map Loc.type args = sg.(sig_args) -> + locs_acceptable args -> + List.map ls2 (loc_arguments sg) = map ls1 args -> + (forall l : loc, + Loc.notin l (loc_arguments sg) -> + Loc.notin l temporaries -> ls2 l = ls1 l) -> + agree_arguments sg (LTL.parmov args (loc_arguments sg) rs1) ls2. +Proof. + intros. + assert (Loc.norepet (loc_arguments sg)). + apply loc_arguments_norepet. + assert (List.length args = List.length (loc_arguments sg)). + rewrite loc_arguments_length. rewrite <- H0. + symmetry. apply list_length_map. + destruct (parmov_spec rs1 _ _ H4 H5) as [A B]. + set (rs2 := LTL.parmov args (loc_arguments sg) rs1) in *. + assert (forall l, In l (loc_arguments sg) -> ls2 l = rs2 l). + intros. + eapply parallel_assignment with (P := loc_acceptable); eauto. + red; intros. + destruct (In_dec Loc.eq l (loc_arguments sg)). + auto. + assert (loc_acceptable l) by tauto. + assert (Loc.notin l (loc_arguments sg)). + eapply loc_acceptable_notin_notin; eauto. + rewrite H3; auto. rewrite B; auto. + apply temporaries_not_acceptable; auto. +Qed. + +Lemma agree_arguments_agree: + forall sg rs ls, agree_arguments sg rs ls -> agree rs ls. +Proof. + intros; red; intros; auto. +Qed. + +Lemma agree_arguments_locs: + forall sg rs1 rs2, + agree_arguments sg rs1 rs2 -> + map rs2 (loc_arguments sg) = map rs1 (loc_arguments sg). +Proof. + intros. + assert (forall ll, incl ll (loc_arguments sg) -> map rs2 ll = map rs1 ll). + induction ll; simpl; intros. auto. + f_equal. apply H. right. apply H0. auto with coqlib. + apply IHll. eapply incl_cons_inv; eauto. + apply H0. apply incl_refl. +Qed. + +Lemma agree_set_parameters: + forall rs1 ls1 ls2 sg params, + agree_parameters sg rs1 ls1 -> + List.map Loc.type params = sg.(sig_args) -> + locs_acceptable params -> + Loc.norepet params -> + List.map ls2 params = List.map ls1 (loc_parameters sg) -> + (forall l : loc, + Loc.notin l params -> + Loc.notin l temporaries -> ls2 l = ls1 l) -> + agree (LTL.parmov (loc_parameters sg) params rs1) ls2. +Proof. + intros. + assert (List.length (loc_parameters sg) = List.length params). + unfold loc_parameters. rewrite list_length_map. + rewrite loc_arguments_length. rewrite <- H0. + apply list_length_map. + destruct (parmov_spec rs1 _ _ H2 H5) as [A B]. + set (rs2 := LTL.parmov (loc_parameters sg) params rs1) in *. + red; intros. + assert (forall l, In l params -> ls2 l = rs2 l). + intros. + eapply parallel_assignment with (P := fun l => In l (loc_parameters sg)); eauto. + destruct (In_dec Loc.eq l params). + auto. + assert (Loc.notin l params). + eapply loc_acceptable_notin_notin; eauto. + rewrite B; auto. rewrite H4; auto. + apply temporaries_not_acceptable; auto. +Qed. + +Lemma agree_call_regs: + forall sg rs ls, + agree_arguments sg rs ls -> + agree_parameters sg (LTL.call_regs rs) (LTL.call_regs ls). +Proof. + intros; red; intros. elim H0. + destruct l; simpl; auto. destruct s; auto. + unfold loc_parameters. intro. + destruct (list_in_map_inv _ _ _ H1) as [r [A B]]. + subst l. generalize (loc_arguments_acceptable _ _ B). + destruct r; simpl; auto. destruct s; simpl; auto. +Qed. + +Lemma agree_arguments_return_regs: + forall sg rs1 rs2 ls1 ls2, + tailcall_possible sg -> + agree rs1 ls1 -> + agree_arguments sg rs2 ls2 -> + agree_arguments sg (LTL.return_regs rs1 rs2) (LTL.return_regs ls1 ls2). +Proof. + intros; red; intros. generalize (H1 l H2). intro. + elim H2; intro. generalize (H0 l H4); intro. + unfold LTL.return_regs. destruct l; auto. + destruct (In_dec Loc.eq (R m) temporaries); auto. + destruct (In_dec Loc.eq (R m) destroyed_at_call); auto. + generalize (H l H4). unfold LTL.return_regs; destruct l; intro. + destruct (In_dec Loc.eq (R m) temporaries); auto. + destruct (In_dec Loc.eq (R m) destroyed_at_call); auto. + contradiction. +Qed. + +(** * Preservation of labels and gotos *) + +Lemma find_label_add_spill: + forall lbl src dst k, + find_label lbl (add_spill src dst k) = find_label lbl k. +Proof. + intros. destruct dst; simpl; auto. + destruct (mreg_eq src m); auto. +Qed. + +Lemma find_label_add_reload: + forall lbl src dst k, + find_label lbl (add_reload src dst k) = find_label lbl k. +Proof. + intros. destruct src; simpl; auto. + destruct (mreg_eq m dst); auto. +Qed. + +Lemma find_label_add_reloads: + forall lbl srcs dsts k, + find_label lbl (add_reloads srcs dsts k) = find_label lbl k. +Proof. + induction srcs; intros; simpl. auto. + destruct dsts; auto. rewrite find_label_add_reload. auto. +Qed. + +Lemma find_label_add_move: + forall lbl src dst k, + find_label lbl (add_move src dst k) = find_label lbl k. +Proof. + intros; unfold add_move. + destruct (Loc.eq src dst); auto. + destruct src. apply find_label_add_spill. + destruct dst. apply find_label_add_reload. + rewrite find_label_add_reload. apply find_label_add_spill. +Qed. + +Lemma find_label_parallel_move: + forall lbl srcs dsts k, + find_label lbl (parallel_move srcs dsts k) = find_label lbl k. +Proof. + intros. unfold parallel_move. generalize (parmove srcs dsts). + induction m; simpl. auto. + rewrite find_label_add_move. auto. +Qed. + +Hint Rewrite find_label_add_spill find_label_add_reload + find_label_add_reloads find_label_add_move + find_label_parallel_move: labels. + +Opaque reg_for. + +Ltac FL := simpl; autorewrite with labels; auto. + +Lemma find_label_transf_instr: + forall lbl sg instr k, + find_label lbl (transf_instr sg instr k) = + if LTLin.is_label lbl instr then Some k else find_label lbl k. +Proof. + intros. destruct instr; FL. + destruct (is_move_operation o l); FL; FL. + FL. + destruct s0; FL; FL; FL. + destruct s0; FL; FL; FL. + FL. + destruct o; FL. +Qed. + +Lemma find_label_transf_code: + forall sg lbl c, + find_label lbl (transf_code sg c) = + option_map (transf_code sg) (LTLin.find_label lbl c). +Proof. + induction c; simpl. + auto. + rewrite find_label_transf_instr. + destruct (LTLin.is_label lbl a); auto. +Qed. + +Lemma find_label_transf_function: + forall lbl f c, + LTLin.find_label lbl (LTLin.fn_code f) = Some c -> + find_label lbl (Linear.fn_code (transf_function f)) = + Some (transf_code f c). +Proof. + intros. destruct f; simpl in *. FL. + rewrite find_label_transf_code. rewrite H; auto. +Qed. + +(** * Semantic preservation *) + +Section PRESERVATION. + +Variable prog: LTLin.program. +Let tprog := transf_program prog. +Hypothesis WT_PROG: LTLintyping.wt_program prog. + +Let ge := Genv.globalenv prog. +Let tge := Genv.globalenv tprog. + +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). + +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). + +Lemma symbols_preserved: + forall id, + Genv.find_symbol tge id = Genv.find_symbol ge id. +Proof (@Genv.find_symbol_transf _ _ _ transf_fundef prog). + +Lemma sig_preserved: + forall f, funsig (transf_fundef f) = LTLin.funsig f. +Proof. + destruct f; reflexivity. +Qed. + +Lemma find_function_wt: + forall ros rs f, + LTLin.find_function ge ros rs = Some f -> wt_fundef f. +Proof. + intros until f. destruct ros; simpl. + intro. eapply Genv.find_funct_prop with (p := prog); eauto. + caseEq (Genv.find_symbol ge i); intros. + eapply Genv.find_funct_ptr_prop with (p := prog); eauto. + congruence. +Qed. + +(** The [match_state] predicate relates states in the original LTLin + program and the transformed Linear program. The main property + it enforces are: +- Agreement between the values of locations in the two programs, + according to the [agree] or [agree_arguments] predicates. +- Lists of LTLin instructions appearing in the source state + are always suffixes of the code for the corresponding functions. +- Well-typedness of the source code, which ensures that + only acceptable locations are accessed by this code. +*) + +Inductive match_stackframes: list LTLin.stackframe -> list Linear.stackframe -> signature -> Prop := + | match_stackframes_nil: + forall tyargs, + match_stackframes nil nil (mksignature tyargs (Some Tint)) + | match_stackframes_cons: + forall res f sp c rs s s' c' ls sig, + match_stackframes s s' (LTLin.fn_sig f) -> + c' = add_spill (loc_result sig) res (transf_code f c) -> + agree rs ls -> + loc_acceptable res -> + wt_function f -> + is_tail c (LTLin.fn_code f) -> + match_stackframes (LTLin.Stackframe res f sp rs c :: s) + (Linear.Stackframe (transf_function f) sp ls c' :: s') + sig. + +Inductive match_states: LTLin.state -> Linear.state -> Prop := + | match_states_intro: + forall s f sp c rs m s' ls + (STACKS: match_stackframes s s' (LTLin.fn_sig f)) + (AG: agree rs ls) + (WT: wt_function f) + (TL: is_tail c (LTLin.fn_code f)), + match_states (LTLin.State s f sp c rs m) + (Linear.State s' (transf_function f) sp (transf_code f c) ls m) + | match_states_call: + forall s f rs m s' ls + (STACKS: match_stackframes s s' (LTLin.funsig f)) + (AG: agree_arguments (LTLin.funsig f) rs ls) + (WT: wt_fundef f), + match_states (LTLin.Callstate s f rs m) + (Linear.Callstate s' (transf_fundef f) ls m) + | match_states_return: + forall s sig rs m s' ls + (STACKS: match_stackframes s s' sig) + (AG: agree rs ls), + match_states (LTLin.Returnstate s sig rs m) + (Linear.Returnstate s' ls m). + +Remark parent_locset_match: + forall s s' sig, + match_stackframes s s' sig -> + agree (LTLin.parent_locset s) (parent_locset s'). +Proof. + induction 1; simpl. + red; intros; auto. + auto. +Qed. + +Remark match_stackframes_inv: + forall s ts sig, + match_stackframes s ts sig -> + forall sig', sig_res sig' = sig_res sig -> + match_stackframes s ts sig'. +Proof. + induction 1; intros. + destruct sig'. simpl in H; inv H. constructor. + assert (loc_result sig' = loc_result sig). + unfold loc_result. rewrite H5; auto. + econstructor; eauto. rewrite H6; auto. +Qed. + +Ltac ExploitWT := + match goal with + | [ WT: wt_function _, TL: is_tail _ _ |- _ ] => + generalize (wt_instrs _ WT _ (is_tail_in TL)); intro WTI + end. + +(** The proof of semantic preservation is a simulation argument + based on diagrams of the following form: +<< + st1 --------------- st2 + | | + t| *|t + | | + v v + st1'--------------- st2' +>> + It is possible for the transformed code to take no transition, + remaining in the same state; for instance, if the source transition + corresponds to a move instruction that was eliminated. + To ensure that this cannot occur infinitely often in a row, + we use the following [measure] function that just counts the + remaining number of instructions in the source code sequence. *) + +Definition measure (st: LTLin.state) : nat := + match st with + | LTLin.State s f sp c ls m => List.length c + | LTLin.Callstate s f ls m => 0%nat + | LTLin.Returnstate s sig ls m => 0%nat + end. + +Theorem transf_step_correct: + forall s1 t s2, LTLin.step ge s1 t s2 -> + forall s1' (MS: match_states s1 s1'), + (exists s2', plus Linear.step tge s1' t s2' /\ match_states s2 s2') + \/ (measure s2 < measure s1 /\ t = E0 /\ match_states s2 s1')%nat. +Proof. + Opaque regs_for. Opaque add_reloads. + induction 1; intros; try inv MS; simpl. + + (* Lop *) + ExploitWT. inv WTI. + (* move *) + simpl. + destruct (add_move_correct tge s' (transf_function f) sp r1 res (transf_code f b) ls m) + as [ls2 [A [B C]]]. + inv A. + right. split. omega. split. auto. + rewrite H1. rewrite H1. econstructor; eauto with coqlib. + apply agree_set with ls2; auto. + rewrite B. simpl in H; inversion H. auto. + left; econstructor; split. eapply plus_left; eauto. + econstructor; eauto with coqlib. + apply agree_set with ls; auto. + rewrite B. simpl in H; inversion H. auto. + intros. simpl in H1. apply C. apply Loc.diff_sym; auto. + simpl in H7; tauto. simpl in H7; tauto. + (* other ops *) + assert (is_move_operation op args = None). + caseEq (is_move_operation op args); intros. + destruct (is_move_operation_correct _ _ H0). congruence. + auto. + rewrite H0. + exploit add_reloads_correct. + eapply length_op_args; eauto. + apply locs_acceptable_disj_temporaries; auto. + intros [ls2 [A [B C]]]. + exploit add_spill_correct. + intros [ls3 [D [E F]]]. + left; econstructor; split. + eapply star_plus_trans. eexact A. + eapply plus_left. eapply exec_Lop with (v := v). + rewrite <- H. rewrite B. rewrite (agree_locs _ _ _ AG H5). + apply eval_operation_preserved. exact symbols_preserved. + eexact D. eauto. traceEq. + econstructor; eauto with coqlib. + apply agree_set with ls; auto. + rewrite E. apply Locmap.gss. + intros. rewrite F; auto. rewrite Locmap.gso. auto. + apply reg_for_diff; auto. + + (* Lload *) + ExploitWT; inv WTI. + exploit add_reloads_correct. + apply le_S. eapply length_addr_args; eauto. + apply locs_acceptable_disj_temporaries; auto. + intros [ls2 [A [B C]]]. + exploit add_spill_correct. + intros [ls3 [D [E F]]]. + left; econstructor; split. + eapply star_plus_trans. eauto. + eapply plus_left. eapply exec_Lload; eauto. + rewrite B. rewrite <- H. rewrite (agree_locs _ _ _ AG H7). + apply eval_addressing_preserved. exact symbols_preserved. + eauto. auto. traceEq. + econstructor; eauto with coqlib. + apply agree_set with ls; auto. + rewrite E. apply Locmap.gss. + intros. rewrite F; auto. rewrite Locmap.gso. auto. + apply reg_for_diff; auto. + + (* Lstore *) + ExploitWT; inv WTI. + assert (exists rsrc, exists rargs, regs_for (src :: args) = rsrc :: rargs). + Transparent regs_for. unfold regs_for. simpl. + destruct src. econstructor; econstructor; eauto. + destruct (slot_type s0); econstructor; econstructor; eauto. + destruct H1 as [rsrc [rargs EQ]]. rewrite EQ. + assert (length (src :: args) <= 3)%nat. + simpl. apply le_n_S. + eapply length_addr_args; eauto. + exploit add_reloads_correct. + eauto. apply locs_acceptable_disj_temporaries; auto. + red; intros. elim H2; intro; auto. subst l; auto. + intros [ls2 [A [B C]]]. rewrite EQ in A. rewrite EQ in B. + injection B. intros D E. + simpl in B. + left; econstructor; split. + eapply plus_right. eauto. + eapply exec_Lstore with (a := a); eauto. + rewrite D. rewrite <- H. rewrite (agree_locs _ _ _ AG H7). + apply eval_addressing_preserved. exact symbols_preserved. + rewrite E. rewrite (agree_loc _ _ _ AG H8). eauto. + traceEq. + econstructor; eauto with coqlib. + apply agree_exten with ls; auto. + + (* Lcall *) + inversion MS. subst s0 f0 sp0 c rs0 m0. + simpl transf_code. + ExploitWT. inversion WTI. subst sig0 ros0 args0 res0. + assert (WTF': wt_fundef f'). eapply find_function_wt; eauto. + destruct ros as [fn | id]. + (* indirect call *) + destruct (add_reload_correct tge s' (transf_function f) sp fn IT3 + (parallel_move args (loc_arguments sig) + (Lcall sig (inl ident IT3) + :: add_spill (loc_result sig) res (transf_code f b))) + ls m) + as [ls2 [A [B C]]]. + destruct (parallel_move_arguments_correct tge s' (transf_function f) sp + args sig + (Lcall sig (inl ident IT3) + :: add_spill (loc_result sig) res (transf_code f b)) + ls2 m H7 H10) + as [ls3 [D [E [F G]]]]. + assert (AG_ARGS: agree_arguments (LTLin.funsig f') rs1 ls3). + rewrite <- H0. + unfold rs1. apply agree_set_arguments with ls; auto. + rewrite E. apply list_map_exten; intros. symmetry. apply C. + assert (Loc.notin x temporaries). apply temporaries_not_acceptable; auto. + simpl in H3. apply Loc.diff_sym. tauto. + intros. rewrite G; auto. apply C. + simpl in H3. apply Loc.diff_sym. tauto. + left; econstructor; split. + eapply star_plus_trans. eauto. eapply plus_right. eauto. + eapply exec_Lcall; eauto. + simpl. rewrite F. rewrite B. + rewrite (agree_loc rs ls fn); auto. + apply functions_translated. eauto. + rewrite H0; symmetry; apply sig_preserved. + eauto. traceEq. + econstructor; eauto. + econstructor; eauto with coqlib. + rewrite H0. auto. + eapply agree_arguments_agree; eauto. + (* direct call *) + destruct (parallel_move_arguments_correct tge s' (transf_function f) sp + args sig + (Lcall sig (inr mreg id) + :: add_spill (loc_result sig) res (transf_code f b)) + ls m H7 H10) + as [ls3 [D [E [F G]]]]. + assert (AG_ARGS: agree_arguments (LTLin.funsig f') rs1 ls3). + rewrite <- H0. + unfold rs1. apply agree_set_arguments with ls; auto. + left; econstructor; split. + eapply plus_right. eauto. + eapply exec_Lcall; eauto. + simpl. rewrite symbols_preserved. + generalize H; simpl. destruct (Genv.find_symbol ge id). + apply function_ptr_translated; auto. congruence. + rewrite H0. symmetry; apply sig_preserved. + traceEq. + econstructor; eauto. + econstructor; eauto with coqlib. + rewrite H0; auto. + eapply agree_arguments_agree; eauto. + + (* Ltailcall *) + inversion MS. subst s0 f0 sp c rs0 m0 s1'. + simpl transf_code. + ExploitWT. inversion WTI. subst sig0 ros0 args0. + assert (WTF': wt_fundef f'). eapply find_function_wt; eauto. + destruct ros as [fn | id]. + (* indirect call *) + destruct (add_reload_correct tge s' (transf_function f) (Vptr stk Int.zero) fn IT3 + (parallel_move args (loc_arguments sig) + (Ltailcall sig (inl ident IT3) :: transf_code f b)) + ls m) + as [ls2 [A [B C]]]. + destruct (parallel_move_arguments_correct tge s' (transf_function f) (Vptr stk Int.zero) + args sig + (Ltailcall sig (inl ident IT3) :: transf_code f b) + ls2 m H5 H7) + as [ls3 [D [E [F G]]]]. + assert (AG_ARGS: agree_arguments (LTLin.funsig f') rs2 (LTL.return_regs (parent_locset s') ls3)). + rewrite <- H0. unfold rs2. + apply agree_arguments_return_regs; auto. + eapply parent_locset_match; eauto. + unfold rs1. apply agree_set_arguments with ls; auto. + rewrite E. apply list_map_exten; intros. symmetry. apply C. + assert (Loc.notin x temporaries). apply temporaries_not_acceptable; auto. + simpl in H2. apply Loc.diff_sym. tauto. + intros. rewrite G; auto. apply C. + simpl in H2. apply Loc.diff_sym. tauto. + left; econstructor; split. + eapply star_plus_trans. eauto. eapply plus_right. eauto. + eapply exec_Ltailcall; eauto. + simpl. rewrite F. rewrite B. + rewrite (agree_loc rs ls fn); auto. + apply functions_translated. eauto. + rewrite H0; symmetry; apply sig_preserved. + eauto. traceEq. + econstructor; eauto. + eapply match_stackframes_inv; eauto. congruence. + + (* direct call *) + destruct (parallel_move_arguments_correct tge s' (transf_function f) (Vptr stk Int.zero) + args sig + (Ltailcall sig (inr mreg id) :: transf_code f b) + ls m H5 H7) + as [ls3 [D [E [F G]]]]. + assert (AG_ARGS: agree_arguments (LTLin.funsig f') rs2 (LTL.return_regs (parent_locset s') ls3)). + rewrite <- H0. unfold rs2. + apply agree_arguments_return_regs; auto. + eapply parent_locset_match; eauto. + unfold rs1. apply agree_set_arguments with ls; auto. + left; econstructor; split. + eapply plus_right. eauto. + eapply exec_Ltailcall; eauto. + simpl. rewrite symbols_preserved. + generalize H; simpl. destruct (Genv.find_symbol ge id). + apply function_ptr_translated; auto. congruence. + rewrite H0. symmetry; apply sig_preserved. + traceEq. + econstructor; eauto. + eapply match_stackframes_inv; eauto. congruence. + + (* Lalloc *) + ExploitWT; inv WTI. + exploit add_reload_correct. intros [ls2 [A [B C]]]. + exploit add_spill_correct. intros [ls3 [D [E F]]]. + left; econstructor; split. + eapply star_plus_trans. eauto. + eapply plus_left. eapply exec_Lalloc; eauto. + rewrite B. rewrite <- H. apply AG. auto. + eauto. eauto. traceEq. + econstructor; eauto with coqlib. + unfold rs3; apply agree_set with (Locmap.set (R loc_alloc_result) (Vptr blk Int.zero) ls2). + auto. rewrite E. rewrite Locmap.gss. + unfold rs2; rewrite Locmap.gss. auto. + auto. + unfold rs2. apply agree_set with ls2. + unfold loc_alloc_result; simpl; intuition congruence. + apply Locmap.gss. intros. apply Locmap.gso; auto. + unfold rs1. apply agree_set with ls. + unfold loc_alloc_argument; simpl; intuition congruence. + rewrite B. apply AG; auto. auto. auto. + + (* Llabel *) + left; econstructor; split. + apply plus_one. apply exec_Llabel. + econstructor; eauto with coqlib. + + (* Lgoto *) + left; econstructor; split. + apply plus_one. apply exec_Lgoto. apply find_label_transf_function; eauto. + econstructor; eauto. + eapply LTLin.find_label_is_tail; eauto. + + (* Lcond true *) + ExploitWT; inv WTI. + exploit add_reloads_correct. + eapply length_cond_args; eauto. + apply locs_acceptable_disj_temporaries; auto. + intros [ls2 [A [B C]]]. + left; econstructor; split. + eapply plus_right. eauto. eapply exec_Lcond_true; eauto. + rewrite B. rewrite (agree_locs _ _ _ AG H5). auto. + apply find_label_transf_function; eauto. + traceEq. + econstructor; eauto. + apply agree_exten with ls; auto. + eapply LTLin.find_label_is_tail; eauto. + + (* Lcond false *) + ExploitWT; inv WTI. + exploit add_reloads_correct. + eapply length_cond_args; eauto. + apply locs_acceptable_disj_temporaries; auto. + intros [ls2 [A [B C]]]. + left; econstructor; split. + eapply plus_right. eauto. eapply exec_Lcond_false; eauto. + rewrite B. rewrite (agree_locs _ _ _ AG H4). auto. + traceEq. + econstructor; eauto with coqlib. + apply agree_exten with ls; auto. + + (* Lreturn *) + ExploitWT; inv WTI. + unfold rs2, rs1; destruct or; simpl. + (* with an argument *) + exploit add_reload_correct. + intros [ls2 [A [B C]]]. + left; econstructor; split. + eapply plus_right. eauto. eapply exec_Lreturn; eauto. + traceEq. + econstructor; eauto. + apply agree_return_regs; auto. + eapply parent_locset_match; eauto. + apply agree_set with ls. + apply loc_result_acceptable. + rewrite B. eapply agree_loc; eauto. + auto. auto. + (* without an argument *) + left; econstructor; split. + apply plus_one. eapply exec_Lreturn; eauto. + econstructor; eauto. + apply agree_return_regs; auto. + eapply parent_locset_match; eauto. + + (* internal function *) + simpl in WT. inversion_clear WT. inversion H0. simpl in AG. + destruct (parallel_move_parameters_correct tge s' (transf_function f) + (Vptr stk Int.zero) (LTLin.fn_params f) (LTLin.fn_sig f) + (transf_code f (LTLin.fn_code f)) (LTL.call_regs ls) m' + wt_params wt_acceptable wt_norepet) + as [ls2 [A [B [C D]]]]. + assert (AG2: agree rs2 ls2). + unfold rs2. eapply agree_set_parameters; eauto. + unfold rs1. apply agree_call_regs; auto. + left; econstructor; split. + eapply plus_left. + eapply exec_function_internal; eauto. + simpl. eauto. traceEq. + econstructor; eauto with coqlib. + + (* external function *) + left; econstructor; split. + apply plus_one. eapply exec_function_external; eauto. + unfold args. symmetry. eapply agree_arguments_locs; auto. + econstructor; eauto. + unfold rs1. apply agree_set with ls; auto. + apply loc_result_acceptable. + apply Locmap.gss. + intros. apply Locmap.gso; auto. + eapply agree_arguments_agree; eauto. + + (* return *) + inv STACKS. + exploit add_spill_correct. intros [ls2 [A [B C]]]. + left; econstructor; split. + eapply plus_left. eapply exec_return; eauto. + eauto. traceEq. + econstructor; eauto. + unfold rs1. apply agree_set with ls; auto. + rewrite B. apply AG. apply loc_result_acceptable. +Qed. + +Lemma transf_initial_states: + forall st1, LTLin.initial_state prog st1 -> + exists st2, Linear.initial_state tprog st2 /\ match_states st1 st2. +Proof. + intros. inversion H. + econstructor; split. + econstructor. + change (prog_main tprog) with (prog_main prog). + rewrite symbols_preserved. eauto. + apply function_ptr_translated; eauto. + rewrite sig_preserved. auto. + replace (Genv.init_mem tprog) with (Genv.init_mem prog). + econstructor; eauto. rewrite H2. constructor. + red; intros. auto. + eapply Genv.find_funct_ptr_prop; eauto. + symmetry. unfold tprog, transf_program. apply Genv.init_mem_transf; auto. +Qed. + +Lemma transf_final_states: + forall st1 st2 r, + match_states st1 st2 -> LTLin.final_state st1 r -> Linear.final_state st2 r. +Proof. + intros. inv H0. inv H. inv STACKS. econstructor. + rewrite (agree_loc _ _ (R R3) AG). auto. + simpl. intuition congruence. +Qed. + +Theorem transf_program_correct: + forall (beh: program_behavior), + LTLin.exec_program prog beh -> Linear.exec_program tprog beh. +Proof. + unfold LTLin.exec_program, Linear.exec_program; intros. + eapply simulation_star_preservation; eauto. + eexact transf_initial_states. + eexact transf_final_states. + eexact transf_step_correct. +Qed. + +End PRESERVATION. diff --git a/backend/Reloadtyping.v b/backend/Reloadtyping.v new file mode 100644 index 00000000..155c174d --- /dev/null +++ b/backend/Reloadtyping.v @@ -0,0 +1,309 @@ +(** Proof of type preservation for Reload and of + correctness of computation of stack bounds for Linear. *) + +Require Import Coqlib. +Require Import Maps. +Require Import AST. +Require Import Op. +Require Import Locations. +Require Import LTLin. +Require Import LTLintyping. +Require Import Linear. +Require Import Lineartyping. +Require Import Conventions. +Require Import Parallelmove. +Require Import Reload. +Require Import Reloadproof. + +(** * Typing Linear constructors *) + +(** We show that the Linear constructor functions defined in [Reload] + generate well-typed instruction sequences, + given sufficient typing and well-formedness hypotheses over the locations involved. *) + +Hint Resolve wt_Lgetstack wt_Lsetstack wt_Lopmove + wt_Lop wt_Lload wt_Lstore wt_Lcall wt_Ltailcall wt_Lalloc + wt_Llabel wt_Lgoto wt_Lcond wt_Lreturn: reloadty. + +Remark wt_code_cons: + forall f i c, wt_instr f i -> wt_code f c -> wt_code f (i :: c). +Proof. + intros; red; simpl; intros. elim H1; intro. + subst i; auto. auto. +Qed. + +Hint Resolve wt_code_cons: reloadty. + +Definition loc_valid (f: function) (l: loc) := + match l with R _ => True | S s => slot_valid f s end. + +Lemma loc_acceptable_valid: + forall f l, loc_acceptable l -> loc_valid f l. +Proof. + destruct l; simpl; intro. auto. + destruct s; simpl. omega. tauto. tauto. +Qed. + +Definition loc_writable (l: loc) := + match l with R _ => True | S s => slot_writable s end. + +Lemma loc_acceptable_writable: + forall l, loc_acceptable l -> loc_writable l. +Proof. + destruct l; simpl; intro. auto. + destruct s; simpl; tauto. +Qed. + +Hint Resolve loc_acceptable_valid loc_acceptable_writable: reloadty. + +Definition locs_valid (f: function) (ll: list loc) := + forall l, In l ll -> loc_valid f l. +Definition locs_writable (ll: list loc) := + forall l, In l ll -> loc_writable l. + +Lemma locs_acceptable_valid: + forall f ll, locs_acceptable ll -> locs_valid f ll. +Proof. + unfold locs_acceptable, locs_valid. auto with reloadty. +Qed. + +Lemma locs_acceptable_writable: + forall ll, locs_acceptable ll -> locs_writable ll. +Proof. + unfold locs_acceptable, locs_writable. auto with reloadty. +Qed. + +Hint Resolve locs_acceptable_valid locs_acceptable_writable: reloadty. + +Lemma wt_add_reload: + forall f src dst k, + loc_valid f src -> Loc.type src = mreg_type dst -> + wt_code f k -> wt_code f (add_reload src dst k). +Proof. + intros; unfold add_reload. + destruct src; eauto with reloadty. + destruct (mreg_eq m dst); eauto with reloadty. +Qed. + +Hint Resolve wt_add_reload: reloadty. + +Lemma wt_add_reloads: + forall f srcs dsts k, + locs_valid f srcs -> map Loc.type srcs = map mreg_type dsts -> + wt_code f k -> wt_code f (add_reloads srcs dsts k). +Proof. + induction srcs; destruct dsts; simpl; intros; try congruence. + auto. inv H0. apply wt_add_reload; auto with coqlib reloadty. + apply IHsrcs; auto. red; intros; auto with coqlib. +Qed. + +Hint Resolve wt_add_reloads: reloadty. + +Lemma wt_add_spill: + forall f src dst k, + loc_valid f dst -> loc_writable dst -> Loc.type dst = mreg_type src -> + wt_code f k -> wt_code f (add_spill src dst k). +Proof. + intros; unfold add_spill. + destruct dst; eauto with reloadty. + destruct (mreg_eq src m); eauto with reloadty. +Qed. + +Hint Resolve wt_add_spill: reloadty. + +Lemma wt_add_move: + forall f src dst k, + loc_valid f src -> loc_valid f dst -> loc_writable dst -> + Loc.type dst = Loc.type src -> + wt_code f k -> wt_code f (add_move src dst k). +Proof. + intros. unfold add_move. + destruct (Loc.eq src dst); auto. + destruct src; auto with reloadty. + destruct dst; auto with reloadty. + set (tmp := match slot_type s with + | Tint => IT1 + | Tfloat => FT1 + end). + assert (mreg_type tmp = Loc.type (S s)). + simpl. destruct (slot_type s); reflexivity. + apply wt_add_reload; auto with reloadty. + apply wt_add_spill; auto. congruence. +Qed. + +Hint Resolve wt_add_move: reloadty. + +Lemma wt_add_moves: + forall f b moves, + (forall s d, In (s, d) moves -> + loc_valid f s /\ loc_valid f d /\ loc_writable d /\ Loc.type s = Loc.type d) -> + wt_code f b -> + wt_code f + (List.fold_right (fun p k => add_move (fst p) (snd p) k) b moves). +Proof. + induction moves; simpl; intros. + auto. + destruct a as [s d]. simpl. + destruct (H s d) as [A [B [C D]]]. auto. + auto with reloadty. +Qed. + +Theorem wt_parallel_move: + forall f srcs dsts b, + List.map Loc.type srcs = List.map Loc.type dsts -> + locs_valid f srcs -> locs_valid f dsts -> locs_writable dsts -> + wt_code f b -> wt_code f (parallel_move srcs dsts b). +Proof. + intros. unfold parallel_move. apply wt_add_moves; auto. + intros. + elim (parmove_prop_2 _ _ _ _ H4); intros A B. + split. destruct A as [C|[C|C]]; auto; subst s; exact I. + split. destruct B as [C|[C|C]]; auto; subst d; exact I. + split. destruct B as [C|[C|C]]; auto; subst d; exact I. + eapply parmove_prop_3; eauto. +Qed. +Hint Resolve wt_parallel_move: reloadty. + +Lemma wt_reg_for: + forall l, mreg_type (reg_for l) = Loc.type l. +Proof. + intros. destruct l; simpl. auto. + case (slot_type s); reflexivity. +Qed. +Hint Resolve wt_reg_for: reloadty. + +Lemma wt_regs_for_rec: + forall locs itmps ftmps, + (List.length locs <= List.length itmps)%nat -> + (List.length locs <= List.length ftmps)%nat -> + (forall r, In r itmps -> mreg_type r = Tint) -> + (forall r, In r ftmps -> mreg_type r = Tfloat) -> + List.map mreg_type (regs_for_rec locs itmps ftmps) = List.map Loc.type locs. +Proof. + induction locs; intros. + simpl. auto. + destruct itmps; simpl in H. omegaContradiction. + destruct ftmps; simpl in H0. omegaContradiction. + simpl. apply (f_equal2 (@cons typ)). + destruct a. reflexivity. simpl. case (slot_type s). + apply H1; apply in_eq. apply H2; apply in_eq. + apply IHlocs. omega. omega. + intros; apply H1; apply in_cons; auto. + intros; apply H2; apply in_cons; auto. +Qed. + +Lemma wt_regs_for: + forall locs, + (List.length locs <= 3)%nat -> + List.map mreg_type (regs_for locs) = List.map Loc.type locs. +Proof. + intros. unfold regs_for. apply wt_regs_for_rec. + simpl. auto. simpl. auto. + simpl; intros; intuition; subst r; reflexivity. + simpl; intros; intuition; subst r; reflexivity. +Qed. +Hint Resolve wt_regs_for: reloadty. + +Hint Resolve length_op_args length_addr_args length_cond_args: reloadty. + +Hint Extern 4 (_ = _) => congruence : reloadty. + +Lemma wt_transf_instr: + forall f instr k, + LTLintyping.wt_instr (LTLin.fn_sig f) instr -> + wt_code (transf_function f) k -> + wt_code (transf_function f) (transf_instr f instr k). +Proof. + Opaque reg_for regs_for. + intros. inv H; simpl; auto with reloadty. + caseEq (is_move_operation op args); intros. + destruct (is_move_operation_correct _ _ H). congruence. + assert (map mreg_type (regs_for args) = map Loc.type args). + eauto with reloadty. + assert (mreg_type (reg_for res) = Loc.type res). eauto with reloadty. + auto with reloadty. + + assert (map mreg_type (regs_for args) = map Loc.type args). + eauto with reloadty. + assert (mreg_type (reg_for dst) = Loc.type dst). eauto with reloadty. + auto with reloadty. + + caseEq (regs_for (src :: args)); intros. + red; simpl; tauto. + assert (map mreg_type (regs_for (src :: args)) = map Loc.type (src :: args)). + apply wt_regs_for. simpl. apply le_n_S. eauto with reloadty. + rewrite H in H5. injection H5; intros. + auto with reloadty. + + assert (locs_valid (transf_function f) (loc_arguments sig)). + red; intros. generalize (loc_arguments_acceptable sig l H). + destruct l; simpl; auto. destruct s; simpl; intuition. + assert (locs_writable (loc_arguments sig)). + red; intros. generalize (loc_arguments_acceptable sig l H7). + destruct l; simpl; auto. destruct s; simpl; intuition. + assert (map Loc.type args = map Loc.type (loc_arguments sig)). + rewrite loc_arguments_type; auto. + assert (Loc.type res = mreg_type (loc_result sig)). + rewrite H3. unfold loc_result. + destruct (sig_res sig); auto. destruct t; auto. + destruct ros; auto 10 with reloadty. + + assert (locs_valid (transf_function f) (loc_arguments sig)). + red; intros. generalize (loc_arguments_acceptable sig l H). + destruct l; simpl; auto. destruct s; simpl; intuition. + assert (locs_writable (loc_arguments sig)). + red; intros. generalize (loc_arguments_acceptable sig l H7). + destruct l; simpl; auto. destruct s; simpl; intuition. + assert (map Loc.type args = map Loc.type (loc_arguments sig)). + rewrite loc_arguments_type; auto. + destruct ros; auto 10 with reloadty. + + assert (map mreg_type (regs_for args) = map Loc.type args). + eauto with reloadty. + auto with reloadty. + + destruct optres; simpl in *; auto with reloadty. + apply wt_add_reload; auto with reloadty. + unfold loc_result. rewrite <- H1. + destruct (Loc.type l); reflexivity. +Qed. + +Lemma wt_transf_code: + forall f c, + LTLintyping.wt_code (LTLin.fn_sig f) c -> + Lineartyping.wt_code (transf_function f) (transf_code f c). +Proof. + induction c; simpl; intros. + red; simpl; tauto. + apply wt_transf_instr; auto with coqlib. + apply IHc. red; auto with coqlib. +Qed. + +Lemma wt_transf_fundef: + forall fd, + LTLintyping.wt_fundef fd -> + Lineartyping.wt_fundef (transf_fundef fd). +Proof. + intros. destruct fd; simpl. + inv H. inv H1. constructor. unfold wt_function. simpl. + apply wt_parallel_move; auto with reloadty. + rewrite loc_parameters_type. auto. + unfold loc_parameters; red; intros. + destruct (list_in_map_inv _ _ _ H) as [r [A B]]. rewrite A. + generalize (loc_arguments_acceptable _ _ B). + destruct r; simpl; auto. destruct s; try tauto. + intros; simpl. split. omega. + apply loc_arguments_bounded; auto. + apply wt_transf_code; auto. + constructor. +Qed. + +Lemma program_typing_preserved: + forall p, + LTLintyping.wt_program p -> + Lineartyping.wt_program (transf_program p). +Proof. + intros; red; intros. + destruct (transform_program_function _ _ _ _ H0) as [f0 [A B]]. + subst f; apply wt_transf_fundef. eauto. +Qed. diff --git a/backend/Selection.v b/backend/Selection.v new file mode 100644 index 00000000..c98e55e4 --- /dev/null +++ b/backend/Selection.v @@ -0,0 +1,1103 @@ +(** Instruction selection *) + +(** The instruction selection pass recognizes opportunities for using + combined arithmetic and logical operations and addressing modes + offered by the target processor. For instance, the expression [x + 1] + can take advantage of the "immediate add" instruction of the processor, + and on the PowerPC, the expression [(x >> 6) & 0xFF] can be turned + into a "rotate and mask" instruction. + + Instruction selection proceeds by bottom-up rewriting over expressions. + The source language is Cminor and the target language is CminorSel. *) + +Require Import Coqlib. +Require Import Maps. +Require Import AST. +Require Import Integers. +Require Import Floats. +Require Import Values. +Require Import Mem. +Require Import Globalenvs. +Require Cminor. +Require Import Op. +Require Import CminorSel. + +Infix ":::" := Econs (at level 60, right associativity) : selection_scope. + +Open Local Scope selection_scope. + +(** * Lifting of let-bound variables *) + +(** Some of the instruction functions generate [Elet] constructs to + share the evaluation of a subexpression. Owing to the use of de + Bruijn indices for let-bound variables, we need to shift de Bruijn + indices when an expression [b] is put in a [Elet a b] context. *) + +Fixpoint lift_expr (p: nat) (a: expr) {struct a}: expr := + match a with + | Evar id => Evar id + | Eop op bl => Eop op (lift_exprlist p bl) + | Eload chunk addr bl => Eload chunk addr (lift_exprlist p bl) + | Estore chunk addr bl c => + Estore chunk addr (lift_exprlist p bl) (lift_expr p c) + | Ecall sig b cl => Ecall sig (lift_expr p b) (lift_exprlist p cl) + | Econdition b c d => + Econdition (lift_condexpr p b) (lift_expr p c) (lift_expr p d) + | Elet b c => Elet (lift_expr p b) (lift_expr (S p) c) + | Eletvar n => + if le_gt_dec p n then Eletvar (S n) else Eletvar n + | Ealloc b => + Ealloc (lift_expr p b) + end + +with lift_condexpr (p: nat) (a: condexpr) {struct a}: condexpr := + match a with + | CEtrue => CEtrue + | CEfalse => CEfalse + | CEcond cond bl => CEcond cond (lift_exprlist p bl) + | CEcondition b c d => + CEcondition (lift_condexpr p b) (lift_condexpr p c) (lift_condexpr p d) + end + +with lift_exprlist (p: nat) (a: exprlist) {struct a}: exprlist := + match a with + | Enil => Enil + | Econs b cl => Econs (lift_expr p b) (lift_exprlist p cl) + end. + +Definition lift (a: expr): expr := lift_expr O a. + +(** * Smart constructors for operators *) + +(** This section defines functions for building CminorSel expressions + and statements, especially expressions consisting of operator + applications. These functions examine their arguments to choose + cheaper forms of operators whenever possible. + + For instance, [add e1 e2] will return a CminorSel expression semantically + equivalent to [Eop Oadd (e1 ::: e2 ::: Enil)], but will use a + [Oaddimm] operator if one of the arguments is an integer constant, + or suppress the addition altogether if one of the arguments is the + null integer. In passing, we perform operator reassociation + ([(e + c1) * c2] becomes [(e * c2) + (c1 * c2)]) and a small amount + of constant propagation. +*) + +(** ** Integer logical negation *) + +(** The natural way to write smart constructors is by pattern-matching + on their arguments, recognizing cases where cheaper operators + or combined operators are applicable. For instance, integer logical + negation has three special cases (not-and, not-or and not-xor), + along with a default case that uses not-or over its arguments and itself. + This is written naively as follows: +<< +Definition notint (e: expr) := + match e with + | Eop Oand (t1:::t2:::Enil) => Eop Onand (t1:::t2:::Enil) + | Eop Oor (t1:::t2:::Enil) => Eop Onor (t1:::t2:::Enil) + | Eop Oxor (t1:::t2:::Enil) => Eop Onxor (t1:::t2:::Enil) + | _ => Elet(e, Eop Onor (Eletvar O ::: Eletvar O ::: Enil) + end. +>> + However, Coq expands complex pattern-matchings like the above into + elementary matchings over all constructors of an inductive type, + resulting in much duplication of the final catch-all case. + Such duplications generate huge executable code and duplicate + cases in the correctness proofs. + + To limit this duplication, we use the following trick due to + Yves Bertot. We first define a dependent inductive type that + characterizes the expressions that match each of the 4 cases of interest. +*) + +Inductive notint_cases: forall (e: expr), Set := + | notint_case1: + forall (t1: expr) (t2: expr), + notint_cases (Eop Oand (t1:::t2:::Enil)) + | notint_case2: + forall (t1: expr) (t2: expr), + notint_cases (Eop Oor (t1:::t2:::Enil)) + | notint_case3: + forall (t1: expr) (t2: expr), + notint_cases (Eop Oxor (t1:::t2:::Enil)) + | notint_default: + forall (e: expr), + notint_cases e. + +(** We then define a classification function that takes an expression + and return the case in which it falls. Note that the catch-all case + [notint_default] does not state that it is mutually exclusive with + the first three, more specific cases. The classification function + nonetheless chooses the specific cases in preference to the catch-all + case. *) + +Definition notint_match (e: expr) := + match e as z1 return notint_cases z1 with + | Eop Oand (t1:::t2:::Enil) => + notint_case1 t1 t2 + | Eop Oor (t1:::t2:::Enil) => + notint_case2 t1 t2 + | Eop Oxor (t1:::t2:::Enil) => + notint_case3 t1 t2 + | e => + notint_default e + end. + +(** Finally, the [notint] function we need is defined by a 4-case match + over the result of the classification function. Thus, no duplication + of the right-hand sides of this match occur, and the proof has only + 4 cases to consider (it proceeds by case over [notint_match e]). + Since the default case is not obviously exclusive with the three + specific cases, it is important that its right-hand side is + semantically correct for all possible values of [e], which is the + case here and for all other smart constructors. *) + +Definition notint (e: expr) := + match notint_match e with + | notint_case1 t1 t2 => + Eop Onand (t1:::t2:::Enil) + | notint_case2 t1 t2 => + Eop Onor (t1:::t2:::Enil) + | notint_case3 t1 t2 => + Eop Onxor (t1:::t2:::Enil) + | notint_default e => + Elet e (Eop Onor (Eletvar O ::: Eletvar O ::: Enil)) + end. + +(** This programming pattern will be applied systematically for the + other smart constructors in this file. *) + +(** ** Boolean negation *) + +Definition notbool_base (e: expr) := + Eop (Ocmp (Ccompimm Ceq Int.zero)) (e ::: Enil). + +Fixpoint notbool (e: expr) {struct e} : expr := + match e with + | Eop (Ointconst n) Enil => + Eop (Ointconst (if Int.eq n Int.zero then Int.one else Int.zero)) Enil + | Eop (Ocmp cond) args => + Eop (Ocmp (negate_condition cond)) args + | Econdition e1 e2 e3 => + Econdition e1 (notbool e2) (notbool e3) + | _ => + notbool_base e + end. + +(** ** Integer addition and pointer addition *) + +(* +Definition addimm (n: int) (e: expr) := + if Int.eq n Int.zero then e else + match e with + | Eop (Ointconst m) Enil => Eop (Ointconst(Int.add n m)) Enil + | Eop (Oaddrsymbol s m) Enil => Eop (Oaddrsymbol s (Int.add n m)) Enil + | Eop (Oaddrstack m) Enil => Eop (Oaddrstack (Int.add n m)) Enil + | Eop (Oaddimm m) (t ::: Enil) => Eop (Oaddimm(Int.add n m)) (t ::: Enil) + | _ => Eop (Oaddimm n) (e ::: Enil) + end. +*) + +(** Addition of an integer constant. *) + +Inductive addimm_cases: forall (e: expr), Set := + | addimm_case1: + forall (m: int), + addimm_cases (Eop (Ointconst m) Enil) + | addimm_case2: + forall (s: ident) (m: int), + addimm_cases (Eop (Oaddrsymbol s m) Enil) + | addimm_case3: + forall (m: int), + addimm_cases (Eop (Oaddrstack m) Enil) + | addimm_case4: + forall (m: int) (t: expr), + addimm_cases (Eop (Oaddimm m) (t ::: Enil)) + | addimm_default: + forall (e: expr), + addimm_cases e. + +Definition addimm_match (e: expr) := + match e as z1 return addimm_cases z1 with + | Eop (Ointconst m) Enil => + addimm_case1 m + | Eop (Oaddrsymbol s m) Enil => + addimm_case2 s m + | Eop (Oaddrstack m) Enil => + addimm_case3 m + | Eop (Oaddimm m) (t ::: Enil) => + addimm_case4 m t + | e => + addimm_default e + end. + +Definition addimm (n: int) (e: expr) := + if Int.eq n Int.zero then e else + match addimm_match e with + | addimm_case1 m => + Eop (Ointconst(Int.add n m)) Enil + | addimm_case2 s m => + Eop (Oaddrsymbol s (Int.add n m)) Enil + | addimm_case3 m => + Eop (Oaddrstack (Int.add n m)) Enil + | addimm_case4 m t => + Eop (Oaddimm(Int.add n m)) (t ::: Enil) + | addimm_default e => + Eop (Oaddimm n) (e ::: Enil) + end. + +(** Addition of two integer or pointer expressions. *) + +(* +Definition add (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => addimm n1 t2 + | Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddimm n2) (t2:::Enil) => addimm (Int.add n1 n2) (Eop Oadd (t1:::t2:::Enil)) + | Eop(Oaddimm n1) (t1:::Enil)), t2 => addimm n1 (Eop Oadd (t1:::t2:::Enil)) + | t1, Eop (Ointconst n2) Enil => addimm n2 t1 + | t1, Eop (Oaddimm n2) (t2:::Enil) => addimm n2 (Eop Oadd (t1:::t2:::Enil)) + | _, _ => Eop Oadd (e1:::e2:::Enil) + end. +*) + +Inductive add_cases: forall (e1: expr) (e2: expr), Set := + | add_case1: + forall (n1: int) (t2: expr), + add_cases (Eop (Ointconst n1) Enil) (t2) + | add_case2: + forall (n1: int) (t1: expr) (n2: int) (t2: expr), + add_cases (Eop (Oaddimm n1) (t1:::Enil)) (Eop (Oaddimm n2) (t2:::Enil)) + | add_case3: + forall (n1: int) (t1: expr) (t2: expr), + add_cases (Eop(Oaddimm n1) (t1:::Enil)) (t2) + | add_case4: + forall (t1: expr) (n2: int), + add_cases (t1) (Eop (Ointconst n2) Enil) + | add_case5: + forall (t1: expr) (n2: int) (t2: expr), + add_cases (t1) (Eop (Oaddimm n2) (t2:::Enil)) + | add_default: + forall (e1: expr) (e2: expr), + add_cases e1 e2. + +Definition add_match_aux (e1: expr) (e2: expr) := + match e2 as z2 return add_cases e1 z2 with + | Eop (Ointconst n2) Enil => + add_case4 e1 n2 + | Eop (Oaddimm n2) (t2:::Enil) => + add_case5 e1 n2 t2 + | e2 => + add_default e1 e2 + end. + +Definition add_match (e1: expr) (e2: expr) := + match e1 as z1, e2 as z2 return add_cases z1 z2 with + | Eop (Ointconst n1) Enil, t2 => + add_case1 n1 t2 + | Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddimm n2) (t2:::Enil) => + add_case2 n1 t1 n2 t2 + | Eop(Oaddimm n1) (t1:::Enil), t2 => + add_case3 n1 t1 t2 + | e1, e2 => + add_match_aux e1 e2 + end. + +Definition add (e1: expr) (e2: expr) := + match add_match e1 e2 with + | add_case1 n1 t2 => + addimm n1 t2 + | add_case2 n1 t1 n2 t2 => + addimm (Int.add n1 n2) (Eop Oadd (t1:::t2:::Enil)) + | add_case3 n1 t1 t2 => + addimm n1 (Eop Oadd (t1:::t2:::Enil)) + | add_case4 t1 n2 => + addimm n2 t1 + | add_case5 t1 n2 t2 => + addimm n2 (Eop Oadd (t1:::t2:::Enil)) + | add_default e1 e2 => + Eop Oadd (e1:::e2:::Enil) + end. + +(** ** Integer and pointer subtraction *) + +(* +Definition sub (e1: expr) (e2: expr) := + match e1, e2 with + | t1, Eop (Ointconst n2) Enil => addimm (Int.neg n2) t1 + | Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddimm n2) (t2:::Enil) => addimm +(intsub n1 n2) (Eop Osub (t1:::t2:::Enil)) + | Eop (Oaddimm n1) (t1:::Enil), t2 => addimm n1 (Eop Osub (t1:::t2:::Rni +l)) + | t1, Eop (Oaddimm n2) (t2:::Enil) => addimm (Int.neg n2) (Eop Osub (t1::: +:t2:::Enil)) + | _, _ => Eop Osub (e1:::e2:::Enil) + end. +*) + +Inductive sub_cases: forall (e1: expr) (e2: expr), Set := + | sub_case1: + forall (t1: expr) (n2: int), + sub_cases (t1) (Eop (Ointconst n2) Enil) + | sub_case2: + forall (n1: int) (t1: expr) (n2: int) (t2: expr), + sub_cases (Eop (Oaddimm n1) (t1:::Enil)) (Eop (Oaddimm n2) (t2:::Enil)) + | sub_case3: + forall (n1: int) (t1: expr) (t2: expr), + sub_cases (Eop (Oaddimm n1) (t1:::Enil)) (t2) + | sub_case4: + forall (t1: expr) (n2: int) (t2: expr), + sub_cases (t1) (Eop (Oaddimm n2) (t2:::Enil)) + | sub_default: + forall (e1: expr) (e2: expr), + sub_cases e1 e2. + +Definition sub_match_aux (e1: expr) (e2: expr) := + match e1 as z1 return sub_cases z1 e2 with + | Eop (Oaddimm n1) (t1:::Enil) => + sub_case3 n1 t1 e2 + | e1 => + sub_default e1 e2 + end. + +Definition sub_match (e1: expr) (e2: expr) := + match e2 as z2, e1 as z1 return sub_cases z1 z2 with + | Eop (Ointconst n2) Enil, t1 => + sub_case1 t1 n2 + | Eop (Oaddimm n2) (t2:::Enil), Eop (Oaddimm n1) (t1:::Enil) => + sub_case2 n1 t1 n2 t2 + | Eop (Oaddimm n2) (t2:::Enil), t1 => + sub_case4 t1 n2 t2 + | e2, e1 => + sub_match_aux e1 e2 + end. + +Definition sub (e1: expr) (e2: expr) := + match sub_match e1 e2 with + | sub_case1 t1 n2 => + addimm (Int.neg n2) t1 + | sub_case2 n1 t1 n2 t2 => + addimm (Int.sub n1 n2) (Eop Osub (t1:::t2:::Enil)) + | sub_case3 n1 t1 t2 => + addimm n1 (Eop Osub (t1:::t2:::Enil)) + | sub_case4 t1 n2 t2 => + addimm (Int.neg n2) (Eop Osub (t1:::t2:::Enil)) + | sub_default e1 e2 => + Eop Osub (e1:::e2:::Enil) + end. + +(** ** Rotates and immediate shifts *) + +(* +Definition rolm (e1: expr) := + match e1 with + | Eop (Ointconst n1) Enil => + Eop (Ointconst(Int.and (Int.rol n1 amount2) mask2)) Enil + | Eop (Orolm amount1 mask1) (t1:::Enil) => + let amount := Int.and (Int.add amount1 amount2) Ox1Fl in + let mask := Int.and (Int.rol mask1 amount2) mask2 in + if Int.is_rlw_mask mask + then Eop (Orolm amount mask) (t1:::Enil) + else Eop (Orolm amount2 mask2) (e1:::Enil) + | _ => Eop (Orolm amount2 mask2) (e1:::Enil) + end +*) + +Inductive rolm_cases: forall (e1: expr), Set := + | rolm_case1: + forall (n1: int), + rolm_cases (Eop (Ointconst n1) Enil) + | rolm_case2: + forall (amount1: int) (mask1: int) (t1: expr), + rolm_cases (Eop (Orolm amount1 mask1) (t1:::Enil)) + | rolm_default: + forall (e1: expr), + rolm_cases e1. + +Definition rolm_match (e1: expr) := + match e1 as z1 return rolm_cases z1 with + | Eop (Ointconst n1) Enil => + rolm_case1 n1 + | Eop (Orolm amount1 mask1) (t1:::Enil) => + rolm_case2 amount1 mask1 t1 + | e1 => + rolm_default e1 + end. + +Definition rolm (e1: expr) (amount2 mask2: int) := + match rolm_match e1 with + | rolm_case1 n1 => + Eop (Ointconst(Int.and (Int.rol n1 amount2) mask2)) Enil + | rolm_case2 amount1 mask1 t1 => + let amount := Int.and (Int.add amount1 amount2) (Int.repr 31) in + let mask := Int.and (Int.rol mask1 amount2) mask2 in + if Int.is_rlw_mask mask + then Eop (Orolm amount mask) (t1:::Enil) + else Eop (Orolm amount2 mask2) (e1:::Enil) + | rolm_default e1 => + Eop (Orolm amount2 mask2) (e1:::Enil) + end. + +Definition shlimm (e1: expr) (n2: int) := + if Int.eq n2 Int.zero then + e1 + else if Int.ltu n2 (Int.repr 32) then + rolm e1 n2 (Int.shl Int.mone n2) + else + Eop Oshl (e1:::Eop (Ointconst n2) Enil:::Enil). + +Definition shruimm (e1: expr) (n2: int) := + if Int.eq n2 Int.zero then + e1 + else if Int.ltu n2 (Int.repr 32) then + rolm e1 (Int.sub (Int.repr 32) n2) (Int.shru Int.mone n2) + else + Eop Oshru (e1:::Eop (Ointconst n2) Enil:::Enil). + +(** ** Integer multiply *) + +Definition mulimm_base (n1: int) (e2: expr) := + match Int.one_bits n1 with + | i :: nil => + shlimm e2 i + | i :: j :: nil => + Elet e2 + (Eop Oadd (shlimm (Eletvar 0) i ::: + shlimm (Eletvar 0) j ::: Enil)) + | _ => + Eop (Omulimm n1) (e2:::Enil) + end. + +(* +Definition mulimm (n1: int) (e2: expr) := + if Int.eq n1 Int.zero then + Elet e2 (Eop (Ointconst Int.zero) Enil) + else if Int.eq n1 Int.one then + e2 + else match e2 with + | Eop (Ointconst n2) Enil => Eop (Ointconst(intmul n1 n2)) Enil + | Eop (Oaddimm n2) (t2:::Enil) => addimm (intmul n1 n2) (mulimm_base n1 t2) + | _ => mulimm_base n1 e2 + end. +*) + +Inductive mulimm_cases: forall (e2: expr), Set := + | mulimm_case1: + forall (n2: int), + mulimm_cases (Eop (Ointconst n2) Enil) + | mulimm_case2: + forall (n2: int) (t2: expr), + mulimm_cases (Eop (Oaddimm n2) (t2:::Enil)) + | mulimm_default: + forall (e2: expr), + mulimm_cases e2. + +Definition mulimm_match (e2: expr) := + match e2 as z1 return mulimm_cases z1 with + | Eop (Ointconst n2) Enil => + mulimm_case1 n2 + | Eop (Oaddimm n2) (t2:::Enil) => + mulimm_case2 n2 t2 + | e2 => + mulimm_default e2 + end. + +Definition mulimm (n1: int) (e2: expr) := + if Int.eq n1 Int.zero then + Elet e2 (Eop (Ointconst Int.zero) Enil) + else if Int.eq n1 Int.one then + e2 + else match mulimm_match e2 with + | mulimm_case1 n2 => + Eop (Ointconst(Int.mul n1 n2)) Enil + | mulimm_case2 n2 t2 => + addimm (Int.mul n1 n2) (mulimm_base n1 t2) + | mulimm_default e2 => + mulimm_base n1 e2 + end. + +(* +Definition mul (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => mulimm n1 t2 + | t1, Eop (Ointconst n2) Enil => mulimm n2 t1 + | _, _ => Eop Omul (e1:::e2:::Enil) + end. +*) + +Inductive mul_cases: forall (e1: expr) (e2: expr), Set := + | mul_case1: + forall (n1: int) (t2: expr), + mul_cases (Eop (Ointconst n1) Enil) (t2) + | mul_case2: + forall (t1: expr) (n2: int), + mul_cases (t1) (Eop (Ointconst n2) Enil) + | mul_default: + forall (e1: expr) (e2: expr), + mul_cases e1 e2. + +Definition mul_match_aux (e1: expr) (e2: expr) := + match e2 as z2 return mul_cases e1 z2 with + | Eop (Ointconst n2) Enil => + mul_case2 e1 n2 + | e2 => + mul_default e1 e2 + end. + +Definition mul_match (e1: expr) (e2: expr) := + match e1 as z1 return mul_cases z1 e2 with + | Eop (Ointconst n1) Enil => + mul_case1 n1 e2 + | e1 => + mul_match_aux e1 e2 + end. + +Definition mul (e1: expr) (e2: expr) := + match mul_match e1 e2 with + | mul_case1 n1 t2 => + mulimm n1 t2 + | mul_case2 t1 n2 => + mulimm n2 t1 + | mul_default e1 e2 => + Eop Omul (e1:::e2:::Enil) + end. + +(** ** Integer division and modulus *) + +Definition divs (e1: expr) (e2: expr) := Eop Odiv (e1:::e2:::Enil). + +Definition mod_aux (divop: operation) (e1 e2: expr) := + Elet e1 + (Elet (lift e2) + (Eop Osub (Eletvar 1 ::: + Eop Omul (Eop divop (Eletvar 1 ::: Eletvar 0 ::: Enil) ::: + Eletvar 0 ::: + Enil) ::: + Enil))). + +Definition mods := mod_aux Odiv. + +Inductive divu_cases: forall (e2: expr), Set := + | divu_case1: + forall (n2: int), + divu_cases (Eop (Ointconst n2) Enil) + | divu_default: + forall (e2: expr), + divu_cases e2. + +Definition divu_match (e2: expr) := + match e2 as z1 return divu_cases z1 with + | Eop (Ointconst n2) Enil => + divu_case1 n2 + | e2 => + divu_default e2 + end. + +Definition divu (e1: expr) (e2: expr) := + match divu_match e2 with + | divu_case1 n2 => + match Int.is_power2 n2 with + | Some l2 => shruimm e1 l2 + | None => Eop Odivu (e1:::e2:::Enil) + end + | divu_default e2 => + Eop Odivu (e1:::e2:::Enil) + end. + +Definition modu (e1: expr) (e2: expr) := + match divu_match e2 with + | divu_case1 n2 => + match Int.is_power2 n2 with + | Some l2 => rolm e1 Int.zero (Int.sub n2 Int.one) + | None => mod_aux Odivu e1 e2 + end + | divu_default e2 => + mod_aux Odivu e1 e2 + end. + +(** ** Bitwise and, or, xor *) + +Definition andimm (n1: int) (e2: expr) := + if Int.is_rlw_mask n1 + then rolm e2 Int.zero n1 + else Eop (Oandimm n1) (e2:::Enil). + +Definition and (e1: expr) (e2: expr) := + match mul_match e1 e2 with + | mul_case1 n1 t2 => + andimm n1 t2 + | mul_case2 t1 n2 => + andimm n2 t1 + | mul_default e1 e2 => + Eop Oand (e1:::e2:::Enil) + end. + +Definition same_expr_pure (e1 e2: expr) := + match e1, e2 with + | Evar v1, Evar v2 => if ident_eq v1 v2 then true else false + | _, _ => false + end. + +Inductive or_cases: forall (e1: expr) (e2: expr), Set := + | or_case1: + forall (amount1: int) (mask1: int) (t1: expr) + (amount2: int) (mask2: int) (t2: expr), + or_cases (Eop (Orolm amount1 mask1) (t1:::Enil)) + (Eop (Orolm amount2 mask2) (t2:::Enil)) + | or_default: + forall (e1: expr) (e2: expr), + or_cases e1 e2. + +Definition or_match (e1: expr) (e2: expr) := + match e1 as z1, e2 as z2 return or_cases z1 z2 with + | Eop (Orolm amount1 mask1) (t1:::Enil), + Eop (Orolm amount2 mask2) (t2:::Enil) => + or_case1 amount1 mask1 t1 amount2 mask2 t2 + | e1, e2 => + or_default e1 e2 + end. + +Definition or (e1: expr) (e2: expr) := + match or_match e1 e2 with + | or_case1 amount1 mask1 t1 amount2 mask2 t2 => + if Int.eq amount1 amount2 + && Int.is_rlw_mask (Int.or mask1 mask2) + && same_expr_pure t1 t2 + then Eop (Orolm amount1 (Int.or mask1 mask2)) (t1:::Enil) + else Eop Oor (e1:::e2:::Enil) + | or_default e1 e2 => + Eop Oor (e1:::e2:::Enil) + end. + +(** ** General shifts *) + +Inductive shift_cases: forall (e1: expr), Set := + | shift_case1: + forall (n2: int), + shift_cases (Eop (Ointconst n2) Enil) + | shift_default: + forall (e1: expr), + shift_cases e1. + +Definition shift_match (e1: expr) := + match e1 as z1 return shift_cases z1 with + | Eop (Ointconst n2) Enil => + shift_case1 n2 + | e1 => + shift_default e1 + end. + +Definition shl (e1: expr) (e2: expr) := + match shift_match e2 with + | shift_case1 n2 => + shlimm e1 n2 + | shift_default e2 => + Eop Oshl (e1:::e2:::Enil) + end. + +Definition shru (e1: expr) (e2: expr) := + match shift_match e2 with + | shift_case1 n2 => + shruimm e1 n2 + | shift_default e2 => + Eop Oshru (e1:::e2:::Enil) + end. + +(** ** Floating-point arithmetic *) + +(* +Definition addf (e1: expr) (e2: expr) := + match e1, e2 with + | Eop Omulf (t1:::t2:::Enil), t3 => Eop Omuladdf (t1:::t2:::t3:::Enil) + | t1, Eop Omulf (t2:::t3:::Enil) => Elet t1 (Eop Omuladdf (t2:::t3:::Rvar 0:::Enil)) + | _, _ => Eop Oaddf (e1:::e2:::Enil) + end. +*) + +Inductive addf_cases: forall (e1: expr) (e2: expr), Set := + | addf_case1: + forall (t1: expr) (t2: expr) (t3: expr), + addf_cases (Eop Omulf (t1:::t2:::Enil)) (t3) + | addf_case2: + forall (t1: expr) (t2: expr) (t3: expr), + addf_cases (t1) (Eop Omulf (t2:::t3:::Enil)) + | addf_default: + forall (e1: expr) (e2: expr), + addf_cases e1 e2. + +Definition addf_match_aux (e1: expr) (e2: expr) := + match e2 as z2 return addf_cases e1 z2 with + | Eop Omulf (t2:::t3:::Enil) => + addf_case2 e1 t2 t3 + | e2 => + addf_default e1 e2 + end. + +Definition addf_match (e1: expr) (e2: expr) := + match e1 as z1 return addf_cases z1 e2 with + | Eop Omulf (t1:::t2:::Enil) => + addf_case1 t1 t2 e2 + | e1 => + addf_match_aux e1 e2 + end. + +Definition addf (e1: expr) (e2: expr) := + match addf_match e1 e2 with + | addf_case1 t1 t2 t3 => + Eop Omuladdf (t1:::t2:::t3:::Enil) + | addf_case2 t1 t2 t3 => + Elet t1 (Eop Omuladdf (lift t2:::lift t3:::Eletvar 0:::Enil)) + | addf_default e1 e2 => + Eop Oaddf (e1:::e2:::Enil) + end. + +(* +Definition subf (e1: expr) (e2: expr) := + match e1, e2 with + | Eop Omulfloat (t1:::t2:::Enil), t3 => Eop Omulsubf (t1:::t2:::t3:::Enil) + | _, _ => Eop Osubf (e1:::e2:::Enil) + end. +*) + +Inductive subf_cases: forall (e1: expr) (e2: expr), Set := + | subf_case1: + forall (t1: expr) (t2: expr) (t3: expr), + subf_cases (Eop Omulf (t1:::t2:::Enil)) (t3) + | subf_default: + forall (e1: expr) (e2: expr), + subf_cases e1 e2. + +Definition subf_match (e1: expr) (e2: expr) := + match e1 as z1 return subf_cases z1 e2 with + | Eop Omulf (t1:::t2:::Enil) => + subf_case1 t1 t2 e2 + | e1 => + subf_default e1 e2 + end. + +Definition subf (e1: expr) (e2: expr) := + match subf_match e1 e2 with + | subf_case1 t1 t2 t3 => + Eop Omulsubf (t1:::t2:::t3:::Enil) + | subf_default e1 e2 => + Eop Osubf (e1:::e2:::Enil) + end. + +(** ** Truncations and sign extensions *) + +Inductive cast8signed_cases: forall (e1: expr), Set := + | cast8signed_case1: + forall (e2: expr), + cast8signed_cases (Eop Ocast8signed (e2 ::: Enil)) + | cast8signed_default: + forall (e1: expr), + cast8signed_cases e1. + +Definition cast8signed_match (e1: expr) := + match e1 as z1 return cast8signed_cases z1 with + | Eop Ocast8signed (e2 ::: Enil) => + cast8signed_case1 e2 + | e1 => + cast8signed_default e1 + end. + +Definition cast8signed (e: expr) := + match cast8signed_match e with + | cast8signed_case1 e1 => e + | cast8signed_default e1 => Eop Ocast8signed (e1 ::: Enil) + end. + +Inductive cast8unsigned_cases: forall (e1: expr), Set := + | cast8unsigned_case1: + forall (e2: expr), + cast8unsigned_cases (Eop Ocast8unsigned (e2 ::: Enil)) + | cast8unsigned_default: + forall (e1: expr), + cast8unsigned_cases e1. + +Definition cast8unsigned_match (e1: expr) := + match e1 as z1 return cast8unsigned_cases z1 with + | Eop Ocast8unsigned (e2 ::: Enil) => + cast8unsigned_case1 e2 + | e1 => + cast8unsigned_default e1 + end. + +Definition cast8unsigned (e: expr) := + match cast8unsigned_match e with + | cast8unsigned_case1 e1 => e + | cast8unsigned_default e1 => Eop Ocast8unsigned (e1 ::: Enil) + end. + +Inductive cast16signed_cases: forall (e1: expr), Set := + | cast16signed_case1: + forall (e2: expr), + cast16signed_cases (Eop Ocast16signed (e2 ::: Enil)) + | cast16signed_default: + forall (e1: expr), + cast16signed_cases e1. + +Definition cast16signed_match (e1: expr) := + match e1 as z1 return cast16signed_cases z1 with + | Eop Ocast16signed (e2 ::: Enil) => + cast16signed_case1 e2 + | e1 => + cast16signed_default e1 + end. + +Definition cast16signed (e: expr) := + match cast16signed_match e with + | cast16signed_case1 e1 => e + | cast16signed_default e1 => Eop Ocast16signed (e1 ::: Enil) + end. + +Inductive cast16unsigned_cases: forall (e1: expr), Set := + | cast16unsigned_case1: + forall (e2: expr), + cast16unsigned_cases (Eop Ocast16unsigned (e2 ::: Enil)) + | cast16unsigned_default: + forall (e1: expr), + cast16unsigned_cases e1. + +Definition cast16unsigned_match (e1: expr) := + match e1 as z1 return cast16unsigned_cases z1 with + | Eop Ocast16unsigned (e2 ::: Enil) => + cast16unsigned_case1 e2 + | e1 => + cast16unsigned_default e1 + end. + +Definition cast16unsigned (e: expr) := + match cast16unsigned_match e with + | cast16unsigned_case1 e1 => e + | cast16unsigned_default e1 => Eop Ocast16unsigned (e1 ::: Enil) + end. + +Inductive singleoffloat_cases: forall (e1: expr), Set := + | singleoffloat_case1: + forall (e2: expr), + singleoffloat_cases (Eop Osingleoffloat (e2 ::: Enil)) + | singleoffloat_default: + forall (e1: expr), + singleoffloat_cases e1. + +Definition singleoffloat_match (e1: expr) := + match e1 as z1 return singleoffloat_cases z1 with + | Eop Osingleoffloat (e2 ::: Enil) => + singleoffloat_case1 e2 + | e1 => + singleoffloat_default e1 + end. + +Definition singleoffloat (e: expr) := + match singleoffloat_match e with + | singleoffloat_case1 e1 => e + | singleoffloat_default e1 => Eop Osingleoffloat (e1 ::: Enil) + end. + +(** ** Conditional expressions *) + +Fixpoint condexpr_of_expr (e: expr) : condexpr := + match e with + | Eop (Ointconst n) Enil => + if Int.eq n Int.zero then CEfalse else CEtrue + | Eop (Ocmp c) el => CEcond c el + | Econdition e1 e2 e3 => + CEcondition e1 (condexpr_of_expr e2) (condexpr_of_expr e3) + | e => CEcond (Ccompimm Cne Int.zero) (e:::Enil) + end. + +(** ** Recognition of addressing modes for load and store operations *) + +(* +Definition addressing (e: expr) := + match e with + | Eop (Oaddrsymbol s n) Enil => (Aglobal s n, Enil) + | Eop (Oaddrstack n) Enil => (Ainstack n, Enil) + | Eop Oadd (Eop (Oaddrsymbol s n) Enil) e2 => (Abased(s, n), e2:::Enil) + | Eop (Oaddimm n) (e1:::Enil) => (Aindexed n, e1:::Enil) + | Eop Oadd (e1:::e2:::Enil) => (Aindexed2, e1:::e2:::Enil) + | _ => (Aindexed Int.zero, e:::Enil) + end. +*) + +Inductive addressing_cases: forall (e: expr), Set := + | addressing_case1: + forall (s: ident) (n: int), + addressing_cases (Eop (Oaddrsymbol s n) Enil) + | addressing_case2: + forall (n: int), + addressing_cases (Eop (Oaddrstack n) Enil) + | addressing_case3: + forall (s: ident) (n: int) (e2: expr), + addressing_cases + (Eop Oadd (Eop (Oaddrsymbol s n) Enil:::e2:::Enil)) + | addressing_case4: + forall (n: int) (e1: expr), + addressing_cases (Eop (Oaddimm n) (e1:::Enil)) + | addressing_case5: + forall (e1: expr) (e2: expr), + addressing_cases (Eop Oadd (e1:::e2:::Enil)) + | addressing_default: + forall (e: expr), + addressing_cases e. + +Definition addressing_match (e: expr) := + match e as z1 return addressing_cases z1 with + | Eop (Oaddrsymbol s n) Enil => + addressing_case1 s n + | Eop (Oaddrstack n) Enil => + addressing_case2 n + | Eop Oadd (Eop (Oaddrsymbol s n) Enil:::e2:::Enil) => + addressing_case3 s n e2 + | Eop (Oaddimm n) (e1:::Enil) => + addressing_case4 n e1 + | Eop Oadd (e1:::e2:::Enil) => + addressing_case5 e1 e2 + | e => + addressing_default e + end. + +Definition addressing (e: expr) := + match addressing_match e with + | addressing_case1 s n => + (Aglobal s n, Enil) + | addressing_case2 n => + (Ainstack n, Enil) + | addressing_case3 s n e2 => + (Abased s n, e2:::Enil) + | addressing_case4 n e1 => + (Aindexed n, e1:::Enil) + | addressing_case5 e1 e2 => + (Aindexed2, e1:::e2:::Enil) + | addressing_default e => + (Aindexed Int.zero, e:::Enil) + end. + +Definition load (chunk: memory_chunk) (e1: expr) := + match addressing e1 with + | (mode, args) => Eload chunk mode args + end. + +Definition store (chunk: memory_chunk) (e1 e2: expr) := + match addressing e1 with + | (mode, args) => Estore chunk mode args e2 + end. + +(** * Translation from Cminor to CminorSel *) + +(** Instruction selection for operator applications *) + +Definition sel_constant (cst: Cminor.constant) : expr := + match cst with + | Cminor.Ointconst n => Eop (Ointconst n) Enil + | Cminor.Ofloatconst f => Eop (Ofloatconst f) Enil + | Cminor.Oaddrsymbol id ofs => Eop (Oaddrsymbol id ofs) Enil + | Cminor.Oaddrstack ofs => Eop (Oaddrstack ofs) Enil + end. + +Definition sel_unop (op: Cminor.unary_operation) (arg: expr) : expr := + match op with + | Cminor.Ocast8unsigned => cast8unsigned arg + | Cminor.Ocast8signed => cast8signed arg + | Cminor.Ocast16unsigned => cast16unsigned arg + | Cminor.Ocast16signed => cast16signed arg + | Cminor.Onegint => Eop (Osubimm Int.zero) (arg ::: Enil) + | Cminor.Onotbool => notbool arg + | Cminor.Onotint => notint arg + | Cminor.Onegf => Eop Onegf (arg ::: Enil) + | Cminor.Oabsf => Eop Oabsf (arg ::: Enil) + | Cminor.Osingleoffloat => singleoffloat arg + | Cminor.Ointoffloat => Eop Ointoffloat (arg ::: Enil) + | Cminor.Ofloatofint => Eop Ofloatofint (arg ::: Enil) + | Cminor.Ofloatofintu => Eop Ofloatofintu (arg ::: Enil) + end. + +Definition sel_binop (op: Cminor.binary_operation) (arg1 arg2: expr) : expr := + match op with + | Cminor.Oadd => add arg1 arg2 + | Cminor.Osub => sub arg1 arg2 + | Cminor.Omul => mul arg1 arg2 + | Cminor.Odiv => divs arg1 arg2 + | Cminor.Odivu => divu arg1 arg2 + | Cminor.Omod => mods arg1 arg2 + | Cminor.Omodu => modu arg1 arg2 + | Cminor.Oand => and arg1 arg2 + | Cminor.Oor => or arg1 arg2 + | Cminor.Oxor => Eop Oxor (arg1 ::: arg2 ::: Enil) + | Cminor.Oshl => shl arg1 arg2 + | Cminor.Oshr => Eop Oshr (arg1 ::: arg2 ::: Enil) + | Cminor.Oshru => shru arg1 arg2 + | Cminor.Oaddf => addf arg1 arg2 + | Cminor.Osubf => subf arg1 arg2 + | Cminor.Omulf => Eop Omulf (arg1 ::: arg2 ::: Enil) + | Cminor.Odivf => Eop Odivf (arg1 ::: arg2 ::: Enil) + | Cminor.Ocmp c => Eop (Ocmp (Ccomp c)) (arg1 ::: arg2 ::: Enil) + | Cminor.Ocmpu c => Eop (Ocmp (Ccompu c)) (arg1 ::: arg2 ::: Enil) + | Cminor.Ocmpf c => Eop (Ocmp (Ccompf c)) (arg1 ::: arg2 ::: Enil) + end. + +(** Conversion from Cminor expression to Cminorsel expressions *) + +Fixpoint sel_expr (a: Cminor.expr) : expr := + match a with + | Cminor.Evar id => Evar id + | Cminor.Econst cst => sel_constant cst + | Cminor.Eunop op arg => sel_unop op (sel_expr arg) + | Cminor.Ebinop op arg1 arg2 => sel_binop op (sel_expr arg1) (sel_expr arg2) + | Cminor.Eload chunk addr => load chunk (sel_expr addr) + | Cminor.Estore chunk addr rhs => store chunk (sel_expr addr) (sel_expr rhs) + | Cminor.Ecall sg fn args => Ecall sg (sel_expr fn) (sel_exprlist args) + | Cminor.Econdition cond ifso ifnot => + Econdition (condexpr_of_expr (sel_expr cond)) + (sel_expr ifso) (sel_expr ifnot) + | Cminor.Elet b c => Elet (sel_expr b) (sel_expr c) + | Cminor.Eletvar n => Eletvar n + | Cminor.Ealloc b => Ealloc (sel_expr b) + end + +with sel_exprlist (al: Cminor.exprlist) : exprlist := + match al with + | Cminor.Enil => Enil + | Cminor.Econs a bl => Econs (sel_expr a) (sel_exprlist bl) + end. + +(** Conversion from Cminor statements to Cminorsel statements. *) + +Fixpoint sel_stmt (s: Cminor.stmt) : stmt := + match s with + | Cminor.Sskip => Sskip + | Cminor.Sexpr e => Sexpr (sel_expr e) + | Cminor.Sassign id e => Sassign id (sel_expr e) + | Cminor.Sseq s1 s2 => Sseq (sel_stmt s1) (sel_stmt s2) + | Cminor.Sifthenelse e ifso ifnot => + Sifthenelse (condexpr_of_expr (sel_expr e)) + (sel_stmt ifso) (sel_stmt ifnot) + | Cminor.Sloop body => Sloop (sel_stmt body) + | Cminor.Sblock body => Sblock (sel_stmt body) + | Cminor.Sexit n => Sexit n + | Cminor.Sswitch e cases dfl => Sswitch (sel_expr e) cases dfl + | Cminor.Sreturn None => Sreturn None + | Cminor.Sreturn (Some e) => Sreturn (Some (sel_expr e)) + | Cminor.Stailcall sg fn args => + Stailcall sg (sel_expr fn) (sel_exprlist args) + end. + +(** Conversion of functions and programs. *) + +Definition sel_function (f: Cminor.function) : function := + mkfunction + f.(Cminor.fn_sig) + f.(Cminor.fn_params) + f.(Cminor.fn_vars) + f.(Cminor.fn_stackspace) + (sel_stmt f.(Cminor.fn_body)). + +Definition sel_fundef (f: Cminor.fundef) : fundef := + transf_fundef sel_function f. + +Definition sel_program (p: Cminor.program) : program := + transform_program sel_fundef p. + + + diff --git a/backend/Selectionproof.v b/backend/Selectionproof.v new file mode 100644 index 00000000..e41765a7 --- /dev/null +++ b/backend/Selectionproof.v @@ -0,0 +1,1240 @@ +(** Correctness of instruction selection *) + +Require Import Coqlib. +Require Import Maps. +Require Import AST. +Require Import Integers. +Require Import Floats. +Require Import Values. +Require Import Mem. +Require Import Events. +Require Import Globalenvs. +Require Import Cminor. +Require Import Op. +Require Import CminorSel. +Require Import Selection. + +Open Local Scope selection_scope. + +Section CMCONSTR. + +Variable ge: genv. + +(** * Lifting of let-bound variables *) + +Inductive insert_lenv: letenv -> nat -> val -> letenv -> Prop := + | insert_lenv_0: + forall le v, + insert_lenv le O v (v :: le) + | insert_lenv_S: + forall le p w le' v, + insert_lenv le p w le' -> + insert_lenv (v :: le) (S p) w (v :: le'). + +Lemma insert_lenv_lookup1: + forall le p w le', + insert_lenv le p w le' -> + forall n v, + nth_error le n = Some v -> (p > n)%nat -> + nth_error le' n = Some v. +Proof. + induction 1; intros. + omegaContradiction. + destruct n; simpl; simpl in H0. auto. + apply IHinsert_lenv. auto. omega. +Qed. + +Lemma insert_lenv_lookup2: + forall le p w le', + insert_lenv le p w le' -> + forall n v, + nth_error le n = Some v -> (p <= n)%nat -> + nth_error le' (S n) = Some v. +Proof. + induction 1; intros. + simpl. assumption. + simpl. destruct n. omegaContradiction. + apply IHinsert_lenv. exact H0. omega. +Qed. + +Scheme eval_expr_ind_3 := Minimality for eval_expr Sort Prop + with eval_condexpr_ind_3 := Minimality for eval_condexpr Sort Prop + with eval_exprlist_ind_3 := Minimality for eval_exprlist Sort Prop. + +Hint Resolve eval_Evar eval_Eop eval_Eload eval_Estore + eval_Ecall eval_Econdition eval_Ealloc + eval_Elet eval_Eletvar + eval_CEtrue eval_CEfalse eval_CEcond + eval_CEcondition eval_Enil eval_Econs: evalexpr. + +Lemma eval_list_one: + forall sp le e m1 a t m2 v, + eval_expr ge sp le e m1 a t m2 v -> + eval_exprlist ge sp le e m1 (a ::: Enil) t m2 (v :: nil). +Proof. + intros. econstructor. eauto. constructor. traceEq. +Qed. + +Lemma eval_list_two: + forall sp le e m1 a1 t1 m2 v1 a2 t2 m3 v2 t, + eval_expr ge sp le e m1 a1 t1 m2 v1 -> + eval_expr ge sp le e m2 a2 t2 m3 v2 -> + t = t1 ** t2 -> + eval_exprlist ge sp le e m1 (a1 ::: a2 ::: Enil) t m3 (v1 :: v2 :: nil). +Proof. + intros. econstructor. eauto. econstructor. eauto. constructor. + reflexivity. traceEq. +Qed. + +Lemma eval_list_three: + forall sp le e m1 a1 t1 m2 v1 a2 t2 m3 v2 a3 t3 m4 v3 t, + eval_expr ge sp le e m1 a1 t1 m2 v1 -> + eval_expr ge sp le e m2 a2 t2 m3 v2 -> + eval_expr ge sp le e m3 a3 t3 m4 v3 -> + t = t1 ** t2 ** t3 -> + eval_exprlist ge sp le e m1 (a1 ::: a2 ::: a3 ::: Enil) t m4 (v1 :: v2 :: v3 :: nil). +Proof. + intros. econstructor. eauto. econstructor. eauto. econstructor. eauto. constructor. + reflexivity. reflexivity. traceEq. +Qed. + +Hint Resolve eval_list_one eval_list_two eval_list_three: evalexpr. + +Lemma eval_lift_expr: + forall w sp le e m1 a t m2 v, + eval_expr ge sp le e m1 a t m2 v -> + forall p le', insert_lenv le p w le' -> + eval_expr ge sp le' e m1 (lift_expr p a) t m2 v. +Proof. + intros w. + apply (eval_expr_ind_3 ge + (fun sp le e m1 a t m2 v => + forall p le', insert_lenv le p w le' -> + eval_expr ge sp le' e m1 (lift_expr p a) t m2 v) + (fun sp le e m1 a t m2 vb => + forall p le', insert_lenv le p w le' -> + eval_condexpr ge sp le' e m1 (lift_condexpr p a) t m2 vb) + (fun sp le e m1 al t m2 vl => + forall p le', insert_lenv le p w le' -> + eval_exprlist ge sp le' e m1 (lift_exprlist p al) t m2 vl)); + simpl; intros; eauto with evalexpr. + + destruct v1; eapply eval_Econdition; + eauto with evalexpr; simpl; eauto with evalexpr. + + eapply eval_Elet. eauto. apply H2. apply insert_lenv_S; auto. auto. + + case (le_gt_dec p n); intro. + apply eval_Eletvar. eapply insert_lenv_lookup2; eauto. + apply eval_Eletvar. eapply insert_lenv_lookup1; eauto. + + destruct vb1; eapply eval_CEcondition; + eauto with evalexpr; simpl; eauto with evalexpr. +Qed. + +Lemma eval_lift: + forall sp le e m1 a t m2 v w, + eval_expr ge sp le e m1 a t m2 v -> + eval_expr ge sp (w::le) e m1 (lift a) t m2 v. +Proof. + intros. unfold lift. eapply eval_lift_expr. + eexact H. apply insert_lenv_0. +Qed. +Hint Resolve eval_lift: evalexpr. + +(** * Useful lemmas and tactics *) + +(** The following are trivial lemmas and custom tactics that help + perform backward (inversion) and forward reasoning over the evaluation + of operator applications. *) + +Ltac EvalOp := eapply eval_Eop; eauto with evalexpr. + +Ltac TrivialOp cstr := unfold cstr; intros; EvalOp. + +Lemma inv_eval_Eop_0: + forall sp le e m1 op t m2 v, + eval_expr ge sp le e m1 (Eop op Enil) t m2 v -> + t = E0 /\ m2 = m1 /\ eval_operation ge sp op nil m1 = Some v. +Proof. + intros. inversion H. inversion H6. + intuition. congruence. +Qed. + +Lemma inv_eval_Eop_1: + forall sp le e m1 op t a1 m2 v, + eval_expr ge sp le e m1 (Eop op (a1 ::: Enil)) t m2 v -> + exists v1, + eval_expr ge sp le e m1 a1 t m2 v1 /\ + eval_operation ge sp op (v1 :: nil) m2 = Some v. +Proof. + intros. + inversion H. inversion H6. inversion H18. + subst. exists v1; intuition. rewrite E0_right. auto. +Qed. + +Lemma inv_eval_Eop_2: + forall sp le e m1 op a1 a2 t3 m3 v, + eval_expr ge sp le e m1 (Eop op (a1 ::: a2 ::: Enil)) t3 m3 v -> + exists t1, exists t2, exists m2, exists v1, exists v2, + eval_expr ge sp le e m1 a1 t1 m2 v1 /\ + eval_expr ge sp le e m2 a2 t2 m3 v2 /\ + t3 = t1 ** t2 /\ + eval_operation ge sp op (v1 :: v2 :: nil) m3 = Some v. +Proof. + intros. + inversion H. subst. inversion H6. subst. inversion H8. subst. + inversion H11. subst. + exists t1; exists t0; exists m0; exists v0; exists v1. + intuition. traceEq. +Qed. + +Ltac SimplEval := + match goal with + | [ |- (eval_expr _ ?sp ?le ?e ?m1 (Eop ?op Enil) ?t ?m2 ?v) -> _] => + intro XX1; + generalize (inv_eval_Eop_0 sp le e m1 op t m2 v XX1); + clear XX1; + intros [XX1 [XX2 XX3]]; + subst t m2; simpl in XX3; + try (simplify_eq XX3; clear XX3; + let EQ := fresh "EQ" in (intro EQ; rewrite EQ)) + | [ |- (eval_expr _ ?sp ?le ?e ?m1 (Eop ?op (?a1 ::: Enil)) ?t ?m2 ?v) -> _] => + intro XX1; + generalize (inv_eval_Eop_1 sp le e m1 op t a1 m2 v XX1); + clear XX1; + let v1 := fresh "v" in let EV := fresh "EV" in + let EQ := fresh "EQ" in + (intros [v1 [EV EQ]]; simpl in EQ) + | [ |- (eval_expr _ ?sp ?le ?e ?m1 (Eop ?op (?a1 ::: ?a2 ::: Enil)) ?t ?m2 ?v) -> _] => + intro XX1; + generalize (inv_eval_Eop_2 sp le e m1 op a1 a2 t m2 v XX1); + clear XX1; + let t1 := fresh "t" in let t2 := fresh "t" in + let m := fresh "m" in + let v1 := fresh "v" in let v2 := fresh "v" in + let EV1 := fresh "EV" in let EV2 := fresh "EV" in + let EQ := fresh "EQ" in let TR := fresh "TR" in + (intros [t1 [t2 [m [v1 [v2 [EV1 [EV2 [TR EQ]]]]]]]]; simpl in EQ) + | _ => idtac + end. + +Ltac InvEval H := + generalize H; SimplEval; clear H. + +(** * Correctness of the smart constructors *) + +(** We now show that the code generated by "smart constructor" functions + such as [Selection.notint] behaves as expected. Continuing the + [notint] example, we show that if the expression [e] + evaluates to some integer value [Vint n], then [Selection.notint e] + evaluates to a value [Vint (Int.not n)] which is indeed the integer + negation of the value of [e]. + + All proofs follow a common pattern: +- Reasoning by case over the result of the classification functions + (such as [add_match] for integer addition), gathering additional + information on the shape of the argument expressions in the non-default + cases. +- Inversion of the evaluations of the arguments, exploiting the additional + information thus gathered. +- Equational reasoning over the arithmetic operations performed, + using the lemmas from the [Int] and [Float] modules. +- Construction of an evaluation derivation for the expression returned + by the smart constructor. +*) + +Lemma eval_notint: + forall sp le e m1 a t m2 x, + eval_expr ge sp le e m1 a t m2 (Vint x) -> + eval_expr ge sp le e m1 (notint a) t m2 (Vint (Int.not x)). +Proof. + unfold notint; intros until x; case (notint_match a); intros. + InvEval H. FuncInv. EvalOp. simpl. congruence. + InvEval H. FuncInv. EvalOp. simpl. congruence. + InvEval H. FuncInv. EvalOp. simpl. congruence. + eapply eval_Elet. eexact H. + eapply eval_Eop. + eapply eval_Econs. apply eval_Eletvar. simpl. reflexivity. + eapply eval_Econs. apply eval_Eletvar. simpl. reflexivity. + apply eval_Enil. reflexivity. reflexivity. + simpl. rewrite Int.or_idem. auto. traceEq. +Qed. + +Lemma eval_notbool_base: + forall sp le e m1 a t m2 v b, + eval_expr ge sp le e m1 a t m2 v -> + Val.bool_of_val v b -> + eval_expr ge sp le e m1 (notbool_base a) t m2 (Val.of_bool (negb b)). +Proof. + TrivialOp notbool_base. simpl. + inversion H0. + rewrite Int.eq_false; auto. + rewrite Int.eq_true; auto. + reflexivity. +Qed. + +Hint Resolve Val.bool_of_true_val Val.bool_of_false_val + Val.bool_of_true_val_inv Val.bool_of_false_val_inv: valboolof. + +Lemma eval_notbool: + forall a sp le e m1 t m2 v b, + eval_expr ge sp le e m1 a t m2 v -> + Val.bool_of_val v b -> + eval_expr ge sp le e m1 (notbool a) t m2 (Val.of_bool (negb b)). +Proof. + assert (N1: forall v b, Val.is_false v -> Val.bool_of_val v b -> Val.is_true (Val.of_bool (negb b))). + intros. inversion H0; simpl; auto; subst v; simpl in H. + congruence. apply Int.one_not_zero. contradiction. + assert (N2: forall v b, Val.is_true v -> Val.bool_of_val v b -> Val.is_false (Val.of_bool (negb b))). + intros. inversion H0; simpl; auto; subst v; simpl in H. + congruence. + + induction a; simpl; intros; try (eapply eval_notbool_base; eauto). + destruct o; try (eapply eval_notbool_base; eauto). + + destruct e. InvEval H. injection XX3; clear XX3; intro; subst v. + inversion H0. rewrite Int.eq_false; auto. + simpl; eauto with evalexpr. + rewrite Int.eq_true; simpl; eauto with evalexpr. + eapply eval_notbool_base; eauto. + + inversion H. subst. + simpl in H11. eapply eval_Eop; eauto. + simpl. caseEq (eval_condition c vl m2); intros. + rewrite H1 in H11. + assert (b0 = b). + destruct b0; inversion H11; subst v; inversion H0; auto. + subst b0. rewrite (Op.eval_negate_condition _ _ _ H1). + destruct b; reflexivity. + rewrite H1 in H11; discriminate. + + inversion H; eauto 10 with evalexpr valboolof. + inversion H; eauto 10 with evalexpr valboolof. + + inversion H. subst. eapply eval_Econdition with (t2 := t8). eexact H34. + destruct v4; eauto. auto. +Qed. + +Lemma eval_addimm: + forall sp le e m1 n a t m2 x, + eval_expr ge sp le e m1 a t m2 (Vint x) -> + eval_expr ge sp le e m1 (addimm n a) t m2 (Vint (Int.add x n)). +Proof. + unfold addimm; intros until x. + generalize (Int.eq_spec n Int.zero). case (Int.eq n Int.zero); intro. + subst n. rewrite Int.add_zero. auto. + case (addimm_match a); intros. + InvEval H0. EvalOp. simpl. rewrite Int.add_commut. auto. + InvEval H0. destruct (Genv.find_symbol ge s); discriminate. + InvEval H0. + destruct sp; simpl in XX3; discriminate. + InvEval H0. FuncInv. EvalOp. simpl. subst x. + rewrite Int.add_assoc. decEq; decEq; decEq. apply Int.add_commut. + EvalOp. +Qed. + +Lemma eval_addimm_ptr: + forall sp le e m1 n t a m2 b ofs, + eval_expr ge sp le e m1 a t m2 (Vptr b ofs) -> + eval_expr ge sp le e m1 (addimm n a) t m2 (Vptr b (Int.add ofs n)). +Proof. + unfold addimm; intros until ofs. + generalize (Int.eq_spec n Int.zero). case (Int.eq n Int.zero); intro. + subst n. rewrite Int.add_zero. auto. + case (addimm_match a); intros. + InvEval H0. + InvEval H0. EvalOp. simpl. + destruct (Genv.find_symbol ge s). + rewrite Int.add_commut. congruence. + discriminate. + InvEval H0. destruct sp; simpl in XX3; try discriminate. + inversion XX3. EvalOp. simpl. decEq. decEq. + rewrite Int.add_assoc. decEq. apply Int.add_commut. + InvEval H0. FuncInv. subst b0; subst ofs. EvalOp. simpl. + rewrite (Int.add_commut n m). rewrite Int.add_assoc. auto. + EvalOp. +Qed. + +Lemma eval_add: + forall sp le e m1 a t1 m2 x b t2 m3 y, + eval_expr ge sp le e m1 a t1 m2 (Vint x) -> + eval_expr ge sp le e m2 b t2 m3 (Vint y) -> + eval_expr ge sp le e m1 (add a b) (t1**t2) m3 (Vint (Int.add x y)). +Proof. + intros until y. unfold add; case (add_match a b); intros. + InvEval H. rewrite Int.add_commut. apply eval_addimm. + rewrite E0_left; assumption. + InvEval H. FuncInv. InvEval H0. FuncInv. + replace (Int.add x y) with (Int.add (Int.add i i0) (Int.add n1 n2)). + apply eval_addimm. EvalOp. + subst x; subst y. + repeat rewrite Int.add_assoc. decEq. apply Int.add_permut. + InvEval H. FuncInv. + replace (Int.add x y) with (Int.add (Int.add i y) n1). + apply eval_addimm. EvalOp. + subst x. repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. + InvEval H0. FuncInv. + apply eval_addimm. rewrite E0_right. auto. + InvEval H0. FuncInv. + replace (Int.add x y) with (Int.add (Int.add x i) n2). + apply eval_addimm. EvalOp. + subst y. rewrite Int.add_assoc. auto. + EvalOp. +Qed. + +Lemma eval_add_ptr: + forall sp le e m1 a t1 m2 p x b t2 m3 y, + eval_expr ge sp le e m1 a t1 m2 (Vptr p x) -> + eval_expr ge sp le e m2 b t2 m3 (Vint y) -> + eval_expr ge sp le e m1 (add a b) (t1**t2) m3 (Vptr p (Int.add x y)). +Proof. + intros until y. unfold add; case (add_match a b); intros. + InvEval H. + InvEval H. FuncInv. InvEval H0. FuncInv. + replace (Int.add x y) with (Int.add (Int.add i i0) (Int.add n1 n2)). + apply eval_addimm_ptr. subst b0. EvalOp. + subst x; subst y. + repeat rewrite Int.add_assoc. decEq. apply Int.add_permut. + InvEval H. FuncInv. + replace (Int.add x y) with (Int.add (Int.add i y) n1). + apply eval_addimm_ptr. subst b0. EvalOp. + subst x. repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. + InvEval H0. apply eval_addimm_ptr. rewrite E0_right. auto. + InvEval H0. FuncInv. + replace (Int.add x y) with (Int.add (Int.add x i) n2). + apply eval_addimm_ptr. EvalOp. + subst y. rewrite Int.add_assoc. auto. + EvalOp. +Qed. + +Lemma eval_add_ptr_2: + forall sp le e m1 a t1 m2 p x b t2 m3 y, + eval_expr ge sp le e m1 a t1 m2 (Vint x) -> + eval_expr ge sp le e m2 b t2 m3 (Vptr p y) -> + eval_expr ge sp le e m1 (add a b) (t1**t2) m3 (Vptr p (Int.add y x)). +Proof. + intros until y. unfold add; case (add_match a b); intros. + InvEval H. + apply eval_addimm_ptr. rewrite E0_left. auto. + InvEval H. FuncInv. InvEval H0. FuncInv. + replace (Int.add y x) with (Int.add (Int.add i0 i) (Int.add n1 n2)). + apply eval_addimm_ptr. subst b0. EvalOp. + subst x; subst y. + repeat rewrite Int.add_assoc. decEq. + rewrite (Int.add_commut n1 n2). apply Int.add_permut. + InvEval H. FuncInv. + replace (Int.add y x) with (Int.add (Int.add y i) n1). + apply eval_addimm_ptr. EvalOp. + subst x. repeat rewrite Int.add_assoc. auto. + InvEval H0. + InvEval H0. FuncInv. + replace (Int.add y x) with (Int.add (Int.add i x) n2). + apply eval_addimm_ptr. EvalOp. subst b0; reflexivity. + subst y. repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. + EvalOp. +Qed. + +Lemma eval_sub: + forall sp le e m1 a t1 m2 x b t2 m3 y, + eval_expr ge sp le e m1 a t1 m2 (Vint x) -> + eval_expr ge sp le e m2 b t2 m3 (Vint y) -> + eval_expr ge sp le e m1 (sub a b) (t1**t2) m3 (Vint (Int.sub x y)). +Proof. + intros until y. + unfold sub; case (sub_match a b); intros. + InvEval H0. rewrite Int.sub_add_opp. + apply eval_addimm. rewrite E0_right. assumption. + InvEval H. FuncInv. InvEval H0. FuncInv. + replace (Int.sub x y) with (Int.add (Int.sub i i0) (Int.sub n1 n2)). + apply eval_addimm. EvalOp. + subst x; subst y. + repeat rewrite Int.sub_add_opp. + repeat rewrite Int.add_assoc. decEq. + rewrite Int.add_permut. decEq. symmetry. apply Int.neg_add_distr. + InvEval H. FuncInv. + replace (Int.sub x y) with (Int.add (Int.sub i y) n1). + apply eval_addimm. EvalOp. + subst x. rewrite Int.sub_add_l. auto. + InvEval H0. FuncInv. + replace (Int.sub x y) with (Int.add (Int.sub x i) (Int.neg n2)). + apply eval_addimm. EvalOp. + subst y. rewrite (Int.add_commut i n2). symmetry. apply Int.sub_add_r. + EvalOp. +Qed. + +Lemma eval_sub_ptr_int: + forall sp le e m1 a t1 m2 p x b t2 m3 y, + eval_expr ge sp le e m1 a t1 m2 (Vptr p x) -> + eval_expr ge sp le e m2 b t2 m3 (Vint y) -> + eval_expr ge sp le e m1 (sub a b) (t1**t2) m3 (Vptr p (Int.sub x y)). +Proof. + intros until y. + unfold sub; case (sub_match a b); intros. + InvEval H0. rewrite Int.sub_add_opp. + apply eval_addimm_ptr. rewrite E0_right. assumption. + InvEval H. FuncInv. InvEval H0. FuncInv. + subst b0. + replace (Int.sub x y) with (Int.add (Int.sub i i0) (Int.sub n1 n2)). + apply eval_addimm_ptr. EvalOp. + subst x; subst y. + repeat rewrite Int.sub_add_opp. + repeat rewrite Int.add_assoc. decEq. + rewrite Int.add_permut. decEq. symmetry. apply Int.neg_add_distr. + InvEval H. FuncInv. subst b0. + replace (Int.sub x y) with (Int.add (Int.sub i y) n1). + apply eval_addimm_ptr. EvalOp. + subst x. rewrite Int.sub_add_l. auto. + InvEval H0. FuncInv. + replace (Int.sub x y) with (Int.add (Int.sub x i) (Int.neg n2)). + apply eval_addimm_ptr. EvalOp. + subst y. rewrite (Int.add_commut i n2). symmetry. apply Int.sub_add_r. + EvalOp. +Qed. + +Lemma eval_sub_ptr_ptr: + forall sp le e m1 a t1 m2 p x b t2 m3 y, + eval_expr ge sp le e m1 a t1 m2 (Vptr p x) -> + eval_expr ge sp le e m2 b t2 m3 (Vptr p y) -> + eval_expr ge sp le e m1 (sub a b) (t1**t2) m3 (Vint (Int.sub x y)). +Proof. + intros until y. + unfold sub; case (sub_match a b); intros. + InvEval H0. + InvEval H. FuncInv. InvEval H0. FuncInv. + replace (Int.sub x y) with (Int.add (Int.sub i i0) (Int.sub n1 n2)). + apply eval_addimm. EvalOp. + simpl; unfold eq_block. subst b0; subst b1; rewrite zeq_true. auto. + subst x; subst y. + repeat rewrite Int.sub_add_opp. + repeat rewrite Int.add_assoc. decEq. + rewrite Int.add_permut. decEq. symmetry. apply Int.neg_add_distr. + InvEval H. FuncInv. subst b0. + replace (Int.sub x y) with (Int.add (Int.sub i y) n1). + apply eval_addimm. EvalOp. + simpl. unfold eq_block. rewrite zeq_true. auto. + subst x. rewrite Int.sub_add_l. auto. + InvEval H0. FuncInv. subst b0. + replace (Int.sub x y) with (Int.add (Int.sub x i) (Int.neg n2)). + apply eval_addimm. EvalOp. + simpl. unfold eq_block. rewrite zeq_true. auto. + subst y. rewrite (Int.add_commut i n2). symmetry. apply Int.sub_add_r. + EvalOp. simpl. unfold eq_block. rewrite zeq_true. auto. +Qed. + +Lemma eval_rolm: + forall sp le e m1 a amount mask t m2 x, + eval_expr ge sp le e m1 a t m2 (Vint x) -> + eval_expr ge sp le e m1 (rolm a amount mask) t m2 (Vint (Int.rolm x amount mask)). +Proof. + intros until x. unfold rolm; case (rolm_match a); intros. + InvEval H. eauto with evalexpr. + case (Int.is_rlw_mask (Int.and (Int.rol mask1 amount) mask)). + InvEval H. FuncInv. EvalOp. simpl. subst x. + decEq. decEq. + replace (Int.and (Int.add amount1 amount) (Int.repr 31)) + with (Int.modu (Int.add amount1 amount) (Int.repr 32)). + symmetry. apply Int.rolm_rolm. + change (Int.repr 31) with (Int.sub (Int.repr 32) Int.one). + apply Int.modu_and with (Int.repr 5). reflexivity. + EvalOp. + EvalOp. +Qed. + +Lemma eval_shlimm: + forall sp le e m1 a n t m2 x, + eval_expr ge sp le e m1 a t m2 (Vint x) -> + Int.ltu n (Int.repr 32) = true -> + eval_expr ge sp le e m1 (shlimm a n) t m2 (Vint (Int.shl x n)). +Proof. + intros. unfold shlimm. + generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intro. + subst n. rewrite Int.shl_zero. auto. + rewrite H0. + replace (Int.shl x n) with (Int.rolm x n (Int.shl Int.mone n)). + apply eval_rolm. auto. symmetry. apply Int.shl_rolm. exact H0. +Qed. + +Lemma eval_shruimm: + forall sp le e m1 a n t m2 x, + eval_expr ge sp le e m1 a t m2 (Vint x) -> + Int.ltu n (Int.repr 32) = true -> + eval_expr ge sp le e m1 (shruimm a n) t m2 (Vint (Int.shru x n)). +Proof. + intros. unfold shruimm. + generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intro. + subst n. rewrite Int.shru_zero. auto. + rewrite H0. + replace (Int.shru x n) with (Int.rolm x (Int.sub (Int.repr 32) n) (Int.shru Int.mone n)). + apply eval_rolm. auto. symmetry. apply Int.shru_rolm. exact H0. +Qed. + +Lemma eval_mulimm_base: + forall sp le e m1 a t n m2 x, + eval_expr ge sp le e m1 a t m2 (Vint x) -> + eval_expr ge sp le e m1 (mulimm_base n a) t m2 (Vint (Int.mul x n)). +Proof. + intros; unfold mulimm_base. + generalize (Int.one_bits_decomp n). + generalize (Int.one_bits_range n). + change (Z_of_nat wordsize) with 32. + destruct (Int.one_bits n). + intros. EvalOp. + destruct l. + intros. rewrite H1. simpl. + rewrite Int.add_zero. rewrite <- Int.shl_mul. + apply eval_shlimm. auto. auto with coqlib. + destruct l. + intros. apply eval_Elet with t m2 (Vint x) E0. auto. + rewrite H1. simpl. rewrite Int.add_zero. + rewrite Int.mul_add_distr_r. + rewrite <- Int.shl_mul. + rewrite <- Int.shl_mul. + EvalOp. eapply eval_Econs. + apply eval_shlimm. apply eval_Eletvar. simpl. reflexivity. + auto with coqlib. + eapply eval_Econs. + apply eval_shlimm. apply eval_Eletvar. simpl. reflexivity. + auto with coqlib. + auto with evalexpr. + reflexivity. traceEq. reflexivity. traceEq. + intros. EvalOp. +Qed. + +Lemma eval_mulimm: + forall sp le e m1 a n t m2 x, + eval_expr ge sp le e m1 a t m2 (Vint x) -> + eval_expr ge sp le e m1 (mulimm n a) t m2 (Vint (Int.mul x n)). +Proof. + intros until x; unfold mulimm. + generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intro. + subst n. rewrite Int.mul_zero. + intro. eapply eval_Elet; eauto with evalexpr. traceEq. + generalize (Int.eq_spec n Int.one); case (Int.eq n Int.one); intro. + subst n. rewrite Int.mul_one. auto. + case (mulimm_match a); intros. + InvEval H1. EvalOp. rewrite Int.mul_commut. reflexivity. + InvEval H1. FuncInv. + replace (Int.mul x n) with (Int.add (Int.mul i n) (Int.mul n n2)). + apply eval_addimm. apply eval_mulimm_base. auto. + subst x. rewrite Int.mul_add_distr_l. decEq. apply Int.mul_commut. + apply eval_mulimm_base. assumption. +Qed. + +Lemma eval_mul: + forall sp le e m1 a t1 m2 x b t2 m3 y, + eval_expr ge sp le e m1 a t1 m2 (Vint x) -> + eval_expr ge sp le e m2 b t2 m3 (Vint y) -> + eval_expr ge sp le e m1 (mul a b) (t1**t2) m3 (Vint (Int.mul x y)). +Proof. + intros until y. + unfold mul; case (mul_match a b); intros. + InvEval H. rewrite Int.mul_commut. apply eval_mulimm. + rewrite E0_left; auto. + InvEval H0. rewrite E0_right. apply eval_mulimm. auto. + EvalOp. +Qed. + +Lemma eval_divs: + forall sp le e m1 a t1 m2 x b t2 m3 y, + eval_expr ge sp le e m1 a t1 m2 (Vint x) -> + eval_expr ge sp le e m2 b t2 m3 (Vint y) -> + y <> Int.zero -> + eval_expr ge sp le e m1 (divs a b) (t1**t2) m3 (Vint (Int.divs x y)). +Proof. + TrivialOp divs. simpl. + predSpec Int.eq Int.eq_spec y Int.zero. contradiction. auto. +Qed. + +Lemma eval_mod_aux: + forall divop semdivop, + (forall sp x y m, + y <> Int.zero -> + eval_operation ge sp divop (Vint x :: Vint y :: nil) m = + Some (Vint (semdivop x y))) -> + forall sp le e m1 a t1 m2 x b t2 m3 y, + eval_expr ge sp le e m1 a t1 m2 (Vint x) -> + eval_expr ge sp le e m2 b t2 m3 (Vint y) -> + y <> Int.zero -> + eval_expr ge sp le e m1 (mod_aux divop a b) (t1**t2) m3 + (Vint (Int.sub x (Int.mul (semdivop x y) y))). +Proof. + intros; unfold mod_aux. + eapply eval_Elet. eexact H0. eapply eval_Elet. + apply eval_lift. eexact H1. + eapply eval_Eop. eapply eval_Econs. + eapply eval_Eletvar. simpl; reflexivity. + eapply eval_Econs. eapply eval_Eop. + eapply eval_Econs. eapply eval_Eop. + eapply eval_Econs. apply eval_Eletvar. simpl; reflexivity. + eapply eval_Econs. apply eval_Eletvar. simpl; reflexivity. + apply eval_Enil. reflexivity. reflexivity. + apply H. assumption. + eapply eval_Econs. apply eval_Eletvar. simpl; reflexivity. + apply eval_Enil. reflexivity. reflexivity. + simpl; reflexivity. apply eval_Enil. + reflexivity. reflexivity. reflexivity. + reflexivity. traceEq. +Qed. + +Lemma eval_mods: + forall sp le e m1 a t1 m2 x b t2 m3 y, + eval_expr ge sp le e m1 a t1 m2 (Vint x) -> + eval_expr ge sp le e m2 b t2 m3 (Vint y) -> + y <> Int.zero -> + eval_expr ge sp le e m1 (mods a b) (t1**t2) m3 (Vint (Int.mods x y)). +Proof. + intros; unfold mods. + rewrite Int.mods_divs. + eapply eval_mod_aux; eauto. + intros. simpl. predSpec Int.eq Int.eq_spec y0 Int.zero. + contradiction. auto. +Qed. + +Lemma eval_divu_base: + forall sp le e m1 a t1 m2 x b t2 m3 y, + eval_expr ge sp le e m1 a t1 m2 (Vint x) -> + eval_expr ge sp le e m2 b t2 m3 (Vint y) -> + y <> Int.zero -> + eval_expr ge sp le e m1 (Eop Odivu (a ::: b ::: Enil)) (t1**t2) m3 (Vint (Int.divu x y)). +Proof. + intros. EvalOp. simpl. + predSpec Int.eq Int.eq_spec y Int.zero. contradiction. auto. +Qed. + +Lemma eval_divu: + forall sp le e m1 a t1 m2 x b t2 m3 y, + eval_expr ge sp le e m1 a t1 m2 (Vint x) -> + eval_expr ge sp le e m2 b t2 m3 (Vint y) -> + y <> Int.zero -> + eval_expr ge sp le e m1 (divu a b) (t1**t2) m3 (Vint (Int.divu x y)). +Proof. + intros until y. + unfold divu; case (divu_match b); intros. + InvEval H0. caseEq (Int.is_power2 y). + intros. rewrite (Int.divu_pow2 x y i H0). + apply eval_shruimm. rewrite E0_right. auto. + apply Int.is_power2_range with y. auto. + intros. subst n2. eapply eval_divu_base. eexact H. EvalOp. auto. + eapply eval_divu_base; eauto. +Qed. + +Lemma eval_modu: + forall sp le e m1 a t1 m2 x b t2 m3 y, + eval_expr ge sp le e m1 a t1 m2 (Vint x) -> + eval_expr ge sp le e m2 b t2 m3 (Vint y) -> + y <> Int.zero -> + eval_expr ge sp le e m1 (modu a b) (t1**t2) m3 (Vint (Int.modu x y)). +Proof. + intros until y; unfold modu; case (divu_match b); intros. + InvEval H0. caseEq (Int.is_power2 y). + intros. rewrite (Int.modu_and x y i H0). + rewrite <- Int.rolm_zero. apply eval_rolm. rewrite E0_right; auto. + intro. rewrite Int.modu_divu. eapply eval_mod_aux. + intros. simpl. predSpec Int.eq Int.eq_spec y0 Int.zero. + contradiction. auto. + eexact H. EvalOp. auto. auto. + rewrite Int.modu_divu. eapply eval_mod_aux. + intros. simpl. predSpec Int.eq Int.eq_spec y0 Int.zero. + contradiction. auto. + eexact H. eexact H0. auto. auto. +Qed. + +Lemma eval_andimm: + forall sp le e m1 n a t m2 x, + eval_expr ge sp le e m1 a t m2 (Vint x) -> + eval_expr ge sp le e m1 (andimm n a) t m2 (Vint (Int.and x n)). +Proof. + intros. unfold andimm. case (Int.is_rlw_mask n). + rewrite <- Int.rolm_zero. apply eval_rolm; auto. + EvalOp. +Qed. + +Lemma eval_and: + forall sp le e m1 a t1 m2 x b t2 m3 y, + eval_expr ge sp le e m1 a t1 m2 (Vint x) -> + eval_expr ge sp le e m2 b t2 m3 (Vint y) -> + eval_expr ge sp le e m1 (and a b) (t1**t2) m3 (Vint (Int.and x y)). +Proof. + intros until y; unfold and; case (mul_match a b); intros. + InvEval H. rewrite Int.and_commut. + rewrite E0_left; apply eval_andimm; auto. + InvEval H0. rewrite E0_right; apply eval_andimm; auto. + EvalOp. +Qed. + +Remark eval_same_expr_pure: + forall a1 a2 sp le e m1 t1 m2 v1 t2 m3 v2, + same_expr_pure a1 a2 = true -> + eval_expr ge sp le e m1 a1 t1 m2 v1 -> + eval_expr ge sp le e m2 a2 t2 m3 v2 -> + t1 = E0 /\ t2 = E0 /\ a2 = a1 /\ v2 = v1 /\ m2 = m1. +Proof. + intros until v2. + destruct a1; simpl; try (intros; discriminate). + destruct a2; simpl; try (intros; discriminate). + case (ident_eq i i0); intros. + subst i0. inversion H0. inversion H1. + assert (v2 = v1). congruence. tauto. + discriminate. +Qed. + +Lemma eval_or: + forall sp le e m1 a t1 m2 x b t2 m3 y, + eval_expr ge sp le e m1 a t1 m2 (Vint x) -> + eval_expr ge sp le e m2 b t2 m3 (Vint y) -> + eval_expr ge sp le e m1 (or a b) (t1**t2) m3 (Vint (Int.or x y)). +Proof. + intros until y; unfold or; case (or_match a b); intros. + generalize (Int.eq_spec amount1 amount2); case (Int.eq amount1 amount2); intro. + case (Int.is_rlw_mask (Int.or mask1 mask2)). + caseEq (same_expr_pure t0 t3); intro. + simpl. InvEval H. FuncInv. InvEval H0. FuncInv. + generalize (eval_same_expr_pure _ _ _ _ _ _ _ _ _ _ _ _ H2 EV EV0). + intros [EQ1 [EQ2 [EQ3 [EQ4 EQ5]]]]. + injection EQ4; intro EQ7. subst. + EvalOp. simpl. rewrite Int.or_rolm. auto. + simpl. EvalOp. + simpl. EvalOp. + simpl. EvalOp. + EvalOp. +Qed. + +Lemma eval_shl: + forall sp le e m1 a t1 m2 x b t2 m3 y, + eval_expr ge sp le e m1 a t1 m2 (Vint x) -> + eval_expr ge sp le e m2 b t2 m3 (Vint y) -> + Int.ltu y (Int.repr 32) = true -> + eval_expr ge sp le e m1 (shl a b) (t1**t2) m3 (Vint (Int.shl x y)). +Proof. + intros until y; unfold shl; case (shift_match b); intros. + InvEval H0. rewrite E0_right. apply eval_shlimm; auto. + EvalOp. simpl. rewrite H1. auto. +Qed. + +Lemma eval_shru: + forall sp le e m1 a t1 m2 x b t2 m3 y, + eval_expr ge sp le e m1 a t1 m2 (Vint x) -> + eval_expr ge sp le e m2 b t2 m3 (Vint y) -> + Int.ltu y (Int.repr 32) = true -> + eval_expr ge sp le e m1 (shru a b) (t1**t2) m3 (Vint (Int.shru x y)). +Proof. + intros until y; unfold shru; case (shift_match b); intros. + InvEval H0. rewrite E0_right; apply eval_shruimm; auto. + EvalOp. simpl. rewrite H1. auto. +Qed. + +Lemma eval_addf: + forall sp le e m1 a t1 m2 x b t2 m3 y, + eval_expr ge sp le e m1 a t1 m2 (Vfloat x) -> + eval_expr ge sp le e m2 b t2 m3 (Vfloat y) -> + eval_expr ge sp le e m1 (addf a b) (t1**t2) m3 (Vfloat (Float.add x y)). +Proof. + intros until y; unfold addf; case (addf_match a b); intros. + InvEval H. FuncInv. EvalOp. + econstructor; eauto. econstructor; eauto. econstructor; eauto. constructor. + traceEq. simpl. subst x. reflexivity. + InvEval H0. FuncInv. eapply eval_Elet. eexact H. EvalOp. + econstructor; eauto with evalexpr. + econstructor; eauto with evalexpr. + econstructor. apply eval_Eletvar. simpl; reflexivity. + constructor. reflexivity. traceEq. + subst y. rewrite Float.addf_commut. reflexivity. auto. + EvalOp. +Qed. + +Lemma eval_subf: + forall sp le e m1 a t1 m2 x b t2 m3 y, + eval_expr ge sp le e m1 a t1 m2 (Vfloat x) -> + eval_expr ge sp le e m2 b t2 m3 (Vfloat y) -> + eval_expr ge sp le e m1 (subf a b) (t1**t2) m3 (Vfloat (Float.sub x y)). +Proof. + intros until y; unfold subf; case (subf_match a b); intros. + InvEval H. FuncInv. EvalOp. + econstructor; eauto. econstructor; eauto. econstructor; eauto. constructor. + traceEq. subst x. reflexivity. + EvalOp. +Qed. + +Lemma eval_cast8signed: + forall sp le e m1 a t m2 v, + eval_expr ge sp le e m1 a t m2 v -> + eval_expr ge sp le e m1 (cast8signed a) t m2 (Val.cast8signed v). +Proof. + intros until v; unfold cast8signed; case (cast8signed_match a); intros. + replace (Val.cast8signed v) with v. auto. + InvEval H. inversion EQ. destruct v0; simpl; auto. rewrite Int.cast8_signed_idem. reflexivity. + EvalOp. +Qed. + +Lemma eval_cast8unsigned: + forall sp le e m1 a t m2 v, + eval_expr ge sp le e m1 a t m2 v -> + eval_expr ge sp le e m1 (cast8unsigned a) t m2 (Val.cast8unsigned v). +Proof. + intros until v; unfold cast8unsigned; case (cast8unsigned_match a); intros. + replace (Val.cast8unsigned v) with v. auto. + InvEval H. inversion EQ. destruct v0; simpl; auto. rewrite Int.cast8_unsigned_idem. reflexivity. + EvalOp. +Qed. + +Lemma eval_cast16signed: + forall sp le e m1 a t m2 v, + eval_expr ge sp le e m1 a t m2 v -> + eval_expr ge sp le e m1 (cast16signed a) t m2 (Val.cast16signed v). +Proof. + intros until v; unfold cast16signed; case (cast16signed_match a); intros. + replace (Val.cast16signed v) with v. auto. + InvEval H. inversion EQ. destruct v0; simpl; auto. rewrite Int.cast16_signed_idem. reflexivity. + EvalOp. +Qed. + +Lemma eval_cast16unsigned: + forall sp le e m1 a t m2 v, + eval_expr ge sp le e m1 a t m2 v -> + eval_expr ge sp le e m1 (cast16unsigned a) t m2 (Val.cast16unsigned v). +Proof. + intros until v; unfold cast16unsigned; case (cast16unsigned_match a); intros. + replace (Val.cast16unsigned v) with v. auto. + InvEval H. inversion EQ. destruct v0; simpl; auto. rewrite Int.cast16_unsigned_idem. reflexivity. + EvalOp. +Qed. + +Lemma eval_singleoffloat: + forall sp le e m1 a t m2 v, + eval_expr ge sp le e m1 a t m2 v -> + eval_expr ge sp le e m1 (singleoffloat a) t m2 (Val.singleoffloat v). +Proof. + intros until v; unfold singleoffloat; case (singleoffloat_match a); intros. + replace (Val.singleoffloat v) with v. auto. + InvEval H. inversion EQ. destruct v0; simpl; auto. rewrite Float.singleoffloat_idem. reflexivity. + EvalOp. +Qed. + +Lemma eval_base_condition_of_expr: + forall sp le a e m1 t m2 v (b: bool), + eval_expr ge sp le e m1 a t m2 v -> + Val.bool_of_val v b -> + eval_condexpr ge sp le e m1 + (CEcond (Ccompimm Cne Int.zero) (a ::: Enil)) + t m2 b. +Proof. + intros. + eapply eval_CEcond. eauto with evalexpr. + inversion H0; simpl. rewrite Int.eq_false; auto. auto. auto. +Qed. + +Lemma eval_condition_of_expr: + forall a sp le e m1 t m2 v (b: bool), + eval_expr ge sp le e m1 a t m2 v -> + Val.bool_of_val v b -> + eval_condexpr ge sp le e m1 (condexpr_of_expr a) t m2 b. +Proof. + induction a; simpl; intros; + try (eapply eval_base_condition_of_expr; eauto; fail). + destruct o; try (eapply eval_base_condition_of_expr; eauto; fail). + + destruct e. InvEval H. inversion XX3; subst v. + inversion H0. + rewrite Int.eq_false; auto. constructor. + subst i; rewrite Int.eq_true. constructor. + eapply eval_base_condition_of_expr; eauto. + + inversion H. subst. eapply eval_CEcond; eauto. simpl in H11. + destruct (eval_condition c vl); try discriminate. + destruct b0; inversion H11; subst; inversion H0; congruence. + + inversion H. subst. + destruct v1; eauto with evalexpr. +Qed. + +Lemma eval_addressing: + forall sp le e m1 a t m2 v b ofs, + eval_expr ge sp le e m1 a t m2 v -> + v = Vptr b ofs -> + match addressing a with (mode, args) => + exists vl, + eval_exprlist ge sp le e m1 args t m2 vl /\ + eval_addressing ge sp mode vl = Some v + end. +Proof. + intros until v. unfold addressing; case (addressing_match a); intros. + InvEval H. exists (@nil val). split. eauto with evalexpr. + simpl. auto. + InvEval H. exists (@nil val). split. eauto with evalexpr. + simpl. auto. + InvEval H. InvEval EV. rewrite E0_left in TR. subst t1. FuncInv. + congruence. + destruct (Genv.find_symbol ge s); congruence. + exists (Vint i0 :: nil). split. eauto with evalexpr. + simpl. subst v. destruct (Genv.find_symbol ge s). congruence. + discriminate. + InvEval H. FuncInv. + congruence. + exists (Vptr b0 i :: nil). split. eauto with evalexpr. + simpl. congruence. + InvEval H. FuncInv. + congruence. + exists (Vint i :: Vptr b0 i0 :: nil). + split. eauto with evalexpr. simpl. + rewrite Int.add_commut. congruence. + exists (Vptr b0 i :: Vint i0 :: nil). + split. eauto with evalexpr. simpl. congruence. + exists (v :: nil). split. eauto with evalexpr. + subst v. simpl. rewrite Int.add_zero. auto. +Qed. + +Lemma eval_load: + forall sp le e m1 a t m2 v chunk v', + eval_expr ge sp le e m1 a t m2 v -> + Mem.loadv chunk m2 v = Some v' -> + eval_expr ge sp le e m1 (load chunk a) t m2 v'. +Proof. + intros. generalize H0; destruct v; simpl; intro; try discriminate. + unfold load. + generalize (eval_addressing _ _ _ _ _ _ _ _ _ _ H (refl_equal _)). + destruct (addressing a). intros [vl [EV EQ]]. + eapply eval_Eload; eauto. +Qed. + +Lemma eval_store: + forall sp le e m1 a1 t1 m2 v1 a2 t2 m3 v2 chunk m4, + eval_expr ge sp le e m1 a1 t1 m2 v1 -> + eval_expr ge sp le e m2 a2 t2 m3 v2 -> + Mem.storev chunk m3 v1 v2 = Some m4 -> + eval_expr ge sp le e m1 (store chunk a1 a2) (t1**t2) m4 v2. +Proof. + intros. generalize H1; destruct v1; simpl; intro; try discriminate. + unfold store. + generalize (eval_addressing _ _ _ _ _ _ _ _ _ _ H (refl_equal _)). + destruct (addressing a1). intros [vl [EV EQ]]. + eapply eval_Estore; eauto. +Qed. + +(** * Correctness of instruction selection for operators *) + +(** We now prove a semantic preservation result for the [sel_unop] + and [sel_binop] selection functions. The proof exploits + the results of the previous section. *) + +Lemma eval_sel_unop: + forall sp le e m op a1 t m1 v1 v, + eval_expr ge sp le e m a1 t m1 v1 -> + eval_unop op v1 = Some v -> + eval_expr ge sp le e m (sel_unop op a1) t m1 v. +Proof. + destruct op; simpl; intros; FuncInv; try subst v. + apply eval_cast8unsigned; auto. + apply eval_cast8signed; auto. + apply eval_cast16unsigned; auto. + apply eval_cast16signed; auto. + EvalOp. + generalize (Int.eq_spec i Int.zero). destruct (Int.eq i Int.zero); intro. + change true with (negb false). eapply eval_notbool; eauto. subst i; constructor. + change false with (negb true). eapply eval_notbool; eauto. constructor; auto. + change Vfalse with (Val.of_bool (negb true)). + eapply eval_notbool; eauto. constructor. + apply eval_notint; auto. + EvalOp. + EvalOp. + apply eval_singleoffloat; auto. + EvalOp. + EvalOp. + EvalOp. +Qed. + +Lemma eval_sel_binop: + forall sp le e m op a1 a2 t1 m1 v1 t2 m2 v2 v, + eval_expr ge sp le e m a1 t1 m1 v1 -> + eval_expr ge sp le e m1 a2 t2 m2 v2 -> + eval_binop op v1 v2 m2 = Some v -> + eval_expr ge sp le e m (sel_binop op a1 a2) (t1 ** t2) m2 v. +Proof. + destruct op; simpl; intros; FuncInv; try subst v. + eapply eval_add; eauto. + eapply eval_add_ptr_2; eauto. + eapply eval_add_ptr; eauto. + eapply eval_sub; eauto. + eapply eval_sub_ptr_int; eauto. + destruct (eq_block b b0); inv H1. + eapply eval_sub_ptr_ptr; eauto. + eapply eval_mul; eauto. + generalize (Int.eq_spec i0 Int.zero). intro. destruct (Int.eq i0 Int.zero); inv H1. + eapply eval_divs; eauto. + generalize (Int.eq_spec i0 Int.zero). intro. destruct (Int.eq i0 Int.zero); inv H1. + eapply eval_divu; eauto. + generalize (Int.eq_spec i0 Int.zero). intro. destruct (Int.eq i0 Int.zero); inv H1. + eapply eval_mods; eauto. + generalize (Int.eq_spec i0 Int.zero). intro. destruct (Int.eq i0 Int.zero); inv H1. + eapply eval_modu; eauto. + eapply eval_and; eauto. + eapply eval_or; eauto. + EvalOp. + caseEq (Int.ltu i0 (Int.repr 32)); intro; rewrite H2 in H1; inv H1. + eapply eval_shl; eauto. + EvalOp. + caseEq (Int.ltu i0 (Int.repr 32)); intro; rewrite H2 in H1; inv H1. + eapply eval_shru; eauto. + eapply eval_addf; eauto. + eapply eval_subf; eauto. + EvalOp. + EvalOp. + EvalOp. simpl. destruct (Int.cmp c i i0); auto. + EvalOp. simpl. generalize H1; unfold eval_compare_null, Cminor.eval_compare_null. + destruct (Int.eq i Int.zero). destruct c; intro EQ; inv EQ; auto. + auto. + EvalOp. simpl. generalize H1; unfold eval_compare_null, Cminor.eval_compare_null. + destruct (Int.eq i0 Int.zero). destruct c; intro EQ; inv EQ; auto. + auto. + EvalOp. simpl. + destruct (valid_pointer m2 b (Int.signed i) && valid_pointer m2 b0 (Int.signed i0)). + destruct (eq_block b b0); inv H1. + destruct (Int.cmp c i i0); auto. + auto. + EvalOp. simpl. destruct (Int.cmpu c i i0); auto. + EvalOp. simpl. destruct (Float.cmp c f f0); auto. +Qed. + +End CMCONSTR. + +(** * Semantic preservation for instruction selection. *) + +Section PRESERVATION. + +Variable prog: Cminor.program. +Let tprog := sel_program prog. +Let ge := Genv.globalenv prog. +Let tge := Genv.globalenv tprog. + +(** Relationship between the global environments for the original + CminorSel program and the generated RTL program. *) + +Lemma symbols_preserved: + forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. +Proof. + intros; unfold ge, tge, tprog, sel_program. + apply Genv.find_symbol_transf. +Qed. + +Lemma functions_translated: + forall (v: val) (f: Cminor.fundef), + Genv.find_funct ge v = Some f -> + Genv.find_funct tge v = Some (sel_fundef f). +Proof. + intros. + exact (Genv.find_funct_transf sel_fundef H). +Qed. + +Lemma function_ptr_translated: + forall (b: block) (f: Cminor.fundef), + Genv.find_funct_ptr ge b = Some f -> + Genv.find_funct_ptr tge b = Some (sel_fundef f). +Proof. + intros. + exact (Genv.find_funct_ptr_transf sel_fundef H). +Qed. + +Lemma sig_function_translated: + forall f, + funsig (sel_fundef f) = Cminor.funsig f. +Proof. + intros. destruct f; reflexivity. +Qed. + +(** This is the main semantic preservation theorem: + instruction selection preserves the semantics of function invocations. + The proof is an induction over the Cminor evaluation derivation. *) + +Lemma sel_function_correct: + forall m fd vargs t m' vres, + Cminor.eval_funcall ge m fd vargs t m' vres -> + CminorSel.eval_funcall tge m (sel_fundef fd) vargs t m' vres. +Proof. + apply (Cminor.eval_funcall_ind4 ge + (fun sp le e m a t m' v => eval_expr tge sp le e m (sel_expr a) t m' v) + (fun sp le e m a t m' v => eval_exprlist tge sp le e m (sel_exprlist a) t m' v) + (fun m fd vargs t m' vres => eval_funcall tge m (sel_fundef fd) vargs t m' vres) + (fun sp e m s t e' m' out => exec_stmt tge sp e m (sel_stmt s) t e' m' out)); + intros; simpl. + (* Evar *) + constructor; auto. + (* Econst *) + destruct cst; simpl; simpl in H; (econstructor; [constructor|simpl;auto]). + rewrite symbols_preserved. auto. + (* Eunop *) + eapply eval_sel_unop; eauto. + (* Ebinop *) + subst t. eapply eval_sel_binop; eauto. + (* Eload *) + eapply eval_load; eauto. + (* Estore *) + subst t. eapply eval_store; eauto. + (* Ecall *) + econstructor; eauto. apply functions_translated; auto. + rewrite <- H4. apply sig_function_translated. + (* Econdition *) + econstructor; eauto. eapply eval_condition_of_expr; eauto. + destruct b1; auto. + (* Elet *) + econstructor; eauto. + (* Eletvar *) + constructor; auto. + (* Ealloc *) + econstructor; eauto. + (* Enil *) + constructor. + (* Econs *) + econstructor; eauto. + (* Internal function *) + econstructor; eauto. + (* External function *) + econstructor; eauto. + (* Sskip *) + constructor. + (* Sexpr *) + econstructor; eauto. + (* Sassign *) + econstructor; eauto. + (* Sifthenelse *) + econstructor; eauto. eapply eval_condition_of_expr; eauto. + destruct b1; auto. + (* Sseq *) + eapply exec_Sseq_continue; eauto. + eapply exec_Sseq_stop; eauto. + (* Sloop *) + eapply exec_Sloop_loop; eauto. + eapply exec_Sloop_stop; eauto. + (* Sblock *) + econstructor; eauto. + (* Sexit *) + constructor. + (* Sswitch *) + econstructor; eauto. + (* Sreturn *) + constructor. + econstructor; eauto. + (* Stailcall *) + econstructor; eauto. apply functions_translated; auto. + rewrite <- H4. apply sig_function_translated. +Qed. + +End PRESERVATION. + +(** As a corollary, instruction selection preserves the observable + behaviour of programs. *) + +Theorem sel_program_correct: + forall prog t r, + Cminor.exec_program prog t r -> + CminorSel.exec_program (sel_program prog) t r. +Proof. + intros. + destruct H as [b [f [m [FINDS [FINDF [SIG EXEC]]]]]]. + exists b; exists (sel_fundef f); exists m. + split. simpl. rewrite <- FINDS. apply symbols_preserved. + split. apply function_ptr_translated. auto. + split. rewrite <- SIG. apply sig_function_translated. + replace (Genv.init_mem (sel_program prog)) with (Genv.init_mem prog). + apply sel_function_correct; auto. + symmetry. unfold sel_program. apply Genv.init_mem_transf. +Qed. diff --git a/backend/Stacking.v b/backend/Stacking.v index de350dc1..c19e293f 100644 --- a/backend/Stacking.v +++ b/backend/Stacking.v @@ -2,13 +2,14 @@ Require Import Coqlib. Require Import Maps. +Require Import Errors. Require Import AST. Require Import Integers. Require Import Op. Require Import RTL. Require Import Locations. Require Import Linear. -Require Import Lineartyping. +Require Import Bounds. Require Import Mach. Require Import Conventions. @@ -87,43 +88,61 @@ Definition offset_of_index (fe: frame_env) (idx: frame_index) := store in the frame the values of callee-save registers used by the current function. *) -Definition save_int_callee_save (fe: frame_env) (cs: mreg) (k: Mach.code) := - let i := index_int_callee_save cs in - if zlt i fe.(fe_num_int_callee_save) - then Msetstack cs (Int.repr (offset_of_index fe (FI_saved_int i))) Tint :: k +Definition save_callee_save_reg + (bound: frame_env -> Z) (number: mreg -> Z) (mkindex: Z -> frame_index) + (ty: typ) (fe: frame_env) (cs: mreg) (k: Mach.code) := + let i := number cs in + if zlt i (bound fe) + then Msetstack cs (Int.repr (offset_of_index fe (mkindex i))) ty :: k else k. -Definition save_float_callee_save (fe: frame_env) (cs: mreg) (k: Mach.code) := - let i := index_float_callee_save cs in - if zlt i fe.(fe_num_float_callee_save) - then Msetstack cs (Int.repr (offset_of_index fe (FI_saved_float i))) Tfloat :: k - else k. +Definition save_callee_save_regs + (bound: frame_env -> Z) (number: mreg -> Z) (mkindex: Z -> frame_index) + (ty: typ) (fe: frame_env) (csl: list mreg) (k: Mach.code) := + List.fold_right (save_callee_save_reg bound number mkindex ty fe) k csl. + +Definition save_callee_save_int (fe: frame_env) := + save_callee_save_regs + fe_num_int_callee_save index_int_callee_save FI_saved_int + Tint fe int_callee_save_regs. + +Definition save_callee_save_float (fe: frame_env) := + save_callee_save_regs + fe_num_float_callee_save index_float_callee_save FI_saved_float + Tfloat fe float_callee_save_regs. Definition save_callee_save (fe: frame_env) (k: Mach.code) := - List.fold_right (save_int_callee_save fe) - (List.fold_right (save_float_callee_save fe) k float_callee_save_regs) - int_callee_save_regs. + save_callee_save_int fe (save_callee_save_float fe k). (** [restore_callee_save fe k] adds before [k] the instructions that re-load from the frame the values of callee-save registers used by the current function, restoring these registers to their initial values. *) -Definition restore_int_callee_save (fe: frame_env) (cs: mreg) (k: Mach.code) := - let i := index_int_callee_save cs in - if zlt i fe.(fe_num_int_callee_save) - then Mgetstack (Int.repr (offset_of_index fe (FI_saved_int i))) Tint cs :: k +Definition restore_callee_save_reg + (bound: frame_env -> Z) (number: mreg -> Z) (mkindex: Z -> frame_index) + (ty: typ) (fe: frame_env) (cs: mreg) (k: Mach.code) := + let i := number cs in + if zlt i (bound fe) + then Mgetstack (Int.repr (offset_of_index fe (mkindex i))) ty cs :: k else k. -Definition restore_float_callee_save (fe: frame_env) (cs: mreg) (k: Mach.code) := - let i := index_float_callee_save cs in - if zlt i fe.(fe_num_float_callee_save) - then Mgetstack (Int.repr (offset_of_index fe (FI_saved_float i))) Tfloat cs :: k - else k. +Definition restore_callee_save_regs + (bound: frame_env -> Z) (number: mreg -> Z) (mkindex: Z -> frame_index) + (ty: typ) (fe: frame_env) (csl: list mreg) (k: Mach.code) := + List.fold_right (restore_callee_save_reg bound number mkindex ty fe) k csl. + +Definition restore_callee_save_int (fe: frame_env) := + restore_callee_save_regs + fe_num_int_callee_save index_int_callee_save FI_saved_int + Tint fe int_callee_save_regs. + +Definition restore_callee_save_float (fe: frame_env) := + restore_callee_save_regs + fe_num_float_callee_save index_float_callee_save FI_saved_float + Tfloat fe float_callee_save_regs. Definition restore_callee_save (fe: frame_env) (k: Mach.code) := - List.fold_right (restore_int_callee_save fe) - (List.fold_right (restore_float_callee_save fe) k float_callee_save_regs) - int_callee_save_regs. + restore_callee_save_int fe (restore_callee_save_float fe k). (** * Code transformation. *) @@ -186,6 +205,8 @@ Definition transl_instr Mstore chunk (transl_addr fe addr) args src :: k | Lcall sig ros => Mcall sig ros :: k + | Ltailcall sig ros => + restore_callee_save fe (Mtailcall sig ros :: k) | Lalloc => Malloc :: k | Llabel lbl => @@ -214,18 +235,23 @@ Definition transl_code Definition transl_body (f: Linear.function) (fe: frame_env) := save_callee_save fe (transl_code fe f.(Linear.fn_code)). -Definition transf_function (f: Linear.function) : option Mach.function := +Open Local Scope string_scope. + +Definition transf_function (f: Linear.function) : res Mach.function := let fe := make_env (function_bounds f) in - if zlt f.(Linear.fn_stacksize) 0 then None else - if zlt (- Int.min_signed) fe.(fe_size) then None else - Some (Mach.mkfunction + if zlt f.(Linear.fn_stacksize) 0 then + Error (msg "Stacking.transf_function") + else if zlt (- Int.min_signed) fe.(fe_size) then + Error (msg "Too many spilled variables, stack size exceeded") + else + OK (Mach.mkfunction f.(Linear.fn_sig) (transl_body f fe) f.(Linear.fn_stacksize) fe.(fe_size)). -Definition transf_fundef (f: Linear.fundef) : option Mach.fundef := +Definition transf_fundef (f: Linear.fundef) : res Mach.fundef := AST.transf_partial_fundef transf_function f. -Definition transf_program (p: Linear.program) : option Mach.program := +Definition transf_program (p: Linear.program) : res Mach.program := transform_partial_program transf_fundef p. diff --git a/backend/Stackingproof.v b/backend/Stackingproof.v index 3bc4339b..905570ef 100644 --- a/backend/Stackingproof.v +++ b/backend/Stackingproof.v @@ -1,15 +1,16 @@ (** Correctness proof for the translation from Linear to Mach. *) (** This file proves semantic preservation for the [Stacking] pass. - For the target language Mach, we use the alternate semantics + For the target language Mach, we use the abstract semantics given in file [Machabstr], where a part of the activation record is not resident in memory. Combined with the semantic equivalence - result between the two Mach semantics (see file [Machabstr2mach]), + result between the two Mach semantics (see file [Machabstr2concr]), the proof in this file also shows semantic preservation with - respect to the standard Mach semantics. *) + respect to the concrete Mach semantics. *) Require Import Coqlib. Require Import Maps. +Require Import Errors. Require Import AST. Require Import Integers. Require Import Values. @@ -17,11 +18,13 @@ Require Import Op. Require Import Mem. Require Import Events. Require Import Globalenvs. +Require Import Smallstep. Require Import Locations. -Require Import Mach. -Require Import Machabstr. Require Import Linear. Require Import Lineartyping. +Require Import Mach. +Require Import Machabstr. +Require Import Bounds. Require Import Conventions. Require Import Stacking. @@ -29,25 +32,28 @@ Require Import Stacking. (** ``Good variable'' properties for frame accesses. *) +Lemma typesize_typesize: + forall ty, AST.typesize ty = 4 * Locations.typesize ty. +Proof. + destruct ty; auto. +Qed. + Lemma get_slot_ok: forall fr ty ofs, - 0 <= ofs -> fr.(low) + ofs + 4 * typesize ty <= 0 -> + 24 <= ofs -> fr.(fr_low) + ofs + 4 * typesize ty <= 0 -> exists v, get_slot fr ty ofs v. Proof. - intros. exists (load_contents (mem_type ty) fr.(contents) (fr.(low) + ofs)). - constructor; auto. + intros. rewrite <- typesize_typesize in H0. + exists (fr.(fr_contents) ty (fr.(fr_low) + ofs)). constructor; auto. Qed. Lemma set_slot_ok: forall fr ty ofs v, - fr.(high) = 0 -> 0 <= ofs -> fr.(low) + ofs + 4 * typesize ty <= 0 -> + 24 <= ofs -> fr.(fr_low) + ofs + 4 * typesize ty <= 0 -> exists fr', set_slot fr ty ofs v fr'. Proof. - intros. - exists (mkblock fr.(low) fr.(high) - (store_contents (mem_type ty) fr.(contents) (fr.(low) + ofs) v) - (set_slot_undef_outside fr ty ofs v H H0 H1 fr.(undef_outside))). - constructor; auto. + intros. rewrite <- typesize_typesize in H0. + econstructor. constructor; eauto. Qed. Lemma slot_gss: @@ -55,10 +61,45 @@ Lemma slot_gss: set_slot fr1 ty ofs v fr2 -> get_slot fr2 ty ofs v. Proof. - intros. induction H. - constructor. - auto. simpl. auto. - simpl. symmetry. apply load_store_contents_same. + intros. inv H. constructor; auto. + simpl. destruct (typ_eq ty ty); try congruence. + rewrite zeq_true. auto. +Qed. + +Remark frame_update_gso: + forall fr ty ofs v ty' ofs', + ofs' + 4 * typesize ty' <= ofs \/ ofs + 4 * typesize ty <= ofs' -> + fr_contents (update ty ofs v fr) ty' ofs' = fr_contents fr ty' ofs'. +Proof. + intros. + generalize (typesize_pos ty); intro. + generalize (typesize_pos ty'); intro. + simpl. rewrite zeq_false. 2: omega. + repeat rewrite <- typesize_typesize in H. + destruct (zle (ofs' + AST.typesize ty') ofs). auto. + destruct (zle (ofs + AST.typesize ty) ofs'). auto. + omegaContradiction. +Qed. + +Remark frame_update_overlap: + forall fr ty ofs v ty' ofs', + ofs <> ofs' -> + ofs' + 4 * typesize ty' > ofs -> ofs + 4 * typesize ty > ofs' -> + fr_contents (update ty ofs v fr) ty' ofs' = Vundef. +Proof. + intros. simpl. rewrite zeq_false; auto. + rewrite <- typesize_typesize in H0. + rewrite <- typesize_typesize in H1. + repeat rewrite zle_false; auto. +Qed. + +Remark frame_update_mismatch: + forall fr ty ofs v ty', + ty <> ty' -> + fr_contents (update ty ofs v fr) ty' ofs = Vundef. +Proof. + intros. simpl. rewrite zeq_true. + destruct (typ_eq ty ty'); congruence. Qed. Lemma slot_gso: @@ -68,38 +109,36 @@ Lemma slot_gso: ofs' + 4 * typesize ty' <= ofs \/ ofs + 4 * typesize ty <= ofs' -> get_slot fr2 ty' ofs' v'. Proof. - intros. induction H; inversion H0. - constructor. - auto. simpl low. auto. - simpl. rewrite H3. symmetry. apply load_store_contents_other. - repeat (rewrite size_mem_type). omega. + intros. inv H. inv H0. + constructor; auto. + symmetry. simpl fr_low. apply frame_update_gso. omega. Qed. Lemma slot_gi: forall f ofs ty, - 0 <= ofs -> (init_frame f).(low) + ofs + 4 * typesize ty <= 0 -> + 24 <= ofs -> fr_low (init_frame f) + ofs + 4 * typesize ty <= 0 -> get_slot (init_frame f) ty ofs Vundef. Proof. - intros. constructor. - auto. auto. - symmetry. apply load_contents_init. + intros. rewrite <- typesize_typesize in H0. constructor; auto. Qed. Section PRESERVATION. Variable prog: Linear.program. Variable tprog: Mach.program. -Hypothesis TRANSF: transf_program prog = Some tprog. +Hypothesis TRANSF: transf_program prog = OK tprog. Let ge := Genv.globalenv prog. Let tge := Genv.globalenv tprog. + Section FRAME_PROPERTIES. +Variable stack: list Machabstr.stackframe. Variable f: Linear.function. Let b := function_bounds f. Let fe := make_env b. Variable tf: Mach.function. -Hypothesis TRANSF_F: transf_function f = Some tf. +Hypothesis TRANSF_F: transf_function f = OK tf. Lemma unfold_transf_function: tf = Mach.mkfunction @@ -109,7 +148,7 @@ Lemma unfold_transf_function: fe.(fe_size). Proof. generalize TRANSF_F. unfold transf_function. - case (zlt (fn_stacksize f) 0). intros; discriminate. + case (zlt (Linear.fn_stacksize f) 0). intros; discriminate. case (zlt (- Int.min_signed) (fe_size (make_env (function_bounds f)))). intros; discriminate. intros. unfold fe. unfold b. congruence. @@ -118,7 +157,7 @@ Qed. Lemma size_no_overflow: fe.(fe_size) <= -Int.min_signed. Proof. generalize TRANSF_F. unfold transf_function. - case (zlt (fn_stacksize f) 0). intros; discriminate. + case (zlt (Linear.fn_stacksize f) 0). intros; discriminate. case (zlt (- Int.min_signed) (fe_size (make_env (function_bounds f)))). intros; discriminate. intros. unfold fe, b. omega. @@ -131,7 +170,7 @@ Definition index_valid (idx: frame_index) := match idx with | FI_local x Tint => 0 <= x < b.(bound_int_local) | FI_local x Tfloat => 0 <= x < b.(bound_float_local) - | FI_arg x ty => 6 <= x /\ x + typesize ty <= b.(bound_outgoing) + | FI_arg x ty => 14 <= x /\ x + typesize ty <= b.(bound_outgoing) | FI_saved_int x => 0 <= x < b.(bound_int_callee_save) | FI_saved_float x => 0 <= x < b.(bound_float_callee_save) end. @@ -166,17 +205,12 @@ Proof. Qed. Ltac AddPosProps := - assert (bound_int_local b >= 0); - [unfold b; apply bound_int_local_pos | - assert (bound_float_local b >= 0); - [unfold b; apply bound_float_local_pos | - assert (bound_int_callee_save b >= 0); - [unfold b; apply bound_int_callee_save_pos | - assert (bound_float_callee_save b >= 0); - [unfold b; apply bound_float_callee_save_pos | - assert (bound_outgoing b >= 6); - [unfold b; apply bound_outgoing_pos | - generalize align_float_part; intro]]]]]. + generalize (bound_int_local_pos b); intro; + generalize (bound_float_local_pos b); intro; + generalize (bound_int_callee_save_pos b); intro; + generalize (bound_float_callee_save_pos b); intro; + generalize (bound_outgoing_pos b); intro; + generalize align_float_part; intro. Lemma size_pos: fe.(fe_size) >= 24. Proof. @@ -212,18 +246,18 @@ Qed. Lemma index_local_valid: forall ofs ty, - slot_bounded f (Local ofs ty) -> + slot_within_bounds f b (Local ofs ty) -> index_valid (FI_local ofs ty). Proof. - unfold slot_bounded, index_valid. auto. + unfold slot_within_bounds, index_valid. auto. Qed. Lemma index_arg_valid: forall ofs ty, - slot_bounded f (Outgoing ofs ty) -> + slot_within_bounds f b (Outgoing ofs ty) -> index_valid (FI_arg ofs ty). Proof. - unfold slot_bounded, index_valid, b. auto. + unfold slot_within_bounds, index_valid. auto. Qed. Lemma index_saved_int_valid: @@ -280,10 +314,8 @@ Lemma offset_of_index_no_overflow: Proof. intros. generalize (offset_of_index_valid idx H). intros [A B]. -(* omega falls flat on its face... *) apply Int.signed_repr. - split. apply Zle_trans with 24. compute; intro; discriminate. - auto. + split. apply Zle_trans with 24; auto. compute; intro; discriminate. assert (offset_of_index fe idx < fe_size fe). generalize (typesize_pos (type_of_index idx)); intro. omega. apply Zlt_succ_le. @@ -295,26 +327,30 @@ Qed. instructions, in case the offset is computed with [offset_of_index]. *) Lemma exec_Mgetstack': - forall sp parent idx ty c rs fr dst m v, + forall sp idx ty c rs fr dst m v, index_valid idx -> get_slot fr ty (offset_of_index fe idx) v -> - Machabstr.exec_instrs tge tf sp parent - (Mgetstack (Int.repr (offset_of_index fe idx)) ty dst :: c) rs fr m - E0 c (rs#dst <- v) fr m. + step tge + (State stack tf sp + (Mgetstack (Int.repr (offset_of_index fe idx)) ty dst :: c) + rs fr m) + E0 (State stack tf sp c (rs#dst <- v) fr m). Proof. - intros. apply Machabstr.exec_one. apply Machabstr.exec_Mgetstack. + intros. apply exec_Mgetstack. rewrite offset_of_index_no_overflow. auto. auto. Qed. Lemma exec_Msetstack': - forall sp parent idx ty c rs fr src m fr', + forall sp idx ty c rs fr src m fr', index_valid idx -> set_slot fr ty (offset_of_index fe idx) (rs src) fr' -> - Machabstr.exec_instrs tge tf sp parent - (Msetstack src (Int.repr (offset_of_index fe idx)) ty :: c) rs fr m - E0 c rs fr' m. + step tge + (State stack tf sp + (Msetstack src (Int.repr (offset_of_index fe idx)) ty :: c) + rs fr m) + E0 (State stack tf sp c rs fr' m). Proof. - intros. apply Machabstr.exec_one. apply Machabstr.exec_Msetstack. + intros. apply exec_Msetstack. rewrite offset_of_index_no_overflow. auto. auto. Qed. @@ -323,44 +359,42 @@ Qed. function. *) Definition index_val (idx: frame_index) (fr: frame) := - load_contents (mem_type (type_of_index idx)) - fr.(contents) - (fr.(low) + offset_of_index fe idx). + fr.(fr_contents) (type_of_index idx) (fr.(fr_low) + offset_of_index fe idx). Lemma get_slot_index: forall fr idx ty v, index_valid idx -> - fr.(low) = - fe.(fe_size) -> + fr.(fr_low) = -fe.(fe_size) -> ty = type_of_index idx -> v = index_val idx fr -> get_slot fr ty (offset_of_index fe idx) v. Proof. intros. subst v; subst ty. generalize (offset_of_index_valid idx H); intros [A B]. - unfold index_val. apply get_slot_intro. omega. - rewrite H0. omega. auto. + rewrite <- typesize_typesize in B. + unfold index_val. apply get_slot_intro; auto. + rewrite H0. omega. Qed. Lemma set_slot_index: forall fr idx v, index_valid idx -> - fr.(high) = 0 -> - fr.(low) = - fe.(fe_size) -> + fr.(fr_low) = -fe.(fe_size) -> exists fr', set_slot fr (type_of_index idx) (offset_of_index fe idx) v fr'. Proof. intros. generalize (offset_of_index_valid idx H); intros [A B]. - apply set_slot_ok. auto. omega. rewrite H1; omega. + apply set_slot_ok; auto. rewrite H0. omega. Qed. (** Alternate ``good variable'' properties for [get_slot] and [set_slot]. *) + Lemma slot_iss: forall fr idx v fr', set_slot fr (type_of_index idx) (offset_of_index fe idx) v fr' -> index_val idx fr' = v. Proof. - intros. inversion H. subst ofs ty. - unfold index_val; simpl. apply load_store_contents_same. + intros. exploit slot_gss; eauto. intro. inv H0. auto. Qed. Lemma slot_iso: @@ -371,19 +405,20 @@ Lemma slot_iso: index_val idx' fr' = index_val idx' fr. Proof. intros. generalize (offset_of_index_disj idx idx' H1 H2 H0). intro. - unfold index_val. inversion H. subst ofs ty. simpl. - apply load_store_contents_other. - repeat rewrite size_mem_type. omega. + inv H. unfold index_val. simpl fr_low. apply frame_update_gso. + omega. Qed. (** * Agreement between location sets and Mach environments *) -(** The following [agree] predicate expresses semantic agreement between - a location set on the Linear side and, on the Mach side, - a register set, plus the current and parent frames, plus the register - set [rs0] at function entry. *) +(** The following [agree] predicate expresses semantic agreement between: +- on the Linear side, the current location set [ls] and the location + set at function entry [ls0]; +- on the Mach side, a register set [rs] plus the current and parent frames + [fr] and [parent]. +*) -Record agree (ls: locset) (rs: regset) (fr parent: frame) (rs0: regset) : Prop := +Record agree (ls: locset) (rs: regset) (fr parent: frame) (ls0: locset) : Prop := mk_agree { (** Machine registers have the same values on the Linear and Mach sides. *) agree_reg: @@ -393,25 +428,22 @@ Record agree (ls: locset) (rs: regset) (fr parent: frame) (rs0: regset) : Prop : have the same values they had at function entry. In other terms, these registers are never assigned. *) agree_unused_reg: - forall r, ~(mreg_bounded f r) -> rs r = rs0 r; + forall r, ~(mreg_within_bounds b r) -> rs r = ls0 (R r); - (** The bounds of the current frame are [[- fe.(fe_size), 0]]. *) - agree_high: - fr.(high) = 0; + (** The low bound of the current frame is [- fe.(fe_size)]. *) agree_size: - fr.(low) = - fe.(fe_size); + fr.(fr_low) = -fe.(fe_size); (** Local and outgoing stack slots (on the Linear side) have the same values as the one loaded from the current Mach frame at the corresponding offsets. *) - agree_locals: forall ofs ty, - slot_bounded f (Local ofs ty) -> + slot_within_bounds f b (Local ofs ty) -> ls (S (Local ofs ty)) = index_val (FI_local ofs ty) fr; agree_outgoing: forall ofs ty, - slot_bounded f (Outgoing ofs ty) -> + slot_within_bounds f b (Outgoing ofs ty) -> ls (S (Outgoing ofs ty)) = index_val (FI_arg ofs ty) fr; (** Incoming stack slots (on the Linear side) have @@ -419,7 +451,7 @@ Record agree (ls: locset) (rs: regset) (fr parent: frame) (rs0: regset) : Prop : at the corresponding offsets. *) agree_incoming: forall ofs ty, - slot_bounded f (Incoming ofs ty) -> + slot_within_bounds f b (Incoming ofs ty) -> get_slot parent ty (Int.signed (Int.repr (4 * ofs))) (ls (S (Incoming ofs ty))); (** The areas of the frame reserved for saving used callee-save @@ -429,35 +461,33 @@ Record agree (ls: locset) (rs: regset) (fr parent: frame) (rs0: regset) : Prop : forall r, In r int_callee_save_regs -> index_int_callee_save r < b.(bound_int_callee_save) -> - index_val (FI_saved_int (index_int_callee_save r)) fr = rs0 r; + index_val (FI_saved_int (index_int_callee_save r)) fr = ls0 (R r); agree_saved_float: forall r, In r float_callee_save_regs -> index_float_callee_save r < b.(bound_float_callee_save) -> - index_val (FI_saved_float (index_float_callee_save r)) fr = rs0 r + index_val (FI_saved_float (index_float_callee_save r)) fr = ls0 (R r) }. -Hint Resolve agree_reg agree_unused_reg agree_size agree_high +Hint Resolve agree_reg agree_unused_reg agree_size agree_locals agree_outgoing agree_incoming agree_saved_int agree_saved_float: stacking. (** Values of registers and register lists. *) Lemma agree_eval_reg: - forall ls rs fr parent rs0 r, - agree ls rs fr parent rs0 -> rs r = ls (R r). + forall ls rs fr parent ls0 r, + agree ls rs fr parent ls0 -> rs r = ls (R r). Proof. intros. symmetry. eauto with stacking. Qed. Lemma agree_eval_regs: - forall ls rs fr parent rs0 rl, - agree ls rs fr parent rs0 -> rs##rl = LTL.reglist rl ls. + forall ls rs fr parent ls0 rl, + agree ls rs fr parent ls0 -> rs##rl = reglist ls rl. Proof. induction rl; simpl; intros. - auto. apply (f_equal2 (@cons val)). - eapply agree_eval_reg; eauto. - auto. + auto. f_equal. eapply agree_eval_reg; eauto. auto. Qed. Hint Resolve agree_eval_reg agree_eval_regs: stacking. @@ -466,10 +496,10 @@ Hint Resolve agree_eval_reg agree_eval_regs: stacking. of machine registers, of local slots, of outgoing slots. *) Lemma agree_set_reg: - forall ls rs fr parent rs0 r v, - agree ls rs fr parent rs0 -> - mreg_bounded f r -> - agree (Locmap.set (R r) v ls) (Regmap.set r v rs) fr parent rs0. + forall ls rs fr parent ls0 r v, + agree ls rs fr parent ls0 -> + mreg_within_bounds b r -> + agree (Locmap.set (R r) v ls) (Regmap.set r v rs) fr parent ls0. Proof. intros. constructor; eauto with stacking. intros. case (mreg_eq r r0); intro. @@ -484,25 +514,22 @@ Proof. Qed. Lemma agree_set_local: - forall ls rs fr parent rs0 v ofs ty, - agree ls rs fr parent rs0 -> - slot_bounded f (Local ofs ty) -> + forall ls rs fr parent ls0 v ofs ty, + agree ls rs fr parent ls0 -> + slot_within_bounds f b (Local ofs ty) -> exists fr', set_slot fr ty (offset_of_index fe (FI_local ofs ty)) v fr' /\ - agree (Locmap.set (S (Local ofs ty)) v ls) rs fr' parent rs0. + agree (Locmap.set (S (Local ofs ty)) v ls) rs fr' parent ls0. Proof. intros. generalize (set_slot_index fr _ v (index_local_valid _ _ H0) - (agree_high _ _ _ _ _ H) (agree_size _ _ _ _ _ H)). intros [fr' SET]. exists fr'. split. auto. constructor; eauto with stacking. (* agree_reg *) intros. rewrite Locmap.gso. eauto with stacking. red; auto. - (* agree_high *) - inversion SET. simpl high. eauto with stacking. (* agree_size *) - inversion SET. simpl low. eauto with stacking. + inversion SET. rewrite H3; simpl fr_low. eauto with stacking. (* agree_local *) intros. case (slot_eq (Local ofs ty) (Local ofs0 ty0)); intro. rewrite <- e. rewrite Locmap.gss. @@ -517,7 +544,7 @@ Proof. (* agree_outgoing *) intros. rewrite Locmap.gso. transitivity (index_val (FI_arg ofs0 ty0) fr). eauto with stacking. symmetry. eapply slot_iso; eauto. - red; auto. red; auto. + red; auto. red; auto. (* agree_incoming *) intros. rewrite Locmap.gso. eauto with stacking. red. auto. (* agree_saved_int *) @@ -529,30 +556,27 @@ Proof. Qed. Lemma agree_set_outgoing: - forall ls rs fr parent rs0 v ofs ty, - agree ls rs fr parent rs0 -> - slot_bounded f (Outgoing ofs ty) -> + forall ls rs fr parent ls0 v ofs ty, + agree ls rs fr parent ls0 -> + slot_within_bounds f b (Outgoing ofs ty) -> exists fr', set_slot fr ty (offset_of_index fe (FI_arg ofs ty)) v fr' /\ - agree (Locmap.set (S (Outgoing ofs ty)) v ls) rs fr' parent rs0. + agree (Locmap.set (S (Outgoing ofs ty)) v ls) rs fr' parent ls0. Proof. intros. generalize (set_slot_index fr _ v (index_arg_valid _ _ H0) - (agree_high _ _ _ _ _ H) (agree_size _ _ _ _ _ H)). intros [fr' SET]. exists fr'. split. exact SET. constructor; eauto with stacking. (* agree_reg *) intros. rewrite Locmap.gso. eauto with stacking. red; auto. - (* agree_high *) - inversion SET. simpl high. eauto with stacking. (* agree_size *) - inversion SET. simpl low. eauto with stacking. + inversion SET. subst fr'; simpl fr_low. eauto with stacking. (* agree_local *) intros. rewrite Locmap.gso. transitivity (index_val (FI_local ofs0 ty0) fr). eauto with stacking. symmetry. eapply slot_iso; eauto. - red; auto. red; auto. + red; auto. red; auto. (* agree_outgoing *) intros. unfold Locmap.set. case (Loc.eq (S (Outgoing ofs ty)) (S (Outgoing ofs0 ty0))); intro. @@ -562,18 +586,12 @@ Proof. congruence. congruence. (* overlapping locations *) caseEq (Loc.overlap (S (Outgoing ofs ty)) (S (Outgoing ofs0 ty0))); intros. - inversion SET. subst ofs1 ty1. - unfold index_val, type_of_index, offset_of_index. - set (ofs4 := 4 * ofs). set (ofs04 := 4 * ofs0). simpl. - unfold ofs4, ofs04. symmetry. - case (zeq ofs ofs0); intro. - subst ofs0. apply load_store_contents_mismatch. + inv SET. unfold index_val, type_of_index, offset_of_index. + destruct (zeq ofs ofs0). + subst ofs0. symmetry. apply frame_update_mismatch. destruct ty; destruct ty0; simpl; congruence. - generalize (Loc.overlap_not_diff _ _ H2). intro. simpl in H4. - apply load_store_contents_overlap. - omega. - rewrite size_mem_type. omega. - rewrite size_mem_type. omega. + generalize (Loc.overlap_not_diff _ _ H2). intro. simpl in H5. + simpl fr_low. symmetry. apply frame_update_overlap. omega. omega. omega. (* different locations *) transitivity (index_val (FI_arg ofs0 ty0) fr). eauto with stacking. @@ -588,17 +606,17 @@ Proof. intros. rewrite <- (agree_saved_float _ _ _ _ _ H r H1 H2). eapply slot_iso; eauto with stacking. red; auto. Qed. - +(* Lemma agree_return_regs: - forall ls rs fr parent rs0 ls' rs', - agree ls rs fr parent rs0 -> + forall ls rs fr parent ls0 ls' rs', + agree ls rs fr parent ls0 -> (forall r, In (R r) temporaries \/ In (R r) destroyed_at_call -> rs' r = ls' (R r)) -> (forall r, In r int_callee_save_regs \/ In r float_callee_save_regs -> rs' r = rs r) -> - agree (LTL.return_regs ls ls') rs' fr parent rs0. + agree (LTL.return_regs ls ls') rs' fr parent ls0. Proof. intros. constructor; unfold LTL.return_regs; eauto with stacking. (* agree_reg *) @@ -610,12 +628,117 @@ Proof. generalize (register_classification r); tauto. (* agree_unused_reg *) intros. rewrite H1. eauto with stacking. - generalize H2; unfold mreg_bounded; case (mreg_type r); intro. + generalize H2; unfold mreg_within_bounds; case (mreg_type r); intro. left. apply index_int_callee_save_pos2. - generalize (bound_int_callee_save_pos f); intro. omega. + generalize (bound_int_callee_save_pos b); intro. omega. right. apply index_float_callee_save_pos2. - generalize (bound_float_callee_save_pos f); intro. omega. + generalize (bound_float_callee_save_pos b); intro. omega. Qed. +*) + +Lemma agree_return_regs: + forall ls rs fr parent ls0 rs', + agree ls rs fr parent ls0 -> + (forall r, + ~In r int_callee_save_regs -> ~In r float_callee_save_regs -> + rs' r = rs r) -> + (forall r, + In r int_callee_save_regs \/ In r float_callee_save_regs -> + rs' r = ls0 (R r)) -> + (forall r, LTL.return_regs ls0 ls (R r) = rs' r). +Proof. + intros; unfold LTL.return_regs. + case (In_dec Loc.eq (R r) temporaries); intro. + rewrite H0. eapply agree_reg; eauto. + apply int_callee_save_not_destroyed; auto. + apply float_callee_save_not_destroyed; auto. + case (In_dec Loc.eq (R r) destroyed_at_call); intro. + rewrite H0. eapply agree_reg; eauto. + apply int_callee_save_not_destroyed; auto. + apply float_callee_save_not_destroyed; auto. + symmetry; apply H1. + generalize (register_classification r); tauto. +Qed. + +(** Agreement over callee-save registers and stack locations *) + +Definition agree_callee_save (ls1 ls2: locset) : Prop := + forall l, + match l with + | R r => In r int_callee_save_regs \/ In r float_callee_save_regs + | S s => True + end -> + ls2 l = ls1 l. + +Remark mreg_not_within_bounds: + forall r, + ~mreg_within_bounds b r -> In r int_callee_save_regs \/ In r float_callee_save_regs. +Proof. + intro r; unfold mreg_within_bounds. + destruct (mreg_type r); intro. + left. apply index_int_callee_save_pos2. + generalize (bound_int_callee_save_pos b). omega. + right. apply index_float_callee_save_pos2. + generalize (bound_float_callee_save_pos b). omega. +Qed. + +Lemma agree_callee_save_agree: + forall ls rs fr parent ls1 ls2, + agree ls rs fr parent ls1 -> + agree_callee_save ls1 ls2 -> + agree ls rs fr parent ls2. +Proof. + intros. inv H. constructor; auto. + intros. rewrite agree_unused_reg0; auto. + symmetry. apply H0. apply mreg_not_within_bounds; auto. + intros. rewrite (H0 (R r)); auto. + intros. rewrite (H0 (R r)); auto. +Qed. + +Lemma agree_callee_save_return_regs: + forall ls1 ls2, + agree_callee_save (LTL.return_regs ls1 ls2) ls1. +Proof. + intros; red; intros. + unfold LTL.return_regs. destruct l; auto. + generalize (int_callee_save_not_destroyed m); intro. + generalize (float_callee_save_not_destroyed m); intro. + destruct (In_dec Loc.eq (R m) temporaries). tauto. + destruct (In_dec Loc.eq (R m) destroyed_at_call). tauto. + auto. +Qed. + +Lemma agree_callee_save_set_result: + forall ls1 ls2 v sg, + agree_callee_save ls1 ls2 -> + agree_callee_save (Locmap.set (R (Conventions.loc_result sg)) v ls1) ls2. +Proof. + intros; red; intros. rewrite H; auto. + symmetry; apply Locmap.gso. destruct l; simpl; auto. + red; intro. subst m. elim (loc_result_not_callee_save _ H0). +Qed. + +(** A variant of [agree] used for return frames. *) + +Definition agree_frame (ls: locset) (fr parent: frame) (ls0: locset) : Prop := + exists rs, agree ls rs fr parent ls0. + +Lemma agree_frame_agree: + forall ls1 ls2 rs fr parent ls0, + agree_frame ls1 fr parent ls0 -> + agree_callee_save ls2 ls1 -> + (forall r, rs r = ls2 (R r)) -> + agree ls2 rs fr parent ls0. +Proof. + intros. destruct H as [rs' AG]. inv AG. + constructor; auto. + intros. rewrite <- agree_unused_reg0; auto. + rewrite <- agree_reg0. rewrite H1. symmetry; apply H0. + apply mreg_not_within_bounds; auto. + intros. rewrite <- H0; auto. + intros. rewrite <- H0; auto. + intros. rewrite <- H0; auto. +Qed. (** * Correctness of saving and restoring of callee-save registers *) @@ -624,87 +747,100 @@ Qed. the register save areas of the current frame do contain the values of the callee-save registers used by the function. *) -Lemma save_int_callee_save_correct_rec: - forall l k sp parent rs fr m, - incl l int_callee_save_regs -> +Section SAVE_CALLEE_SAVE. + +Variable bound: frame_env -> Z. +Variable number: mreg -> Z. +Variable mkindex: Z -> frame_index. +Variable ty: typ. +Variable sp: val. +Variable csregs: list mreg. +Hypothesis number_inj: + forall r1 r2, In r1 csregs -> In r2 csregs -> r1 <> r2 -> number r1 <> number r2. +Hypothesis mkindex_valid: + forall r, In r csregs -> number r < bound fe -> index_valid (mkindex (number r)). +Hypothesis mkindex_typ: + forall z, type_of_index (mkindex z) = ty. +Hypothesis mkindex_inj: + forall z1 z2, z1 <> z2 -> mkindex z1 <> mkindex z2. +Hypothesis mkindex_diff: + forall r idx, + idx <> mkindex (number r) -> index_diff (mkindex (number r)) idx. + +Lemma save_callee_save_regs_correct: + forall l k rs fr m, + incl l csregs -> list_norepet l -> - fr.(high) = 0 -> - fr.(low) = -fe.(fe_size) -> + fr.(fr_low) = -fe.(fe_size) -> exists fr', - Machabstr.exec_instrs tge tf sp parent - (List.fold_right (save_int_callee_save fe) k l) rs fr m - E0 k rs fr' m - /\ fr'.(high) = 0 - /\ fr'.(low) = -fe.(fe_size) + star step tge + (State stack tf sp + (save_callee_save_regs bound number mkindex ty fe l k) rs fr m) + E0 (State stack tf sp k rs fr' m) + /\ fr'.(fr_low) = - fe.(fe_size) /\ (forall r, - In r l -> index_int_callee_save r < bound_int_callee_save b -> - index_val (FI_saved_int (index_int_callee_save r)) fr' = rs r) + In r l -> number r < bound fe -> + index_val (mkindex (number r)) fr' = rs r) /\ (forall idx, index_valid idx -> (forall r, - In r l -> index_int_callee_save r < bound_int_callee_save b -> - idx <> FI_saved_int (index_int_callee_save r)) -> + In r l -> number r < bound fe -> idx <> mkindex (number r)) -> index_val idx fr' = index_val idx fr). Proof. - induction l. + induction l; intros; simpl save_callee_save_regs. (* base case *) - intros. simpl fold_right. exists fr. - split. apply Machabstr.exec_refl. split. auto. split. auto. - split. intros. elim H3. auto. + exists fr. split. apply star_refl. split. auto. + split. intros. elim H2. auto. (* inductive case *) - intros. simpl fold_right. - set (k1 := fold_right (save_int_callee_save fe) k l) in *. - assert (R1: incl l int_callee_save_regs). eauto with coqlib. + set (k1 := save_callee_save_regs bound number mkindex ty fe l k). + assert (R1: incl l csregs). eauto with coqlib. assert (R2: list_norepet l). inversion H0; auto. - unfold save_int_callee_save. - case (zlt (index_int_callee_save a) (fe_num_int_callee_save fe)); - intro; - unfold fe_num_int_callee_save, fe, make_env in z. + unfold save_callee_save_reg. + destruct (zlt (number a) (bound fe)). (* a store takes place *) - assert (IDX: index_valid (FI_saved_int (index_int_callee_save a))). - apply index_saved_int_valid. eauto with coqlib. auto. - generalize (set_slot_index _ _ (rs a) IDX H1 H2). + assert (VALID: index_valid (mkindex (number a))). + apply mkindex_valid. auto with coqlib. auto. + exploit set_slot_index; eauto. intros [fr1 SET]. - assert (R3: high fr1 = 0). inversion SET. simpl high. auto. - assert (R4: low fr1 = -fe_size fe). inversion SET. simpl low. auto. - generalize (IHl k sp parent rs fr1 m R1 R2 R3 R4). - intros [fr' [A [B [C [D E]]]]]. - exists fr'. - split. eapply Machabstr.exec_trans. apply exec_Msetstack'; eauto with stacking. + exploit (IHl k rs fr1 m); auto. inv SET; auto. + fold k1. intros [fr' [A [B [C D]]]]. + exists fr'. + split. eapply star_left. + apply exec_Msetstack'; eauto with stacking. rewrite <- (mkindex_typ (number a)). eauto. eexact A. traceEq. - split. auto. - split. auto. - split. intros. elim H3; intros. subst r. - rewrite E. eapply slot_iss; eauto. auto. - intros. decEq. apply index_int_callee_save_inj; auto with coqlib. + split. auto. + split. intros. elim H2; intros. subst r. + rewrite D. eapply slot_iss; eauto. + apply mkindex_valid; auto. + intros. apply mkindex_inj. apply number_inj; auto with coqlib. inversion H0. red; intro; subst r; contradiction. - apply D; auto. + apply C; auto. intros. transitivity (index_val idx fr1). - apply E; auto. - intros. apply H4; eauto with coqlib. - eapply slot_iso; eauto. - destruct idx; simpl; auto. - generalize (H4 a (in_eq _ _) z). congruence. - (* no store takes place *) - generalize (IHl k sp parent rs fr m R1 R2 H1 H2). - intros [fr' [A [B [C [D E]]]]]. - exists fr'. split. exact A. split. exact B. split. exact C. - split. intros. elim H3; intros. subst r. omegaContradiction. apply D; auto. - intros. apply E; auto. - intros. apply H4; auto with coqlib. -Qed. + intros. apply H3; eauto with coqlib. + eapply slot_iso; eauto. + apply mkindex_diff. apply H3. auto with coqlib. + auto. + (* no store takes place *) + exploit (IHl k rs fr m); auto. intros [fr' [A [B [C D]]]]. + exists fr'. split. exact A. split. exact B. + split. intros. elim H2; intros. subst r. omegaContradiction. + apply C; auto. + intros. apply D; auto. + intros. apply H3; auto with coqlib. +Qed. -Lemma save_int_callee_save_correct: - forall k sp parent rs fr m, - fr.(high) = 0 -> - fr.(low) = -fe.(fe_size) -> +End SAVE_CALLEE_SAVE. + +Lemma save_callee_save_int_correct: + forall k sp rs fr m, + fr.(fr_low) = - fe.(fe_size) -> exists fr', - Machabstr.exec_instrs tge tf sp parent - (List.fold_right (save_int_callee_save fe) k int_callee_save_regs) rs fr m - E0 k rs fr' m - /\ fr'.(high) = 0 - /\ fr'.(low) = -fe.(fe_size) + star step tge + (State stack tf sp + (save_callee_save_int fe k) rs fr m) + E0 (State stack tf sp k rs fr' m) + /\ fr'.(fr_low) = - fe.(fe_size) /\ (forall r, In r int_callee_save_regs -> index_int_callee_save r < bound_int_callee_save b -> @@ -714,98 +850,30 @@ Lemma save_int_callee_save_correct: match idx with FI_saved_int _ => False | _ => True end -> index_val idx fr' = index_val idx fr). Proof. - intros. - generalize (save_int_callee_save_correct_rec - int_callee_save_regs k sp parent rs fr m - (incl_refl _) int_callee_save_norepet H H0). - intros [fr' [A [B [C [D E]]]]]. - exists fr'. - split. assumption. split. assumption. split. assumption. - split. apply D. intros. apply E. auto. - intros. red; intros; subst idx. contradiction. + intros. + exploit (save_callee_save_regs_correct fe_num_int_callee_save index_int_callee_save FI_saved_int + Tint sp int_callee_save_regs). + exact index_int_callee_save_inj. + intros. red. split; auto. generalize (index_int_callee_save_pos r H0). omega. + auto. + intros; congruence. + intros until idx. destruct idx; simpl; auto. congruence. + apply incl_refl. + apply int_callee_save_norepet. eauto. + intros [fr' [A [B [C D]]]]. + exists fr'; intuition. unfold save_callee_save_int; eauto. + apply D. auto. intros; subst idx. auto. Qed. -Lemma save_float_callee_save_correct_rec: - forall l k sp parent rs fr m, - incl l float_callee_save_regs -> - list_norepet l -> - fr.(high) = 0 -> - fr.(low) = -fe.(fe_size) -> - exists fr', - Machabstr.exec_instrs tge tf sp parent - (List.fold_right (save_float_callee_save fe) k l) rs fr m - E0 k rs fr' m - /\ fr'.(high) = 0 - /\ fr'.(low) = -fe.(fe_size) - /\ (forall r, - In r l -> index_float_callee_save r < bound_float_callee_save b -> - index_val (FI_saved_float (index_float_callee_save r)) fr' = rs r) - /\ (forall idx, - index_valid idx -> - (forall r, - In r l -> index_float_callee_save r < bound_float_callee_save b -> - idx <> FI_saved_float (index_float_callee_save r)) -> - index_val idx fr' = index_val idx fr). -Proof. - induction l. - (* base case *) - intros. simpl fold_right. exists fr. - split. apply Machabstr.exec_refl. split. auto. split. auto. - split. intros. elim H3. auto. - (* inductive case *) - intros. simpl fold_right. - set (k1 := fold_right (save_float_callee_save fe) k l) in *. - assert (R1: incl l float_callee_save_regs). eauto with coqlib. - assert (R2: list_norepet l). inversion H0; auto. - unfold save_float_callee_save. - case (zlt (index_float_callee_save a) (fe_num_float_callee_save fe)); - intro; - unfold fe_num_float_callee_save, fe, make_env in z. - (* a store takes place *) - assert (IDX: index_valid (FI_saved_float (index_float_callee_save a))). - apply index_saved_float_valid. eauto with coqlib. auto. - generalize (set_slot_index _ _ (rs a) IDX H1 H2). - intros [fr1 SET]. - assert (R3: high fr1 = 0). inversion SET. simpl high. auto. - assert (R4: low fr1 = -fe_size fe). inversion SET. simpl low. auto. - generalize (IHl k sp parent rs fr1 m R1 R2 R3 R4). - intros [fr' [A [B [C [D E]]]]]. - exists fr'. - split. eapply Machabstr.exec_trans. apply exec_Msetstack'; eauto with stacking. - eexact A. traceEq. - split. auto. - split. auto. - split. intros. elim H3; intros. subst r. - rewrite E. eapply slot_iss; eauto. auto. - intros. decEq. apply index_float_callee_save_inj; auto with coqlib. - inversion H0. red; intro; subst r; contradiction. - apply D; auto. - intros. transitivity (index_val idx fr1). - apply E; auto. - intros. apply H4; eauto with coqlib. - eapply slot_iso; eauto. - destruct idx; simpl; auto. - generalize (H4 a (in_eq _ _) z). congruence. - (* no store takes place *) - generalize (IHl k sp parent rs fr m R1 R2 H1 H2). - intros [fr' [A [B [C [D E]]]]]. - exists fr'. split. exact A. split. exact B. split. exact C. - split. intros. elim H3; intros. subst r. omegaContradiction. - apply D; auto. - intros. apply E; auto. - intros. apply H4; auto with coqlib. -Qed. - -Lemma save_float_callee_save_correct: - forall k sp parent rs fr m, - fr.(high) = 0 -> - fr.(low) = -fe.(fe_size) -> +Lemma save_callee_save_float_correct: + forall k sp rs fr m, + fr.(fr_low) = - fe.(fe_size) -> exists fr', - Machabstr.exec_instrs tge tf sp parent - (List.fold_right (save_float_callee_save fe) k float_callee_save_regs) rs fr m - E0 k rs fr' m - /\ fr'.(high) = 0 - /\ fr'.(low) = -fe.(fe_size) + star step tge + (State stack tf sp + (save_callee_save_float fe k) rs fr m) + E0 (State stack tf sp k rs fr' m) + /\ fr'.(fr_low) = - fe.(fe_size) /\ (forall r, In r float_callee_save_regs -> index_float_callee_save r < bound_float_callee_save b -> @@ -815,63 +883,59 @@ Lemma save_float_callee_save_correct: match idx with FI_saved_float _ => False | _ => True end -> index_val idx fr' = index_val idx fr). Proof. - intros. - generalize (save_float_callee_save_correct_rec - float_callee_save_regs k sp parent rs fr m - (incl_refl _) float_callee_save_norepet H H0). - intros [fr' [A [B [C [D E]]]]]. - exists fr'. split. assumption. split. assumption. split. assumption. - split. apply D. intros. apply E. auto. - intros. red; intros; subst idx. contradiction. -Qed. - -Lemma index_val_init_frame: - forall idx, - index_valid idx -> - index_val idx (init_frame tf) = Vundef. -Proof. - intros. unfold index_val, init_frame. simpl contents. - apply load_contents_init. + intros. + exploit (save_callee_save_regs_correct fe_num_float_callee_save index_float_callee_save FI_saved_float + Tfloat sp float_callee_save_regs). + exact index_float_callee_save_inj. + intros. red. split; auto. generalize (index_float_callee_save_pos r H0). omega. + auto. + intros; congruence. + intros until idx. destruct idx; simpl; auto. congruence. + apply incl_refl. + apply float_callee_save_norepet. eauto. + intros [fr' [A [B [C D]]]]. + exists fr'; intuition. unfold save_callee_save_float; eauto. + apply D. auto. intros; subst idx. auto. Qed. Lemma save_callee_save_correct: - forall sp parent k rs fr m ls, + forall sp k rs fr m ls, (forall r, rs r = ls (R r)) -> (forall ofs ty, - 6 <= ofs -> - ofs + typesize ty <= size_arguments f.(fn_sig) -> - get_slot parent ty (Int.signed (Int.repr (4 * ofs))) (ls (S (Outgoing ofs ty)))) -> - high fr = 0 -> - low fr = -fe.(fe_size) -> + 14 <= ofs -> + ofs + typesize ty <= size_arguments f.(Linear.fn_sig) -> + get_slot (parent_frame stack) ty (Int.signed (Int.repr (4 * ofs))) (ls (S (Outgoing ofs ty)))) -> + fr.(fr_low) = - fe.(fe_size) -> (forall idx, index_valid idx -> index_val idx fr = Vundef) -> exists fr', - Machabstr.exec_instrs tge tf sp parent - (save_callee_save fe k) rs fr m - E0 k rs fr' m - /\ agree (LTL.call_regs ls) rs fr' parent rs. + star step tge + (State stack tf sp (save_callee_save fe k) rs fr m) + E0 (State stack tf sp k rs fr' m) + /\ agree (LTL.call_regs ls) rs fr' (parent_frame stack) ls. Proof. intros. unfold save_callee_save. - generalize (save_int_callee_save_correct - (fold_right (save_float_callee_save fe) k float_callee_save_regs) - sp parent rs fr m H1 H2). - intros [fr1 [A1 [B1 [C1 [D1 E1]]]]]. - generalize (save_float_callee_save_correct k sp parent rs fr1 m B1 C1). - intros [fr2 [A2 [B2 [C2 [D2 E2]]]]]. + exploit save_callee_save_int_correct; eauto. + intros [fr1 [A1 [B1 [C1 D1]]]]. + exploit save_callee_save_float_correct. eexact B1. + intros [fr2 [A2 [B2 [C2 D2]]]]. exists fr2. - split. eapply Machabstr.exec_trans. eexact A1. eexact A2. traceEq. + split. eapply star_trans. eexact A1. eexact A2. traceEq. constructor; unfold LTL.call_regs; auto. (* agree_local *) - intros. rewrite E2; auto with stacking. - rewrite E1; auto with stacking. + intros. rewrite D2; auto with stacking. + rewrite D1; auto with stacking. symmetry. auto with stacking. (* agree_outgoing *) - intros. rewrite E2; auto with stacking. - rewrite E1; auto with stacking. + intros. rewrite D2; auto with stacking. + rewrite D1; auto with stacking. symmetry. auto with stacking. (* agree_incoming *) - intros. simpl in H4. apply H0. tauto. tauto. + intros. simpl in H3. apply H0. tauto. tauto. (* agree_saved_int *) - intros. rewrite E2; auto with stacking. + intros. rewrite D2; auto with stacking. + rewrite C1; auto with stacking. + (* agree_saved_float *) + intros. rewrite C2; auto with stacking. Qed. (** The following lemmas show the correctness of the register reloading @@ -879,49 +943,66 @@ Qed. all callee-save registers contain the same values they had at function entry. *) -Lemma restore_int_callee_save_correct_rec: - forall sp parent k fr m rs0 l ls rs, - incl l int_callee_save_regs -> +Section RESTORE_CALLEE_SAVE. + +Variable bound: frame_env -> Z. +Variable number: mreg -> Z. +Variable mkindex: Z -> frame_index. +Variable ty: typ. +Variable sp: val. +Variable csregs: list mreg. +Hypothesis mkindex_valid: + forall r, In r csregs -> number r < bound fe -> index_valid (mkindex (number r)). +Hypothesis mkindex_typ: + forall z, type_of_index (mkindex z) = ty. +Hypothesis number_within_bounds: + forall r, In r csregs -> + (number r < bound fe <-> mreg_within_bounds b r). +Hypothesis mkindex_val: + forall ls rs fr ls0 r, + agree ls rs fr (parent_frame stack) ls0 -> In r csregs -> number r < bound fe -> + index_val (mkindex (number r)) fr = ls0 (R r). + +Lemma restore_callee_save_regs_correct: + forall k fr m ls0 l ls rs, + incl l csregs -> list_norepet l -> - agree ls rs fr parent rs0 -> + agree ls rs fr (parent_frame stack) ls0 -> exists ls', exists rs', - Machabstr.exec_instrs tge tf sp parent - (List.fold_right (restore_int_callee_save fe) k l) rs fr m - E0 k rs' fr m - /\ (forall r, In r l -> rs' r = rs0 r) + star step tge + (State stack tf sp + (restore_callee_save_regs bound number mkindex ty fe l k) rs fr m) + E0 (State stack tf sp k rs' fr m) + /\ (forall r, In r l -> rs' r = ls0 (R r)) /\ (forall r, ~(In r l) -> rs' r = rs r) - /\ agree ls' rs' fr parent rs0. + /\ agree ls' rs' fr (parent_frame stack) ls0. Proof. - induction l. + induction l; intros; simpl restore_callee_save_regs. (* base case *) - intros. simpl fold_right. exists ls. exists rs. - split. apply Machabstr.exec_refl. + exists ls. exists rs. + split. apply star_refl. split. intros. elim H2. split. auto. auto. (* inductive case *) - intros. simpl fold_right. - set (k1 := fold_right (restore_int_callee_save fe) k l) in *. - assert (R0: In a int_callee_save_regs). apply H; auto with coqlib. - assert (R1: incl l int_callee_save_regs). eauto with coqlib. + set (k1 := restore_callee_save_regs bound number mkindex ty fe l k). + assert (R0: In a csregs). apply H; auto with coqlib. + assert (R1: incl l csregs). eauto with coqlib. assert (R2: list_norepet l). inversion H0; auto. - unfold restore_int_callee_save. - case (zlt (index_int_callee_save a) (fe_num_int_callee_save fe)); - intro; - unfold fe_num_int_callee_save, fe, make_env in z. - set (ls1 := Locmap.set (R a) (rs0 a) ls). - set (rs1 := Regmap.set a (rs0 a) rs). - assert (R3: agree ls1 rs1 fr parent rs0). + unfold restore_callee_save_reg. + destruct (zlt (number a) (bound fe)). + set (ls1 := Locmap.set (R a) (ls0 (R a)) ls). + set (rs1 := Regmap.set a (ls0 (R a)) rs). + assert (R3: agree ls1 rs1 fr (parent_frame stack) ls0). unfold ls1, rs1. apply agree_set_reg. auto. - red. rewrite int_callee_save_type. exact z. - apply H. auto with coqlib. + rewrite <- number_within_bounds; auto. generalize (IHl ls1 rs1 R1 R2 R3). intros [ls' [rs' [A [B [C D]]]]]. - exists ls'. exists rs'. - split. apply Machabstr.exec_trans with E0 k1 rs1 fr m E0. + exists ls'. exists rs'. split. + apply star_left with E0 (State stack tf sp k1 rs1 fr m) E0. unfold rs1; apply exec_Mgetstack'; eauto with stacking. apply get_slot_index; eauto with stacking. - symmetry. eauto with stacking. - eauto with stacking. traceEq. + symmetry. eapply mkindex_val; eauto. + auto. traceEq. split. intros. elim H2; intros. subst r. rewrite C. unfold rs1. apply Regmap.gss. inversion H0; auto. auto. @@ -934,127 +1015,82 @@ Proof. exists ls'; exists rs'. split. assumption. split. intros. elim H2; intros. subst r. apply (agree_unused_reg _ _ _ _ _ D). - unfold mreg_bounded. rewrite int_callee_save_type; auto. - auto. + rewrite <- number_within_bounds. auto. omega. auto. split. intros. simpl in H2. apply C. tauto. assumption. Qed. +End RESTORE_CALLEE_SAVE. + Lemma restore_int_callee_save_correct: - forall sp parent k fr m rs0 ls rs, - agree ls rs fr parent rs0 -> + forall sp k fr m ls0 ls rs, + agree ls rs fr (parent_frame stack) ls0 -> exists ls', exists rs', - Machabstr.exec_instrs tge tf sp parent - (List.fold_right (restore_int_callee_save fe) k int_callee_save_regs) rs fr m - E0 k rs' fr m - /\ (forall r, In r int_callee_save_regs -> rs' r = rs0 r) + star step tge + (State stack tf sp + (restore_callee_save_int fe k) rs fr m) + E0 (State stack tf sp k rs' fr m) + /\ (forall r, In r int_callee_save_regs -> rs' r = ls0 (R r)) /\ (forall r, ~(In r int_callee_save_regs) -> rs' r = rs r) - /\ agree ls' rs' fr parent rs0. + /\ agree ls' rs' fr (parent_frame stack) ls0. Proof. - intros. apply restore_int_callee_save_correct_rec with ls. - apply incl_refl. apply int_callee_save_norepet. auto. -Qed. - -Lemma restore_float_callee_save_correct_rec: - forall sp parent k fr m rs0 l ls rs, - incl l float_callee_save_regs -> - list_norepet l -> - agree ls rs fr parent rs0 -> - exists ls', exists rs', - Machabstr.exec_instrs tge tf sp parent - (List.fold_right (restore_float_callee_save fe) k l) rs fr m - E0 k rs' fr m - /\ (forall r, In r l -> rs' r = rs0 r) - /\ (forall r, ~(In r l) -> rs' r = rs r) - /\ agree ls' rs' fr parent rs0. -Proof. - induction l. - (* base case *) - intros. simpl fold_right. exists ls. exists rs. - split. apply Machabstr.exec_refl. - split. intros. elim H2. - split. auto. auto. - (* inductive case *) - intros. simpl fold_right. - set (k1 := fold_right (restore_float_callee_save fe) k l) in *. - assert (R0: In a float_callee_save_regs). apply H; auto with coqlib. - assert (R1: incl l float_callee_save_regs). eauto with coqlib. - assert (R2: list_norepet l). inversion H0; auto. - unfold restore_float_callee_save. - case (zlt (index_float_callee_save a) (fe_num_float_callee_save fe)); - intro; - unfold fe_num_float_callee_save, fe, make_env in z. - set (ls1 := Locmap.set (R a) (rs0 a) ls). - set (rs1 := Regmap.set a (rs0 a) rs). - assert (R3: agree ls1 rs1 fr parent rs0). - unfold ls1, rs1. apply agree_set_reg. auto. - red. rewrite float_callee_save_type. exact z. - apply H. auto with coqlib. - generalize (IHl ls1 rs1 R1 R2 R3). - intros [ls' [rs' [A [B [C D]]]]]. - exists ls'. exists rs'. - split. apply Machabstr.exec_trans with E0 k1 rs1 fr m E0. - unfold rs1; apply exec_Mgetstack'; eauto with stacking. - apply get_slot_index; eauto with stacking. - symmetry. eauto with stacking. - exact A. traceEq. - split. intros. elim H2; intros. - subst r. rewrite C. unfold rs1. apply Regmap.gss. inversion H0; auto. + intros. unfold restore_callee_save_int. + apply restore_callee_save_regs_correct with int_callee_save_regs ls. + intros; simpl. split; auto. generalize (index_int_callee_save_pos r H0). omega. auto. - split. intros. simpl in H2. rewrite C. unfold rs1. apply Regmap.gso. - apply sym_not_eq; tauto. tauto. - assumption. - (* no load takes place *) - generalize (IHl ls rs R1 R2 H1). - intros [ls' [rs' [A [B [C D]]]]]. - exists ls'; exists rs'. split. assumption. - split. intros. elim H2; intros. - subst r. apply (agree_unused_reg _ _ _ _ _ D). - unfold mreg_bounded. rewrite float_callee_save_type; auto. + intros. unfold mreg_within_bounds. + rewrite (int_callee_save_type r H0). tauto. + eauto with stacking. + apply incl_refl. + apply int_callee_save_norepet. auto. - split. intros. simpl in H2. apply C. tauto. - assumption. Qed. Lemma restore_float_callee_save_correct: - forall sp parent k fr m rs0 ls rs, - agree ls rs fr parent rs0 -> + forall sp k fr m ls0 ls rs, + agree ls rs fr (parent_frame stack) ls0 -> exists ls', exists rs', - Machabstr.exec_instrs tge tf sp parent - (List.fold_right (restore_float_callee_save fe) k float_callee_save_regs) rs fr m - E0 k rs' fr m - /\ (forall r, In r float_callee_save_regs -> rs' r = rs0 r) + star step tge + (State stack tf sp + (restore_callee_save_float fe k) rs fr m) + E0 (State stack tf sp k rs' fr m) + /\ (forall r, In r float_callee_save_regs -> rs' r = ls0 (R r)) /\ (forall r, ~(In r float_callee_save_regs) -> rs' r = rs r) - /\ agree ls' rs' fr parent rs0. + /\ agree ls' rs' fr (parent_frame stack) ls0. Proof. - intros. apply restore_float_callee_save_correct_rec with ls. - apply incl_refl. apply float_callee_save_norepet. auto. + intros. unfold restore_callee_save_float. + apply restore_callee_save_regs_correct with float_callee_save_regs ls. + intros; simpl. split; auto. generalize (index_float_callee_save_pos r H0). omega. + auto. + intros. unfold mreg_within_bounds. + rewrite (float_callee_save_type r H0). tauto. + eauto with stacking. + apply incl_refl. + apply float_callee_save_norepet. + auto. Qed. Lemma restore_callee_save_correct: - forall sp parent k fr m rs0 ls rs, - agree ls rs fr parent rs0 -> + forall sp k fr m ls0 ls rs, + agree ls rs fr (parent_frame stack) ls0 -> exists rs', - Machabstr.exec_instrs tge tf sp parent - (restore_callee_save fe k) rs fr m - E0 k rs' fr m + star step tge + (State stack tf sp (restore_callee_save fe k) rs fr m) + E0 (State stack tf sp k rs' fr m) /\ (forall r, In r int_callee_save_regs \/ In r float_callee_save_regs -> - rs' r = rs0 r) + rs' r = ls0 (R r)) /\ (forall r, ~(In r int_callee_save_regs) -> ~(In r float_callee_save_regs) -> rs' r = rs r). Proof. intros. unfold restore_callee_save. - generalize (restore_int_callee_save_correct sp parent - (fold_right (restore_float_callee_save fe) k float_callee_save_regs) - fr m rs0 ls rs H). + exploit restore_int_callee_save_correct; eauto. intros [ls1 [rs1 [A [B [C D]]]]]. - generalize (restore_float_callee_save_correct sp parent - k fr m rs0 ls1 rs1 D). + exploit restore_float_callee_save_correct. eexact D. intros [ls2 [rs2 [P [Q [R S]]]]]. - exists rs2. split. eapply Machabstr.exec_trans. eexact A. eexact P. traceEq. + exists rs2. split. eapply star_trans. eexact A. eexact P. traceEq. split. intros. elim H0; intros. rewrite R. apply B. auto. apply list_disjoint_notin with int_callee_save_regs. apply int_float_callee_save_disjoint. auto. @@ -1083,12 +1119,12 @@ Remark find_label_save_callee_save: forall fe lbl k, Mach.find_label lbl (save_callee_save fe k) = Mach.find_label lbl k. Proof. - intros. unfold save_callee_save. + intros. unfold save_callee_save, save_callee_save_int, save_callee_save_float, save_callee_save_regs. repeat rewrite find_label_fold_right. reflexivity. - intros. unfold save_float_callee_save. + intros. unfold save_callee_save_reg. case (zlt (index_float_callee_save x) (fe_num_float_callee_save fe)); intro; reflexivity. - intros. unfold save_int_callee_save. + intros. unfold save_callee_save_reg. case (zlt (index_int_callee_save x) (fe_num_int_callee_save fe)); intro; reflexivity. Qed. @@ -1097,12 +1133,12 @@ Remark find_label_restore_callee_save: forall fe lbl k, Mach.find_label lbl (restore_callee_save fe k) = Mach.find_label lbl k. Proof. - intros. unfold restore_callee_save. + intros. unfold restore_callee_save, restore_callee_save_int, restore_callee_save_float, restore_callee_save_regs. repeat rewrite find_label_fold_right. reflexivity. - intros. unfold restore_float_callee_save. + intros. unfold restore_callee_save_reg. case (zlt (index_float_callee_save x) (fe_num_float_callee_save fe)); intro; reflexivity. - intros. unfold restore_int_callee_save. + intros. unfold restore_callee_save_reg. case (zlt (index_int_callee_save x) (fe_num_int_callee_save fe)); intro; reflexivity. Qed. @@ -1117,13 +1153,14 @@ Proof. destruct a; unfold transl_instr; auto. destruct s; simpl; auto. destruct s; simpl; auto. + rewrite find_label_restore_callee_save. auto. simpl. case (peq lbl l); intro. reflexivity. auto. rewrite find_label_restore_callee_save. auto. Qed. Lemma transl_find_label: forall f tf lbl c, - transf_function f = Some tf -> + transf_function f = OK tf -> Linear.find_label lbl f.(Linear.fn_code) = Some c -> Mach.find_label lbl tf.(Mach.fn_code) = Some (transl_code (make_env (function_bounds f)) c). @@ -1143,32 +1180,11 @@ Lemma find_label_incl: Proof. induction c; simpl. intros; discriminate. - intro c'. case (is_label lbl a); intros. + intro c'. case (Linear.is_label lbl a); intros. injection H; intro; subst c'. red; intros; auto with coqlib. apply incl_tl. auto. Qed. -Lemma exec_instr_incl: - forall f sp c1 ls1 m1 t c2 ls2 m2, - Linear.exec_instr ge f sp c1 ls1 m1 t c2 ls2 m2 -> - incl c1 f.(fn_code) -> - incl c2 f.(fn_code). -Proof. - induction 1; intros; eauto with coqlib. - eapply find_label_incl; eauto. - eapply find_label_incl; eauto. -Qed. - -Lemma exec_instrs_incl: - forall f sp c1 ls1 m1 t c2 ls2 m2, - Linear.exec_instrs ge f sp c1 ls1 m1 t c2 ls2 m2 -> - incl c1 f.(fn_code) -> - incl c2 f.(fn_code). -Proof. - induction 1; intros; auto. - eapply exec_instr_incl; eauto. -Qed. - (** Preservation / translation of global symbols and functions. *) Lemma symbols_preserved: @@ -1180,42 +1196,59 @@ Proof. Qed. Lemma functions_translated: - forall f v, + forall v f, Genv.find_funct ge v = Some f -> exists tf, - Genv.find_funct tge v = Some tf /\ transf_fundef f = Some tf. -Proof. - intros. - generalize (Genv.find_funct_transf_partial transf_fundef TRANSF H). - case (transf_fundef f). - intros tf [A B]. exists tf. tauto. - intros. tauto. -Qed. + Genv.find_funct tge v = Some tf /\ transf_fundef f = OK tf. +Proof + (Genv.find_funct_transf_partial transf_fundef TRANSF). Lemma function_ptr_translated: - forall f v, + forall v f, Genv.find_funct_ptr ge v = Some f -> exists tf, - Genv.find_funct_ptr tge v = Some tf /\ transf_fundef f = Some tf. -Proof. - intros. - generalize (Genv.find_funct_ptr_transf_partial transf_fundef TRANSF H). - case (transf_fundef f). - intros tf [A B]. exists tf. tauto. - intros. tauto. -Qed. + Genv.find_funct_ptr tge v = Some tf /\ transf_fundef f = OK tf. +Proof + (Genv.find_funct_ptr_transf_partial transf_fundef TRANSF). Lemma sig_preserved: - forall f tf, transf_fundef f = Some tf -> Mach.funsig tf = Linear.funsig f. + forall f tf, transf_fundef f = OK tf -> Mach.funsig tf = Linear.funsig f. Proof. intros until tf; unfold transf_fundef, transf_partial_fundef. destruct f. unfold transf_function. - destruct (zlt (fn_stacksize f) 0). congruence. - destruct (zlt (- Int.min_signed) (fe_size (make_env (function_bounds f)))). congruence. - intros. inversion H; reflexivity. + destruct (zlt (Linear.fn_stacksize f) 0). simpl; congruence. + destruct (zlt (- Int.min_signed) (fe_size (make_env (function_bounds f)))). simpl; congruence. + unfold bind. intros. inversion H; reflexivity. intro. inversion H. reflexivity. Qed. +Lemma find_function_translated: + forall f0 ls rs fr parent ls0 ros f, + agree f0 ls rs fr parent ls0 -> + Linear.find_function ge ros ls = Some f -> + exists tf, + find_function tge ros rs = Some tf /\ transf_fundef f = OK tf. +Proof. + intros until f; intro AG. + destruct ros; simpl. + rewrite (agree_eval_reg _ _ _ _ _ _ m AG). intro. + apply functions_translated; auto. + rewrite symbols_preserved. destruct (Genv.find_symbol ge i); try congruence. + intro. apply function_ptr_translated; auto. +Qed. + +Hypothesis wt_prog: wt_program prog. + +Lemma find_function_well_typed: + forall ros ls f, + Linear.find_function ge ros ls = Some f -> wt_fundef f. +Proof. + intros until f; destruct ros; simpl; unfold ge. + intro. eapply Genv.find_funct_prop; eauto. + destruct (Genv.find_symbol (Genv.globalenv prog) i); try congruence. + intro. eapply Genv.find_funct_ptr_prop; eauto. +Qed. + (** Correctness of stack pointer relocation in operations and addressing modes. *) @@ -1224,7 +1257,7 @@ Definition shift_sp (tf: Mach.function) (sp: val) := Remark shift_offset_sp: forall f tf sp n v, - transf_function f = Some tf -> + transf_function f = OK tf -> offset_sp sp n = Some v -> offset_sp (shift_sp tf sp) (Int.add (Int.repr (fe_size (make_env (function_bounds f)))) n) = Some v. @@ -1243,11 +1276,11 @@ Proof. Qed. Lemma shift_eval_operation: - forall f tf sp op args v, - transf_function f = Some tf -> - eval_operation ge sp op args = Some v -> + forall f tf sp op args m v, + transf_function f = OK tf -> + eval_operation ge sp op args m = Some v -> eval_operation tge (shift_sp tf sp) - (transl_op (make_env (function_bounds f)) op) args = + (transl_op (make_env (function_bounds f)) op) args m = Some v. Proof. intros until v. destruct op; intros; auto. @@ -1258,7 +1291,7 @@ Qed. Lemma shift_eval_addressing: forall f tf sp addr args v, - transf_function f = Some tf -> + transf_function f = OK tf -> eval_addressing ge sp addr args = Some v -> eval_addressing tge (shift_sp tf sp) (transl_addr (make_env (function_bounds f)) addr) args = @@ -1282,7 +1315,7 @@ Variable rs: regset. Variable sg: signature. Hypothesis AG1: forall r, rs r = ls (R r). Hypothesis AG2: forall (ofs : Z) (ty : typ), - 6 <= ofs -> + 14 <= ofs -> ofs + typesize ty <= size_arguments sg -> get_slot fr ty (Int.signed (Int.repr (4 * ofs))) (ls (S (Outgoing ofs ty))). @@ -1319,374 +1352,336 @@ End EXTERNAL_ARGUMENTS. (** The proof of semantic preservation relies on simulation diagrams of the following form: << - c, ls, m ------------------- T(c), rs, fr, m - | | - | | - v v - c', ls', m' ---------------- T(c'), rs', fr', m' + st1 --------------- st2 + | | + t| +|t + | | + v v + st1'--------------- st2' >> - The left vertical arrow represents a transition in the - original Linear code. The top horizontal bar captures three preconditions: -- Agreement between [ls] on the Linear side and [rs], [fr], [rs0] - on the Mach side. -- Inclusion between [c] and the code of the function [f] being - translated. + Matching between source and target states is defined by [match_states] + below. It implies: +- Agreement between, on the Linear side, the location sets [ls] + and [parent_locset s] of the current function and its caller, + and on the Mach side the register set [rs], the frame [fr] + and the caller's frame [parent_frame ts]. +- Inclusion between the Linear code [c] and the code of the + function [f] being executed. - Well-typedness of [f]. - - In conclusion, we want to prove the existence of [rs'], [fr'], [m'] - that satisfies the right arrow (zero, one or several transitions in - the generated Mach code) and the postcondition (agreement between - [ls'] and [rs'], [fr'], [rs0]). - - As usual, we capture these diagrams as predicates parameterized - by the transition in the original Linear code. *) - -Definition exec_instr_prop - (f: function) (sp: val) - (c: code) (ls: locset) (m: mem) (t: trace) - (c': code) (ls': locset) (m': mem) := - forall tf rs fr parent rs0 - (TRANSL: transf_function f = Some tf) - (WTF: wt_function f) - (AG: agree f ls rs fr parent rs0) - (INCL: incl c f.(fn_code)), - exists rs', exists fr', - Machabstr.exec_instrs tge tf (shift_sp tf sp) parent - (transl_code (make_env (function_bounds f)) c) rs fr m - t (transl_code (make_env (function_bounds f)) c') rs' fr' m' - /\ agree f ls' rs' fr' parent rs0. - -(** The simulation property for function calls has different preconditions - (a slightly weaker notion of agreement between [ls] and the initial - register values [rs] and caller's frame [parent]) and different - postconditions (preservation of callee-save registers). *) - -Definition exec_function_prop - (f: fundef) - (ls: locset) (m: mem) (t: trace) - (ls': locset) (m': mem) := - forall tf rs parent - (TRANSL: transf_fundef f = Some tf) - (WTF: wt_fundef f) - (AG1: forall r, rs r = ls (R r)) - (AG2: forall ofs ty, - 6 <= ofs -> - ofs + typesize ty <= size_arguments (funsig f) -> - get_slot parent ty (Int.signed (Int.repr (4 * ofs))) (ls (S (Outgoing ofs ty)))), - exists rs', - Machabstr.exec_function tge tf parent rs m t rs' m' - /\ (forall r, - In (R r) temporaries \/ In (R r) destroyed_at_call -> - rs' r = ls' (R r)) - /\ (forall r, - In r int_callee_save_regs \/ In r float_callee_save_regs -> - rs' r = rs r). - -Hypothesis wt_prog: wt_program prog. - -Lemma transf_function_correct: - forall f ls m t ls' m', - Linear.exec_function ge f ls m t ls' m' -> - exec_function_prop f ls m t ls' m'. +*) + +Inductive match_stacks: list Linear.stackframe -> list Machabstr.stackframe -> Prop := + | match_stacks_nil: + match_stacks nil nil + | match_stacks_cons: + forall f sp c ls tf fr s ts, + match_stacks s ts -> + transf_function f = OK tf -> + wt_function f -> + agree_frame f ls fr (parent_frame ts) (parent_locset s) -> + incl c (Linear.fn_code f) -> + match_stacks + (Linear.Stackframe f sp ls c :: s) + (Machabstr.Stackframe tf (shift_sp tf sp) (transl_code (make_env (function_bounds f)) c) fr :: ts). + +Inductive match_states: Linear.state -> Machabstr.state -> Prop := + | match_states_intro: + forall s f sp c ls m ts tf rs fr + (STACKS: match_stacks s ts) + (TRANSL: transf_function f = OK tf) + (WTF: wt_function f) + (AG: agree f ls rs fr (parent_frame ts) (parent_locset s)) + (INCL: incl c (Linear.fn_code f)), + match_states (Linear.State s f sp c ls m) + (Machabstr.State ts tf (shift_sp tf sp) (transl_code (make_env (function_bounds f)) c) rs fr m) + | match_states_call: + forall s f ls m ts tf rs + (STACKS: match_stacks s ts) + (TRANSL: transf_fundef f = OK tf) + (WTF: wt_fundef f) + (AG1: forall r, rs r = ls (R r)) + (AG2: forall ofs ty, + 14 <= ofs -> + ofs + typesize ty <= size_arguments (Linear.funsig f) -> + get_slot (parent_frame ts) ty (Int.signed (Int.repr (4 * ofs))) (ls (S (Outgoing ofs ty)))) + (AG3: agree_callee_save ls (parent_locset s)), + match_states (Linear.Callstate s f ls m) + (Machabstr.Callstate ts tf rs m) + | match_states_return: + forall s ls m ts rs + (STACKS: match_stacks s ts) + (AG1: forall r, rs r = ls (R r)) + (AG2: agree_callee_save ls (parent_locset s)), + match_states (Linear.Returnstate s ls m) + (Machabstr.Returnstate ts rs m). + +Theorem transf_step_correct: + forall s1 t s2, Linear.step ge s1 t s2 -> + forall s1' (MS: match_states s1 s1'), + exists s2', plus step tge s1' t s2' /\ match_states s2 s2'. Proof. assert (RED: forall f i c, transl_code (make_env (function_bounds f)) (i :: c) = transl_instr (make_env (function_bounds f)) i (transl_code (make_env (function_bounds f)) c)). intros. reflexivity. - apply (Linear.exec_function_ind3 ge exec_instr_prop - exec_instr_prop exec_function_prop); - intros; red; intros; - try rewrite RED; + induction 1; intros; + try inv MS; + try rewrite RED; try (generalize (WTF _ (INCL _ (in_eq _ _))); intro WTI); + try (generalize (function_is_within_bounds f WTF _ (INCL _ (in_eq _ _))); + intro BOUND; simpl in BOUND); unfold transl_instr. - (* Lgetstack *) - inversion WTI. exists (rs0#r <- (rs (S sl))); exists fr. + inv WTI. destruct BOUND. + exists (State ts tf (shift_sp tf sp) (transl_code (make_env (function_bounds f)) b) + (rs0#r <- (rs (S sl))) fr m). split. destruct sl. (* Lgetstack, local *) - apply exec_Mgetstack'; auto. + apply plus_one. eapply exec_Mgetstack'; eauto. apply get_slot_index. apply index_local_valid. auto. eapply agree_size; eauto. reflexivity. eapply agree_locals; eauto. (* Lgetstack, incoming *) - apply Machabstr.exec_one; constructor. + apply plus_one; apply exec_Mgetparam. unfold offset_of_index. eapply agree_incoming; eauto. (* Lgetstack, outgoing *) - apply exec_Mgetstack'; auto. + apply plus_one; apply exec_Mgetstack'; eauto. apply get_slot_index. apply index_arg_valid. auto. eapply agree_size; eauto. reflexivity. eapply agree_outgoing; eauto. (* Lgetstack, common *) + econstructor; eauto with coqlib. apply agree_set_reg; auto. (* Lsetstack *) - inversion WTI. destruct sl. + inv WTI. destruct sl. + (* Lsetstack, local *) - generalize (agree_set_local _ _ _ _ _ _ (rs0 r) _ _ AG H3). + generalize (agree_set_local _ _ _ _ _ _ (rs0 r) _ _ AG BOUND). intros [fr' [SET AG']]. - exists rs0; exists fr'. split. - apply exec_Msetstack'; auto. + econstructor; split. + apply plus_one. eapply exec_Msetstack'; eauto. + econstructor; eauto with coqlib. replace (rs (R r)) with (rs0 r). auto. symmetry. eapply agree_reg; eauto. (* Lsetstack, incoming *) contradiction. (* Lsetstack, outgoing *) - generalize (agree_set_outgoing _ _ _ _ _ _ (rs0 r) _ _ AG H3). + generalize (agree_set_outgoing _ _ _ _ _ _ (rs0 r) _ _ AG BOUND). intros [fr' [SET AG']]. - exists rs0; exists fr'. split. - apply exec_Msetstack'; auto. + econstructor; split. + apply plus_one. eapply exec_Msetstack'; eauto. + econstructor; eauto with coqlib. replace (rs (R r)) with (rs0 r). auto. symmetry. eapply agree_reg; eauto. (* Lop *) - assert (mreg_bounded f res). inversion WTI; auto. - exists (rs0#res <- v); exists fr. split. - apply Machabstr.exec_one. constructor. + exists (State ts tf (shift_sp tf sp) (transl_code (make_env (function_bounds f)) b) (rs0#res <- v) fr m); split. + apply plus_one. apply exec_Mop. apply shift_eval_operation. auto. change mreg with RegEq.t. rewrite (agree_eval_regs _ _ _ _ _ _ args AG). auto. + econstructor; eauto with coqlib. apply agree_set_reg; auto. (* Lload *) - inversion WTI. exists (rs0#dst <- v); exists fr. split. - apply Machabstr.exec_one; econstructor. + exists (State ts tf (shift_sp tf sp) (transl_code (make_env (function_bounds f)) b) (rs0#dst <- v) fr m); split. + apply plus_one; eapply exec_Mload; eauto. apply shift_eval_addressing; auto. change mreg with RegEq.t. rewrite (agree_eval_regs _ _ _ _ _ _ args AG). eauto. - auto. + econstructor; eauto with coqlib. apply agree_set_reg; auto. (* Lstore *) - exists rs0; exists fr. split. - apply Machabstr.exec_one; econstructor. - apply shift_eval_addressing; auto. + econstructor; split. + apply plus_one; eapply exec_Mstore; eauto. + apply shift_eval_addressing; eauto. change mreg with RegEq.t. rewrite (agree_eval_regs _ _ _ _ _ _ args AG). eauto. - rewrite (agree_eval_reg _ _ _ _ _ _ src AG). auto. - auto. - - (* Lcall *) - inversion WTI. - assert (WTF': wt_fundef f'). - destruct ros; simpl in H. - apply (Genv.find_funct_prop wt_fundef wt_prog H). - destruct (Genv.find_symbol ge i); try discriminate. - apply (Genv.find_funct_ptr_prop wt_fundef wt_prog H). - assert (TR: exists tf', Mach.find_function tge ros rs0 = Some tf' - /\ transf_fundef f' = Some tf'). - destruct ros; simpl in H; simpl. - eapply functions_translated. - rewrite (agree_eval_reg _ _ _ _ _ _ m0 AG). auto. - rewrite symbols_preserved. - destruct (Genv.find_symbol ge i); try discriminate. - apply function_ptr_translated; auto. - elim TR; intros tf' [FIND' TRANSL']; clear TR. - assert (AG1: forall r, rs0 r = rs (R r)). - intro. symmetry. eapply agree_reg; eauto. - assert (AG2: forall ofs ty, - 6 <= ofs -> - ofs + typesize ty <= size_arguments (funsig f') -> - get_slot fr ty (Int.signed (Int.repr (4 * ofs))) (rs (S (Outgoing ofs ty)))). - intros. - assert (slot_bounded f (Outgoing ofs ty)). - red. rewrite <- H0 in H8. omega. - change (4 * ofs) with (offset_of_index (make_env (function_bounds f)) (FI_arg ofs ty)). - rewrite (offset_of_index_no_overflow f tf); auto. - apply get_slot_index. apply index_arg_valid. auto. - eapply agree_size; eauto. reflexivity. - eapply agree_outgoing; eauto. - generalize (H2 tf' rs0 fr TRANSL' WTF' AG1 AG2). - intros [rs2 [EXF [REGS1 REGS2]]]. - exists rs2; exists fr. split. - apply Machabstr.exec_one; apply Machabstr.exec_Mcall with tf'; auto. - apply agree_return_regs with rs0; auto. - + rewrite (agree_eval_reg _ _ _ _ _ _ src AG). eauto. + econstructor; eauto with coqlib. + + (* Lcall *) + assert (WTF': wt_fundef f'). eapply find_function_well_typed; eauto. + exploit find_function_translated; eauto. + intros [tf' [FIND' TRANSL']]. + econstructor; split. + apply plus_one; eapply exec_Mcall; eauto. + econstructor; eauto. + econstructor; eauto with coqlib. + exists rs0; auto. + intro. symmetry. eapply agree_reg; eauto. + intros. + assert (slot_within_bounds f (function_bounds f) (Outgoing ofs ty)). + red. simpl. omega. + change (4 * ofs) with (offset_of_index (make_env (function_bounds f)) (FI_arg ofs ty)). + rewrite (offset_of_index_no_overflow f tf); auto. + apply get_slot_index. apply index_arg_valid. auto. + eapply agree_size; eauto. reflexivity. + eapply agree_outgoing; eauto. + simpl. red; auto. + + (* Ltailcall *) + assert (WTF': wt_fundef f'). eapply find_function_well_typed; eauto. + generalize (find_function_translated _ _ _ _ _ _ _ _ AG H). + intros [tf' [FIND' TRANSL']]. + generalize (restore_callee_save_correct ts _ _ TRANSL + (shift_sp tf (Vptr stk Int.zero)) + (Mtailcall (Linear.funsig f') ros :: transl_code (make_env (function_bounds f)) b) + _ m _ _ _ AG). + intros [rs2 [A [B C]]]. + assert (FIND'': find_function tge ros rs2 = Some tf'). + rewrite <- FIND'. destruct ros; simpl; auto. + inv WTI. rewrite C. auto. + simpl. intuition congruence. simpl. intuition congruence. + econstructor; split. + eapply plus_right. eexact A. + simpl shift_sp. eapply exec_Mtailcall; eauto. traceEq. + econstructor; eauto. + intros; symmetry; eapply agree_return_regs; eauto. + intros. inv WTI. rewrite tailcall_possible_size in H4. + rewrite H4 in H1. elimtype False. generalize (typesize_pos ty). omega. + apply agree_callee_save_return_regs. + (* Lalloc *) - exists (rs0#loc_alloc_result <- (Vptr blk Int.zero)); exists fr. split. - apply Machabstr.exec_one; eapply Machabstr.exec_Malloc; eauto. + exists (State ts tf (shift_sp tf sp) (transl_code (make_env (function_bounds f)) b) + (rs0#loc_alloc_result <- (Vptr blk Int.zero)) fr m'); split. + apply plus_one; eapply exec_Malloc; eauto. rewrite (agree_eval_reg _ _ _ _ _ _ loc_alloc_argument AG). auto. + econstructor; eauto with coqlib. apply agree_set_reg; auto. red. simpl. generalize (max_over_regs_of_funct_pos f int_callee_save). omega. (* Llabel *) - exists rs0; exists fr. split. - apply Machabstr.exec_one; apply Machabstr.exec_Mlabel. - auto. + econstructor; split. + apply plus_one; apply exec_Mlabel. + econstructor; eauto with coqlib. (* Lgoto *) - exists rs0; exists fr. split. - apply Machabstr.exec_one; apply Machabstr.exec_Mgoto. - apply transl_find_label; auto. - auto. + econstructor; split. + apply plus_one; apply exec_Mgoto. + apply transl_find_label; eauto. + econstructor; eauto. + eapply find_label_incl; eauto. (* Lcond, true *) - exists rs0; exists fr. split. - apply Machabstr.exec_one; apply Machabstr.exec_Mcond_true. - rewrite <- (agree_eval_regs _ _ _ _ _ _ args AG) in H; auto. - apply transl_find_label; auto. - auto. + econstructor; split. + apply plus_one; apply exec_Mcond_true. + rewrite <- (agree_eval_regs _ _ _ _ _ _ args AG) in H; eauto. + apply transl_find_label; eauto. + econstructor; eauto. + eapply find_label_incl; eauto. (* Lcond, false *) - exists rs0; exists fr. split. - apply Machabstr.exec_one; apply Machabstr.exec_Mcond_false. + econstructor; split. + apply plus_one; apply exec_Mcond_false. rewrite <- (agree_eval_regs _ _ _ _ _ _ args AG) in H; auto. - auto. - - (* refl *) - exists rs0; exists fr. split. apply Machabstr.exec_refl. auto. - - (* one *) - apply H0; auto. - - (* trans *) - generalize (H0 tf rs fr parent rs0 TRANSL WTF AG INCL). - intros [rs' [fr' [A B]]]. - assert (INCL': incl b2 (fn_code f)). eapply exec_instrs_incl; eauto. - generalize (H2 tf rs' fr' parent rs0 TRANSL WTF B INCL'). - intros [rs'' [fr'' [C D]]]. - exists rs''; exists fr''. split. - eapply Machabstr.exec_trans. eexact A. eexact C. auto. - auto. - - (* function *) + econstructor; eauto with coqlib. + + (* Lreturn *) + exploit restore_callee_save_correct; eauto. + intros [ls' [A [B C]]]. + econstructor; split. + eapply plus_right. eauto. + simpl shift_sp. econstructor; eauto. traceEq. + econstructor; eauto. + intros. symmetry. eapply agree_return_regs; eauto. + apply agree_callee_save_return_regs. + + (* internal function *) generalize TRANSL; clear TRANSL. unfold transf_fundef, transf_partial_fundef. - caseEq (transf_function f); try congruence. + caseEq (transf_function f); simpl; try congruence. intros tfn TRANSL EQ. inversion EQ; clear EQ; subst tf. inversion WTF as [|f' WTFN]. subst f'. - assert (X: forall link ra, - exists rs' : regset, - Machabstr.exec_function_body tge tfn parent link ra rs0 m t rs' (free m2 stk) /\ - (forall r : mreg, - In (R r) temporaries \/ In (R r) destroyed_at_call -> rs' r = rs2 (R r)) /\ - (forall r : mreg, - In r int_callee_save_regs \/ In r float_callee_save_regs -> rs' r = rs0 r)). - intros. set (sp := Vptr stk Int.zero) in *. set (tsp := shift_sp tfn sp). set (fe := make_env (function_bounds f)). - assert (low (init_frame tfn) = -fe.(fe_size)). - simpl low. rewrite (unfold_transf_function _ _ TRANSL). + assert (fr_low (init_frame tfn) = - fe.(fe_size)). + simpl fr_low. rewrite (unfold_transf_function _ _ TRANSL). reflexivity. - assert (exists fr1, set_slot (init_frame tfn) Tint 0 link fr1). - apply set_slot_ok. reflexivity. omega. rewrite H2. generalize (size_pos f). - unfold fe. simpl typesize. omega. - elim H3; intros fr1 SET1; clear H3. - assert (high fr1 = 0). - inversion SET1. reflexivity. - assert (low fr1 = -fe.(fe_size)). - inversion SET1. rewrite <- H2. reflexivity. - assert (exists fr2, set_slot fr1 Tint 12 ra fr2). - apply set_slot_ok. auto. omega. rewrite H4. generalize (size_pos f). - unfold fe. simpl typesize. omega. - elim H5; intros fr2 SET2; clear H5. - assert (high fr2 = 0). - inversion SET2. simpl. auto. - assert (low fr2 = -fe.(fe_size)). - inversion SET2. rewrite <- H4. reflexivity. - assert (UNDEF: forall idx, index_valid f idx -> index_val f idx fr2 = Vundef). - intros. - assert (get_slot fr2 (type_of_index idx) (offset_of_index fe idx) Vundef). - generalize (offset_of_index_valid _ _ H7). fold fe. intros [XX YY]. - eapply slot_gso; eauto. - eapply slot_gso; eauto. - apply slot_gi. omega. omega. - simpl typesize. omega. simpl typesize. omega. - inversion H8. symmetry. exact H11. - generalize (save_callee_save_correct f tfn TRANSL - tsp parent - (transl_code (make_env (function_bounds f)) f.(fn_code)) - rs0 fr2 m1 rs AG1 AG2 H5 H6 UNDEF). + assert (UNDEF: forall idx, index_valid f idx -> index_val f idx (init_frame tfn) = Vundef). + intros. + assert (get_slot (init_frame tfn) (type_of_index idx) (offset_of_index fe idx) Vundef). + generalize (offset_of_index_valid _ _ H1). fold fe. intros [XX YY]. + apply slot_gi; auto. omega. + inv H2; auto. + exploit save_callee_save_correct; eauto. intros [fr [EXP AG]]. - generalize (H1 tfn rs0 fr parent rs0 TRANSL WTFN AG (incl_refl _)). - intros [rs' [fr' [EXB AG']]]. - generalize (restore_callee_save_correct f tfn TRANSL tsp parent - (Mreturn :: transl_code (make_env (function_bounds f)) b) - fr' m2 rs0 rs2 rs' AG'). - intros [rs'' [EXX [REGS1 REGS2]]]. - exists rs''. split. eapply Machabstr.exec_funct_body. - rewrite (unfold_transf_function f tfn TRANSL); eexact H. - eexact SET1. eexact SET2. - replace (Mach.fn_code tfn) with - (transl_body f (make_env (function_bounds f))). - replace (Vptr stk (Int.repr (- fn_framesize tfn))) with tsp. - eapply Machabstr.exec_trans. eexact EXP. - eapply Machabstr.exec_trans. eexact EXB. eexact EXX. - reflexivity. traceEq. - unfold tsp, shift_sp, sp. unfold Val.add. - rewrite Int.add_commut. rewrite Int.add_zero. auto. - rewrite (unfold_transf_function f tfn TRANSL). simpl. auto. - split. intros. rewrite REGS2. symmetry; eapply agree_reg; eauto. - apply int_callee_save_not_destroyed; auto. - apply float_callee_save_not_destroyed; auto. - auto. - generalize (X Vzero Vzero). intros [rs' [EX [REGS1 REGS2]]]. - exists rs'. split. - constructor. intros. - generalize (X link ra). intros [rs'' [EX' [REGS1' REGS2']]]. - assert (rs' = rs''). - apply (@Regmap.exten val). intro r. - elim (register_classification r); intro. - rewrite REGS1'. apply REGS1. auto. auto. - rewrite REGS2'. apply REGS2. auto. auto. - rewrite H4. auto. - split; auto. + econstructor; split. + eapply plus_left. + eapply exec_function_internal; eauto. + rewrite (unfold_transf_function f tfn TRANSL); simpl; eexact H. + replace (Mach.fn_code tfn) with + (transl_body f (make_env (function_bounds f))). + replace (Vptr stk (Int.repr (- fn_framesize tfn))) with tsp. + unfold transl_body. eexact EXP. + unfold tsp, shift_sp, sp. unfold Val.add. + rewrite Int.add_commut. rewrite Int.add_zero. auto. + rewrite (unfold_transf_function f tfn TRANSL). simpl. auto. + traceEq. + unfold tsp. econstructor; eauto with coqlib. + eapply agree_callee_save_agree; eauto. (* external function *) simpl in TRANSL. inversion TRANSL; subst tf. - inversion WTF. subst ef0. set (sg := ef_sig ef) in *. - exists (rs#(loc_result sg) <- res). - split. econstructor. eauto. - fold sg. rewrite H0. apply transl_external_arguments; assumption. - reflexivity. - split; intros. rewrite H1. - unfold Regmap.set. case (RegEq.eq r (loc_result sg)); intro. + inversion WTF. subst ef0. + exploit transl_external_arguments; eauto. intro EXTARGS. + econstructor; split. + apply plus_one. eapply exec_function_external; eauto. + econstructor; eauto. + intros. unfold Regmap.set. case (RegEq.eq r (loc_result (ef_sig ef))); intro. rewrite e. rewrite Locmap.gss; auto. rewrite Locmap.gso; auto. red; auto. - apply Regmap.gso. red; intro; subst r. - elim (Conventions.loc_result_not_callee_save _ H2). + apply agree_callee_save_set_result; auto. + + (* return *) + inv STACKS. + econstructor; split. + apply plus_one. apply exec_return. + econstructor; eauto. simpl in AG2. + eapply agree_frame_agree; eauto. Qed. -End PRESERVATION. +Lemma transf_initial_states: + forall st1, Linear.initial_state prog st1 -> + exists st2, Machabstr.initial_state tprog st2 /\ match_states st1 st2. +Proof. + intros. inversion H. + exploit function_ptr_translated; eauto. intros [tf [FIND TR]]. + econstructor; split. + econstructor. + rewrite (transform_partial_program_main _ _ TRANSF). + rewrite symbols_preserved. eauto. + eauto. + rewrite (Genv.init_mem_transf_partial _ _ TRANSF). + econstructor; eauto. constructor. + eapply Genv.find_funct_ptr_prop; eauto. + intros. + replace (size_arguments (Linear.funsig f)) with 14 in H5. + elimtype False. generalize (typesize_pos ty). omega. + rewrite H2; auto. + simpl; red; auto. +Qed. -Theorem transl_program_correct: - forall (p: Linear.program) (tp: Mach.program) (t: trace) (r: val), - wt_program p -> - transf_program p = Some tp -> - Linear.exec_program p t r -> - Machabstr.exec_program tp t r. -Proof. - intros p tp t r WTP TRANSF - [fptr [f [ls' [m [FINDSYMB [FINDFUNC [SIG [EXEC RES]]]]]]]]. - assert (WTF: wt_fundef f). - apply (Genv.find_funct_ptr_prop wt_fundef WTP FINDFUNC). - set (ls := Locmap.init Vundef) in *. - set (rs := Regmap.init Vundef). - set (fr := empty_frame). - assert (AG1: forall r, rs r = ls (R r)). - intros; reflexivity. - assert (AG2: forall ofs ty, - 6 <= ofs -> - ofs + typesize ty <= size_arguments (funsig f) -> - get_slot fr ty (Int.signed (Int.repr (4 * ofs))) (ls (S (Outgoing ofs ty)))). - rewrite SIG. unfold size_arguments, sig_args, size_arguments_rec. - intros. generalize (typesize_pos ty). - intro. omegaContradiction. - generalize (function_ptr_translated p tp TRANSF f _ FINDFUNC). - intros [tf [TFIND TRANSL]]. - generalize (transf_function_correct p tp TRANSF WTP _ _ _ _ _ _ EXEC - tf rs fr TRANSL WTF AG1 AG2). - intros [rs' [A [B C]]]. - red. exists fptr; exists tf; exists rs'; exists m. - split. rewrite (symbols_preserved p tp TRANSF). - rewrite (transform_partial_program_main transf_fundef p TRANSF). - assumption. - split. assumption. - split. replace (Genv.init_mem tp) with (Genv.init_mem p). - exact A. symmetry. apply Genv.init_mem_transf_partial with transf_fundef. - exact TRANSF. - rewrite <- RES. replace R3 with (loc_result (funsig f)). - apply B. right. apply loc_result_acceptable. - rewrite SIG; reflexivity. +Lemma transf_final_states: + forall st1 st2 r, + match_states st1 st2 -> Linear.final_state st1 r -> Machabstr.final_state st2 r. +Proof. + intros. inv H0. inv H. inv STACKS. econstructor. rewrite AG1; auto. +Qed. + +Theorem transf_program_correct: + forall (beh: program_behavior), + Linear.exec_program prog beh -> Machabstr.exec_program tprog beh. +Proof. + unfold Linear.exec_program, Machabstr.exec_program; intros. + eapply simulation_plus_preservation; eauto. + eexact transf_initial_states. + eexact transf_final_states. + eexact transf_step_correct. Qed. + +End PRESERVATION. diff --git a/backend/Stackingtyping.v b/backend/Stackingtyping.v index beb28e29..fa8a3e2e 100644 --- a/backend/Stackingtyping.v +++ b/backend/Stackingtyping.v @@ -2,6 +2,7 @@ Require Import Coqlib. Require Import Maps. +Require Import Errors. Require Import Integers. Require Import AST. Require Import Op. @@ -11,11 +12,12 @@ Require Import Linear. Require Import Lineartyping. Require Import Mach. Require Import Machtyping. +Require Import Bounds. Require Import Stacking. Require Import Stackingproof. (** We show that the Mach code generated by the [Stacking] pass - is well-typed if the original Linear code is. *) + is well-typed if the original LTLin code is. *) Definition wt_instrs (k: Mach.code) : Prop := forall i, In i k -> wt_instr i. @@ -33,17 +35,7 @@ Section TRANSL_FUNCTION. Variable f: Linear.function. Let fe := make_env (function_bounds f). Variable tf: Mach.function. -Hypothesis TRANSF_F: transf_function f = Some tf. - -Lemma wt_Msetstack': - forall idx ty r, - mreg_type r = ty -> index_valid f idx -> - wt_instr (Msetstack r (Int.repr (offset_of_index fe idx)) ty). -Proof. - intros. constructor. auto. - unfold fe. rewrite (offset_of_index_no_overflow f tf TRANSF_F); auto. - generalize (offset_of_index_valid f idx H0). tauto. -Qed. +Hypothesis TRANSF_F: transf_function f = OK tf. Lemma wt_fold_right: forall (A: Set) (f: A -> code -> code) (k: code) (l: list A), @@ -58,51 +50,57 @@ Proof. auto. Qed. -Lemma wt_save_int_callee_save: - forall cs k, - In cs int_callee_save_regs -> wt_instrs k -> - wt_instrs (save_int_callee_save fe cs k). +Lemma wt_save_callee_save_int: + forall k, + wt_instrs k -> + wt_instrs (save_callee_save_int fe k). Proof. - intros. unfold save_int_callee_save. - case (zlt (index_int_callee_save cs) (fe_num_int_callee_save fe)); intro. + intros. unfold save_callee_save_int, save_callee_save_regs. + apply wt_fold_right; auto. + intros. unfold save_callee_save_reg. + case (zlt (index_int_callee_save x) (fe_num_int_callee_save fe)); intro. apply wt_instrs_cons; auto. - apply wt_Msetstack'. apply int_callee_save_type; auto. - apply index_saved_int_valid. auto. exact z. + apply wt_Msetstack. apply int_callee_save_type; auto. auto. Qed. -Lemma wt_save_float_callee_save: - forall cs k, - In cs float_callee_save_regs -> wt_instrs k -> - wt_instrs (save_float_callee_save fe cs k). +Lemma wt_save_callee_save_float: + forall k, + wt_instrs k -> + wt_instrs (save_callee_save_float fe k). Proof. - intros. unfold save_float_callee_save. - case (zlt (index_float_callee_save cs) (fe_num_float_callee_save fe)); intro. + intros. unfold save_callee_save_float, save_callee_save_regs. + apply wt_fold_right; auto. + intros. unfold save_callee_save_reg. + case (zlt (index_float_callee_save x) (fe_num_float_callee_save fe)); intro. apply wt_instrs_cons; auto. - apply wt_Msetstack'. apply float_callee_save_type; auto. - apply index_saved_float_valid. auto. exact z. + apply wt_Msetstack. apply float_callee_save_type; auto. auto. Qed. -Lemma wt_restore_int_callee_save: - forall cs k, - In cs int_callee_save_regs -> wt_instrs k -> - wt_instrs (restore_int_callee_save fe cs k). +Lemma wt_restore_callee_save_int: + forall k, + wt_instrs k -> + wt_instrs (restore_callee_save_int fe k). Proof. - intros. unfold restore_int_callee_save. - case (zlt (index_int_callee_save cs) (fe_num_int_callee_save fe)); intro. + intros. unfold restore_callee_save_int, restore_callee_save_regs. + apply wt_fold_right; auto. + intros. unfold restore_callee_save_reg. + case (zlt (index_int_callee_save x) (fe_num_int_callee_save fe)); intro. apply wt_instrs_cons; auto. constructor. apply int_callee_save_type; auto. auto. Qed. -Lemma wt_restore_float_callee_save: - forall cs k, - In cs float_callee_save_regs -> wt_instrs k -> - wt_instrs (restore_float_callee_save fe cs k). +Lemma wt_restore_callee_save_float: + forall k, + wt_instrs k -> + wt_instrs (restore_callee_save_float fe k). Proof. - intros. unfold restore_float_callee_save. - case (zlt (index_float_callee_save cs) (fe_num_float_callee_save fe)); intro. + intros. unfold restore_callee_save_float, restore_callee_save_regs. + apply wt_fold_right; auto. + intros. unfold restore_callee_save_reg. + case (zlt (index_float_callee_save x) (fe_num_float_callee_save fe)); intro. apply wt_instrs_cons; auto. constructor. apply float_callee_save_type; auto. auto. @@ -113,9 +111,7 @@ Lemma wt_save_callee_save: wt_instrs k -> wt_instrs (save_callee_save fe k). Proof. intros. unfold save_callee_save. - apply wt_fold_right. exact wt_save_int_callee_save. - apply wt_fold_right. exact wt_save_float_callee_save. - auto. + apply wt_save_callee_save_int. apply wt_save_callee_save_float. auto. Qed. Lemma wt_restore_callee_save: @@ -123,37 +119,34 @@ Lemma wt_restore_callee_save: wt_instrs k -> wt_instrs (restore_callee_save fe k). Proof. intros. unfold restore_callee_save. - apply wt_fold_right. exact wt_restore_int_callee_save. - apply wt_fold_right. exact wt_restore_float_callee_save. - auto. + apply wt_restore_callee_save_int. apply wt_restore_callee_save_float. auto. Qed. Lemma wt_transl_instr: forall instr k, + In instr f.(Linear.fn_code) -> Lineartyping.wt_instr f instr -> wt_instrs k -> wt_instrs (transl_instr fe instr k). Proof. - intros. destruct instr; unfold transl_instr; inversion H. + intros. + generalize (instr_is_within_bounds f instr H H0); intro BND. + destruct instr; unfold transl_instr; inv H0; simpl in BND. (* getstack *) - destruct s; simpl in H3; apply wt_instrs_cons; auto; + destruct BND. + destruct s; simpl in *; apply wt_instrs_cons; auto; constructor; auto. (* setstack *) - destruct s; simpl in H3; simpl in H4. - apply wt_instrs_cons; auto. apply wt_Msetstack'. auto. - apply index_local_valid. auto. + destruct s. + apply wt_instrs_cons; auto. apply wt_Msetstack. auto. auto. - apply wt_instrs_cons; auto. apply wt_Msetstack'. auto. - apply index_arg_valid. auto. + apply wt_instrs_cons; auto. apply wt_Msetstack. auto. (* op, move *) simpl. apply wt_instrs_cons. constructor; auto. auto. - (* op, undef *) - simpl. apply wt_instrs_cons. constructor. auto. (* op, others *) apply wt_instrs_cons; auto. constructor. destruct o; simpl; congruence. - destruct o; simpl; congruence. rewrite H6. destruct o; reflexivity || congruence. (* load *) apply wt_instrs_cons; auto. @@ -162,10 +155,14 @@ Proof. (* store *) apply wt_instrs_cons; auto. constructor; auto. - rewrite H3. destruct a; reflexivity. + rewrite H4. destruct a; reflexivity. (* call *) apply wt_instrs_cons; auto. constructor; auto. + (* tailcall *) + apply wt_restore_callee_save. apply wt_instrs_cons; auto. + constructor; auto. + destruct s0; auto. rewrite H5; auto. (* alloc *) apply wt_instrs_cons; auto. constructor. (* label *) @@ -185,7 +182,7 @@ End TRANSL_FUNCTION. Lemma wt_transf_function: forall f tf, - transf_function f = Some tf -> + transf_function f = OK tf -> Lineartyping.wt_function f -> wt_function tf. Proof. @@ -201,7 +198,7 @@ Proof. constructor. change (wt_instrs (fn_code tf)). rewrite H1; simpl; unfold transl_body. - apply wt_save_callee_save with tf; auto. + apply wt_save_callee_save; auto. unfold transl_code. apply wt_fold_right. intros. eapply wt_transl_instr; eauto. red; intros. elim H3. @@ -213,20 +210,20 @@ Qed. Lemma wt_transf_fundef: forall f tf, Lineartyping.wt_fundef f -> - transf_fundef f = Some tf -> + transf_fundef f = OK tf -> wt_fundef tf. Proof. intros f tf WT. inversion WT; subst. simpl; intros; inversion H. constructor. unfold transf_fundef, transf_partial_fundef. - caseEq (transf_function f0); try congruence. + caseEq (transf_function f0); simpl; try congruence. intros tfn TRANSF EQ. inversion EQ; subst tf. constructor; eapply wt_transf_function; eauto. Qed. Lemma program_typing_preserved: forall (p: Linear.program) (tp: Mach.program), - transf_program p = Some tp -> + transf_program p = OK tp -> Lineartyping.wt_program p -> Machtyping.wt_program tp. Proof. diff --git a/backend/Tunneling.v b/backend/Tunneling.v index 4fbdc9fd..15f4676d 100644 --- a/backend/Tunneling.v +++ b/backend/Tunneling.v @@ -30,8 +30,8 @@ Require Import LTL. dead code (as the "goto L3" in the example above). *) -Definition is_goto_block (b: option block) : option node := - match b with Some (Bgoto s) => Some s | _ => None end. +Definition is_goto_instr (b: option instruction) : option node := + match b with Some (Lnop s) => Some s | _ => None end. (** [branch_target f pc] returns the node of the CFG that is at the end of the branch sequence starting at [pc]. If the instruction @@ -70,7 +70,7 @@ Fixpoint branch_target_rec (f: LTL.function) (pc: node) (count: nat) match count with | Datatypes.O => None | Datatypes.S count' => - match is_goto_block f.(fn_code)!pc with + match is_goto_instr f.(fn_code)!pc with | Some s => branch_target_rec f s count' | None => Some pc end @@ -86,34 +86,32 @@ Definition branch_target (f: LTL.function) (pc: node) := replacing the destinations of the [Bgoto] and [Bcond] instructions with their final target, as computed by [branch_target]. *) -Fixpoint tunnel_block (f: LTL.function) (b: block) {struct b} : block := +Definition tunnel_instr (f: LTL.function) (b: instruction) : instruction := match b with - | Bgetstack s r b => - Bgetstack s r (tunnel_block f b) - | Bsetstack r s b => - Bsetstack r s (tunnel_block f b) - | Bop op args res b => - Bop op args res (tunnel_block f b) - | Bload chunk addr args dst b => - Bload chunk addr args dst (tunnel_block f b) - | Bstore chunk addr args src b => - Bstore chunk addr args src (tunnel_block f b) - | Bcall sig ros b => - Bcall sig ros (tunnel_block f b) - | Balloc b => - Balloc (tunnel_block f b) - | Bgoto s => - Bgoto (branch_target f s) - | Bcond cond args s1 s2 => - Bcond cond args (branch_target f s1) (branch_target f s2) - | Breturn => - Breturn + | Lnop s => + Lnop (branch_target f s) + | Lop op args res s => + Lop op args res (branch_target f s) + | Lload chunk addr args dst s => + Lload chunk addr args dst (branch_target f s) + | Lstore chunk addr args src s => + Lstore chunk addr args src (branch_target f s) + | Lcall sig ros args res s => + Lcall sig ros args res (branch_target f s) + | Ltailcall sig ros args => + Ltailcall sig ros args + | Lalloc arg res s => + Lalloc arg res (branch_target f s) + | Lcond cond args s1 s2 => + Lcond cond args (branch_target f s1) (branch_target f s2) + | Lreturn or => + Lreturn or end. Lemma wf_tunneled_code: forall (f: LTL.function), - let tc := PTree.map (fun pc b => tunnel_block f b) (fn_code f) in - forall (pc: node), Plt pc (Psucc (fn_entrypoint f)) \/ tc!pc = None. + let tc := PTree.map (fun pc b => tunnel_instr f b) (fn_code f) in + forall (pc: node), Plt pc (fn_nextpc f) \/ tc!pc = None. Proof. intros. elim (fn_code_wf f pc); intro. left; auto. right; unfold tc. @@ -123,9 +121,11 @@ Qed. Definition tunnel_function (f: LTL.function) : LTL.function := mkfunction (fn_sig f) + (fn_params f) (fn_stacksize f) - (PTree.map (fun pc b => tunnel_block f b) (fn_code f)) - (fn_entrypoint f) + (PTree.map (fun pc b => tunnel_instr f b) (fn_code f)) + (branch_target f (fn_entrypoint f)) + (fn_nextpc f) (wf_tunneled_code f). Definition tunnel_fundef (f: LTL.fundef) : LTL.fundef := diff --git a/backend/Tunnelingproof.v b/backend/Tunnelingproof.v index eae53cac..3777eaa9 100644 --- a/backend/Tunnelingproof.v +++ b/backend/Tunnelingproof.v @@ -7,6 +7,7 @@ Require Import Values. Require Import Mem. Require Import Events. Require Import Globalenvs. +Require Import Smallstep. Require Import Op. Require Import Locations. Require Import LTL. @@ -14,51 +15,85 @@ Require Import Tunneling. (** * Properties of branch target computation *) -Lemma is_goto_block_correct: +Lemma is_goto_instr_correct: forall b s, - is_goto_block b = Some s -> b = Some (Bgoto s). + is_goto_instr b = Some s -> b = Some (Lnop s). Proof. - unfold is_goto_block; intros. - destruct b. destruct b; discriminate || congruence. - discriminate. + unfold is_goto_instr; intros. + destruct b; try discriminate. + destruct i; discriminate || congruence. Qed. Lemma branch_target_rec_1: forall f pc n, branch_target_rec f pc n = Some pc \/ branch_target_rec f pc n = None - \/ exists pc', f.(fn_code)!pc = Some(Bgoto pc'). + \/ exists pc', f.(fn_code)!pc = Some(Lnop pc'). Proof. intros. destruct n; simpl. right; left; auto. - caseEq (is_goto_block f.(fn_code)!pc); intros. - right; right. exists n0. apply is_goto_block_correct; auto. + caseEq (is_goto_instr f.(fn_code)!pc); intros. + right; right. exists n0. apply is_goto_instr_correct; auto. left; auto. Qed. Lemma branch_target_rec_2: forall f n pc1 pc2 pc3, - f.(fn_code)!pc1 = Some (Bgoto pc2) -> + f.(fn_code)!pc1 = Some (Lnop pc2) -> branch_target_rec f pc1 n = Some pc3 -> branch_target_rec f pc2 n = Some pc3. Proof. induction n. simpl. intros; discriminate. intros pc1 pc2 pc3 ATpc1 H. simpl in H. - unfold is_goto_block in H; rewrite ATpc1 in H. - simpl. caseEq (is_goto_block f.(fn_code)!pc2); intros. - apply IHn with pc2. apply is_goto_block_correct; auto. auto. + unfold is_goto_instr in H; rewrite ATpc1 in H. + simpl. caseEq (is_goto_instr f.(fn_code)!pc2); intros. + apply IHn with pc2. apply is_goto_instr_correct; auto. auto. destruct n; simpl in H. discriminate. rewrite H0 in H. auto. Qed. +(** Counting the number of consecutive gotos. *) + +Fixpoint count_goto_rec (f: LTL.function) (pc: node) (count: nat) + {struct count} : nat := + match count with + | Datatypes.O => Datatypes.O + | Datatypes.S count' => + match is_goto_instr f.(fn_code)!pc with + | Some s => Datatypes.S (count_goto_rec f s count') + | None => Datatypes.O + end + end. + +Definition count_goto (f: LTL.function) (pc: node) : nat := + count_goto_rec f pc 10%nat. + +Lemma count_goto_rec_prop: + forall f n pc1 pc2 pc3, + f.(fn_code)!pc1 = Some (Lnop pc2) -> + branch_target_rec f pc1 n = Some pc3 -> + (count_goto_rec f pc2 n < count_goto_rec f pc1 n)%nat. +Proof. + induction n. + simpl; intros. discriminate. + intros pc1 pc2 pc3 ATpc1 H. simpl in H. + unfold is_goto_instr in H; rewrite ATpc1 in H. + simpl. unfold is_goto_instr at 2. rewrite ATpc1. + caseEq (is_goto_instr f.(fn_code)!pc2); intros. + exploit (IHn pc2); eauto. apply is_goto_instr_correct; eauto. + omega. + omega. +Qed. + (** The following lemma captures the property of [branch_target] on which the proof of semantic preservation relies. *) Lemma branch_target_characterization: forall f pc, branch_target f pc = pc \/ - (exists pc', f.(fn_code)!pc = Some(Bgoto pc') - /\ branch_target f pc' = branch_target f pc). + (exists pc', f.(fn_code)!pc = Some(Lnop pc') + /\ branch_target f pc' = branch_target f pc + /\ count_goto f pc' < count_goto f pc)%nat. Proof. intros. unfold branch_target. generalize (branch_target_rec_1 f pc 10%nat). @@ -67,7 +102,8 @@ Proof. rewrite A. left; auto. caseEq (branch_target_rec f pc 10%nat). intros pcx BT. right. exists pc'. split. auto. - rewrite (branch_target_rec_2 _ _ _ _ _ AT BT). auto. + split. rewrite (branch_target_rec_2 _ _ _ _ _ AT BT). auto. + unfold count_goto. eapply count_goto_rec_prop; eauto. intro. left; auto. Qed. @@ -103,221 +139,233 @@ Proof. destruct f; reflexivity. Qed. -(** These are inversion lemmas, characterizing what happens in the LTL - semantics when executing [Bgoto] instructions or basic blocks. *) - -Lemma exec_instrs_Bgoto_inv: - forall sp b1 ls1 m1 t b2 ls2 m2, - exec_instrs ge sp b1 ls1 m1 t b2 ls2 m2 -> - forall s1, - b1 = Bgoto s1 -> t = E0 /\ b2 = b1 /\ ls2 = ls1 /\ m2 = m1. +Lemma find_function_translated: + forall ros ls f, + find_function ge ros ls = Some f -> + find_function tge ros ls = Some (tunnel_fundef f). Proof. - induction 1. - intros. tauto. - intros. subst b1. inversion H. - intros. generalize (IHexec_instrs1 s1 H2). intros [A [B [C D]]]. - subst t1 b2 rs2 m2. - generalize (IHexec_instrs2 s1 H2). intros [A [B [C D]]]. - subst t2 b3 rs3 m3. intuition. traceEq. + intros until f. destruct ros; simpl. + intro. apply functions_translated; auto. + rewrite symbols_preserved. destruct (Genv.find_symbol ge i). + apply function_ptr_translated; auto. + congruence. Qed. -Lemma exec_block_Bgoto_inv: - forall sp s ls1 m1 t out ls2 m2, - exec_block ge sp (Bgoto s) ls1 m1 t out ls2 m2 -> - t = E0 /\ out = Cont s /\ ls2 = ls1 /\ m2 = m1. -Proof. - intros. inversion H; - generalize (exec_instrs_Bgoto_inv _ _ _ _ _ _ _ _ H0 s (refl_equal _)); - intros [A [B [C D]]]; - try discriminate. - intuition congruence. -Qed. +(** The proof of semantic preservation is a simulation argument + based on diagrams of the following form: +<< + st1 --------------- st2 + | | + t| ?|t + | | + v v + st1'--------------- st2' +>> + The [match_states] predicate, defined below, captures the precondition + between states [st1] and [st2], as well as the postcondition between + [st1'] and [st2']. One transition in the source code (left) can correspond + to zero or one transition in the transformed code (right). The + "zero transition" case occurs when executing a [Lgoto] instruction + in the source code that has been removed by tunneling. + + In the definition of [match_states], note that only the control-flow + (in particular, the current program point [pc]) is changed: + the values of locations and the memory states are identical in the + original and transformed codes. *) -Lemma exec_blocks_Bgoto_inv: - forall c sp pc1 ls1 m1 t out ls2 m2 s, - exec_blocks ge c sp pc1 ls1 m1 t out ls2 m2 -> - c!pc1 = Some (Bgoto s) -> - (t = E0 /\ out = Cont pc1 /\ ls2 = ls1 /\ m2 = m1) - \/ exec_blocks ge c sp s ls1 m1 t out ls2 m2. +Definition tunneled_code (f: function) := + PTree.map (fun pc b => tunnel_instr f b) (fn_code f). + +Inductive match_stackframes: stackframe -> stackframe -> Prop := + | match_stackframes_intro: + forall res f sp ls0 pc, + match_stackframes + (Stackframe res f sp ls0 pc) + (Stackframe res (tunnel_function f) sp ls0 (branch_target f pc)). + +Inductive match_states: state -> state -> Prop := + | match_states_intro: + forall s f sp pc ls m ts, + list_forall2 match_stackframes s ts -> + match_states (State s f sp pc ls m) + (State ts (tunnel_function f) sp (branch_target f pc) ls m) + | match_states_call: + forall s f ls m ts, + list_forall2 match_stackframes s ts -> + match_states (Callstate s f ls m) + (Callstate ts (tunnel_fundef f) ls m) + | match_states_return: + forall s sig ls m ts, + list_forall2 match_stackframes s ts -> + match_states (Returnstate s sig ls m) + (Returnstate ts sig ls m). + +Lemma parent_locset_match: + forall s ts, list_forall2 match_stackframes s ts -> parent_locset ts = parent_locset s. Proof. - induction 1; intros. - left; tauto. - assert (b = Bgoto s). congruence. subst b. - generalize (exec_block_Bgoto_inv _ _ _ _ _ _ _ _ H0). - intros [A [B [C D]]]. subst t out rs' m'. - right. apply exec_blocks_refl. - elim (IHexec_blocks1 H2). - intros [A [B [C D]]]. - assert (pc2 = pc1). congruence. subst t1 rs2 m2 pc2. - replace t with t2. apply IHexec_blocks2; auto. traceEq. - intro. right. - eapply exec_blocks_trans; eauto. + induction 1; simpl; auto. inv H; auto. Qed. -(** The following [exec_*_prop] predicates state the correctness - of the tunneling transformation: for each LTL execution - in the original code (of an instruction, a sequence of instructions, - a basic block, a sequence of basic blocks, etc), there exists - a similar LTL execution in the tunneled code. - - Note that only the control-flow is changed: the values of locations - and the memory states are identical in the original and transformed - codes. *) +(** To preserve non-terminating behaviours, we show that the transformed + code cannot take an infinity of "zero transition" cases. + We use the following [measure] function over source states, + which decreases strictly in the "zero transition" case. *) -Definition tunnel_outcome (f: function) (out: outcome) := - match out with - | Cont pc => Cont (branch_target f pc) - | Return => Return +Definition measure (st: state) : nat := + match st with + | State s f sp pc ls m => count_goto f pc + | Callstate s f ls m => 0%nat + | Returnstate s sig ls m => 0%nat end. -Definition exec_instr_prop - (sp: val) (b1: block) (ls1: locset) (m1: mem) (t: trace) - (b2: block) (ls2: locset) (m2: mem) : Prop := - forall f, - exec_instr tge sp (tunnel_block f b1) ls1 m1 - t (tunnel_block f b2) ls2 m2. - -Definition exec_instrs_prop - (sp: val) (b1: block) (ls1: locset) (m1: mem) (t: trace) - (b2: block) (ls2: locset) (m2: mem) : Prop := - forall f, - exec_instrs tge sp (tunnel_block f b1) ls1 m1 - t (tunnel_block f b2) ls2 m2. - -Definition exec_block_prop - (sp: val) (b1: block) (ls1: locset) (m1: mem) (t: trace) - (out: outcome) (ls2: locset) (m2: mem) : Prop := - forall f, - exec_block tge sp (tunnel_block f b1) ls1 m1 - t (tunnel_outcome f out) ls2 m2. +Lemma branch_target_identity: + forall f pc, + match f.(fn_code)!pc with Some(Lnop _) => False | _ => True end -> + branch_target f pc = pc. +Proof. + intros. + destruct (branch_target_characterization f pc) as [A | [pc' [B C]]]. + auto. rewrite B in H. contradiction. +Qed. + +Lemma tunnel_function_lookup: + forall f pc i, + f.(fn_code)!pc = Some i -> + (tunnel_function f).(fn_code)!pc = Some (tunnel_instr f i). +Proof. + intros. simpl. rewrite PTree.gmap. rewrite H. auto. +Qed. -Definition tunneled_code (f: function) := - PTree.map (fun pc b => tunnel_block f b) (fn_code f). - -Definition exec_blocks_prop - (c: code) (sp: val) - (pc: node) (ls1: locset) (m1: mem) (t: trace) - (out: outcome) (ls2: locset) (m2: mem) : Prop := - forall f, - f.(fn_code) = c -> - exec_blocks tge (tunneled_code f) sp - (branch_target f pc) ls1 m1 - t (tunnel_outcome f out) ls2 m2. - -Definition exec_function_prop - (f: fundef) (ls1: locset) (m1: mem) (t: trace) - (ls2: locset) (m2: mem) : Prop := - exec_function tge (tunnel_fundef f) ls1 m1 t ls2 m2. - -Scheme exec_instr_ind5 := Minimality for LTL.exec_instr Sort Prop - with exec_instrs_ind5 := Minimality for LTL.exec_instrs Sort Prop - with exec_block_ind5 := Minimality for LTL.exec_block Sort Prop - with exec_blocks_ind5 := Minimality for LTL.exec_blocks Sort Prop - with exec_function_ind5 := Minimality for LTL.exec_function Sort Prop. - -(** The proof of semantic preservation is a structural induction - over the LTL evaluation derivation of the original program, - using the [exec_*_prop] predicates above as induction hypotheses. *) - -Lemma tunnel_function_correct: - forall f ls1 m1 t ls2 m2, - exec_function ge f ls1 m1 t ls2 m2 -> - exec_function_prop f ls1 m1 t ls2 m2. +Lemma tunnel_step_correct: + forall st1 t st2, step ge st1 t st2 -> + forall st1' (MS: match_states st1 st1'), + (exists st2', step tge st1' t st2' /\ match_states st2 st2') + \/ (measure st2 < measure st1 /\ t = E0 /\ match_states st2 st1')%nat. Proof. - apply (exec_function_ind5 ge - exec_instr_prop - exec_instrs_prop - exec_block_prop - exec_blocks_prop - exec_function_prop); - intros; red; intros; simpl. - (* getstack *) - constructor. - (* setstack *) - constructor. - (* op *) - constructor. rewrite <- H. apply eval_operation_preserved. - exact symbols_preserved. - (* load *) - apply exec_Bload with a. rewrite <- H. - apply eval_addressing_preserved. exact symbols_preserved. - auto. - (* store *) - apply exec_Bstore with a. rewrite <- H. - apply eval_addressing_preserved. exact symbols_preserved. - auto. - (* call *) - apply exec_Bcall with (tunnel_fundef f). - generalize H; unfold find_function; destruct ros. - intro. apply functions_translated; auto. - rewrite symbols_preserved. destruct (Genv.find_symbol ge i). - intro. apply function_ptr_translated; auto. congruence. - generalize (sig_preserved f). congruence. - apply H2. - (* alloc *) - eapply exec_Balloc; eauto. - (* instr_refl *) - apply exec_refl. - (* instr_one *) - apply exec_one. apply H0. - (* instr_trans *) - apply exec_trans with t1 (tunnel_block f b2) rs2 m2 t2; auto. - (* goto *) - apply exec_Bgoto. red in H0. simpl in H0. apply H0. - (* cond, true *) - eapply exec_Bcond_true. red in H0. simpl in H0. apply H0. auto. - (* cond, false *) - eapply exec_Bcond_false. red in H0. simpl in H0. apply H0. auto. + induction 1; intros; try inv MS. + (* Lnop *) + destruct (branch_target_characterization f pc) as [A | [pc1 [B [C D]]]]. + left; econstructor; split. + eapply exec_Lnop. rewrite A. + rewrite (tunnel_function_lookup _ _ _ H); simpl; auto. + econstructor; eauto. + assert (pc1 = pc') by congruence. subst pc1. + right. split. simpl. auto. split. auto. + rewrite <- C. econstructor; eauto. + (* Lop *) + rewrite (branch_target_identity f pc); [idtac | rewrite H; auto]. + left; econstructor; split. + eapply exec_Lop with (v := v); eauto. + rewrite (tunnel_function_lookup _ _ _ H); simpl; auto. + rewrite <- H0. apply eval_operation_preserved. exact symbols_preserved. + econstructor; eauto. + (* Lload *) + rewrite (branch_target_identity f pc); [idtac | rewrite H; auto]. + left; econstructor; split. + eapply exec_Lload; eauto. + rewrite (tunnel_function_lookup _ _ _ H); simpl; auto. + rewrite <- H0. apply eval_addressing_preserved. exact symbols_preserved. + econstructor; eauto. + (* Lstore *) + rewrite (branch_target_identity f pc); [idtac | rewrite H; auto]. + left; econstructor; split. + eapply exec_Lstore; eauto. + rewrite (tunnel_function_lookup _ _ _ H); simpl; auto. + rewrite <- H0. apply eval_addressing_preserved. exact symbols_preserved. + econstructor; eauto. + (* Lcall *) + unfold rs1. inv MS. + left; econstructor; split. + eapply exec_Lcall with (f' := tunnel_fundef f'); eauto. + rewrite (branch_target_identity f pc); [idtac | rewrite H; auto]. + rewrite (tunnel_function_lookup _ _ _ H); simpl. + rewrite sig_preserved. auto. + apply find_function_translated; auto. + rewrite sig_preserved; auto. fold rs1. + econstructor; eauto. + constructor; auto. + constructor; auto. + (* Ltailcall *) + unfold rs2, rs1 in *. inv MS. fold rs1. fold rs2. + left; econstructor; split. + eapply exec_Ltailcall with (f' := tunnel_fundef f'); eauto. + rewrite (branch_target_identity f pc); [idtac | rewrite H; auto]. + rewrite (tunnel_function_lookup _ _ _ H); simpl. + rewrite sig_preserved. auto. + apply find_function_translated; auto. + rewrite sig_preserved; auto. fold rs1. + rewrite (parent_locset_match _ _ H9). + econstructor; eauto. + (* Lalloc *) + rewrite (branch_target_identity f pc); [idtac | rewrite H; auto]. + left; exists (State ts (tunnel_function f) sp (branch_target f pc') rs3 m'); split. + unfold rs3, rs2, rs1; eapply exec_Lalloc; eauto. + rewrite (tunnel_function_lookup _ _ _ H); simpl; auto. + econstructor; eauto. + (* cond *) + rewrite (branch_target_identity f pc); [idtac | rewrite H; auto]. + left; econstructor; split. + eapply exec_Lcond_true; eauto. + rewrite (tunnel_function_lookup _ _ _ H); simpl; eauto. + econstructor; eauto. + rewrite (branch_target_identity f pc); [idtac | rewrite H; auto]. + left; econstructor; split. + eapply exec_Lcond_false; eauto. + rewrite (tunnel_function_lookup _ _ _ H); simpl; eauto. + econstructor; eauto. (* return *) - apply exec_Breturn. red in H0. simpl in H0. apply H0. - (* block_refl *) - apply exec_blocks_refl. - (* block_one *) - red in H1. - elim (branch_target_characterization f pc). - intro. rewrite H3. apply exec_blocks_one with (tunnel_block f b). - unfold tunneled_code. rewrite PTree.gmap. rewrite H2; rewrite H. - reflexivity. apply H1. - intros [pc' [ATpc BTS]]. - assert (b = Bgoto pc'). congruence. subst b. - generalize (exec_block_Bgoto_inv _ _ _ _ _ _ _ _ H0). - intros [A [B [C D]]]. subst t out rs' m'. - simpl. rewrite BTS. apply exec_blocks_refl. - (* blocks_trans *) - apply exec_blocks_trans with t1 (branch_target f pc2) rs2 m2 t2. - exact (H0 f H4). exact (H2 f H4). auto. + rewrite (branch_target_identity f pc); [idtac | rewrite H; auto]. + left; econstructor; split. + eapply exec_Lreturn; eauto. + rewrite (tunnel_function_lookup _ _ _ H); simpl; eauto. + simpl. rewrite (parent_locset_match _ _ H7). constructor; auto. (* internal function *) - econstructor. eexact H. - change (fn_code (tunnel_function f)) with (tunneled_code f). - simpl. - elim (branch_target_characterization f (fn_entrypoint f)). - intro BT. rewrite <- BT. exact (H1 f (refl_equal _)). - intros [pc [ATpc BT]]. - apply exec_blocks_trans with - E0 (branch_target f (fn_entrypoint f)) (call_regs rs) m1 t. - eapply exec_blocks_one. - unfold tunneled_code. rewrite PTree.gmap. rewrite ATpc. - simpl. reflexivity. - apply exec_Bgoto. rewrite BT. apply exec_refl. - exact (H1 f (refl_equal _)). traceEq. + simpl. left; econstructor; split. + eapply exec_function_internal; eauto. + simpl. econstructor; eauto. (* external function *) - econstructor; eauto. + simpl. left; econstructor; split. + eapply exec_function_external; eauto. + simpl. econstructor; eauto. + (* return *) + inv H4. inv H1. + left; econstructor; split. + eapply exec_return; eauto. + fold rs1. constructor. auto. Qed. -End PRESERVATION. +Lemma transf_initial_states: + forall st1, initial_state p st1 -> + exists st2, initial_state tp st2 /\ match_states st1 st2. +Proof. + intros. inversion H. + exists (Callstate nil (tunnel_fundef f) (Locmap.init Vundef) (Genv.init_mem tp)); split. + econstructor; eauto. + change (prog_main tp) with (prog_main p). + rewrite symbols_preserved. eauto. + apply function_ptr_translated; auto. + rewrite <- H2. apply sig_preserved. + replace (Genv.init_mem tp) with (Genv.init_mem p). + constructor. constructor. auto. + symmetry. unfold tp, tunnel_program. apply Genv.init_mem_transf. +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 H6. constructor. auto. +Qed. Theorem transf_program_correct: - forall (p: program) (t: trace) (r: val), - exec_program p t r -> - exec_program (tunnel_program p) t r. + forall (beh: program_behavior), + exec_program p beh -> exec_program tp beh. Proof. - intros p t r [b [f [ls [m [FIND1 [FIND2 [SIG [EX RES]]]]]]]]. - red. exists b; exists (tunnel_fundef f); exists ls; exists m. - split. change (prog_main (tunnel_program p)) with (prog_main p). - rewrite <- FIND1. apply symbols_preserved. - split. apply function_ptr_translated. assumption. - split. generalize (sig_preserved f). congruence. - split. apply tunnel_function_correct. - unfold tunnel_program. rewrite Genv.init_mem_transf. auto. - rewrite sig_preserved. exact RES. + unfold exec_program; intros. + eapply simulation_opt_preservation; eauto. + eexact transf_initial_states. + eexact transf_final_states. + eexact tunnel_step_correct. Qed. + +End PRESERVATION. diff --git a/backend/Tunnelingtyping.v b/backend/Tunnelingtyping.v index 6281afa1..c611067c 100644 --- a/backend/Tunnelingtyping.v +++ b/backend/Tunnelingtyping.v @@ -11,26 +11,65 @@ Require Import Locations. Require Import LTL. Require Import LTLtyping. Require Import Tunneling. +Require Import Tunnelingproof. (** Tunneling preserves typing. *) -Lemma wt_tunnel_block: - forall f b, - wt_block f b -> - wt_block (tunnel_function f) (tunnel_block f b). +Lemma branch_target_rec_valid: + forall f, wt_function f -> + forall count pc pc', + branch_target_rec f pc count = Some pc' -> + valid_successor f pc -> + valid_successor f pc'. Proof. - induction 1; simpl; econstructor; eauto. + induction count; simpl. + intros; discriminate. + intros until pc'. caseEq (is_goto_instr (fn_code f)!pc); intros. + generalize (is_goto_instr_correct _ _ H0). intro. + eapply IHcount; eauto. + generalize (wt_instrs _ H _ _ H3); intro WTI; inv WTI. auto. + inv H1; auto. +Qed. + +Lemma tunnel_valid_successor: + forall f pc, + valid_successor f pc -> valid_successor (tunnel_function f) pc. +Proof. + intros. destruct H as [i AT]. + unfold valid_successor; simpl. rewrite PTree.gmap. rewrite AT. + simpl. exists (tunnel_instr f i); auto. +Qed. + +Lemma branch_target_valid: + forall f pc, + wt_function f -> + valid_successor f pc -> + valid_successor (tunnel_function f) (branch_target f pc). +Proof. + intros. apply tunnel_valid_successor. + unfold branch_target. caseEq (branch_target_rec f pc 10); intros. + eapply branch_target_rec_valid; eauto. + auto. +Qed. + +Lemma wt_tunnel_instr: + forall f i, + wt_function f -> + wt_instr f i -> wt_instr (tunnel_function f) (tunnel_instr f i). +Proof. + intros; inv H0; simpl; econstructor; eauto; + eapply branch_target_valid; eauto. Qed. Lemma wt_tunnel_function: forall f, wt_function f -> wt_function (tunnel_function f). Proof. - unfold wt_function; intros until b. - simpl. rewrite PTree.gmap. unfold option_map. - caseEq (fn_code f)!pc. intros b0 AT EQ. - injection EQ; intros; subst b. - apply wt_tunnel_block. eauto. - intros; discriminate. + intros. inversion H. constructor; simpl; auto. + intros until instr. rewrite PTree.gmap. unfold option_map. + caseEq (fn_code f)!pc. intros b0 AT EQ. inv EQ. + apply wt_tunnel_instr; eauto. + congruence. + eapply branch_target_valid; eauto. Qed. Lemma wt_tunnel_fundef: diff --git a/caml/CMlexer.mll b/caml/CMlexer.mll index 49d0dbdd..ae71e0c1 100644 --- a/caml/CMlexer.mll +++ b/caml/CMlexer.mll @@ -30,8 +30,10 @@ rule token = parse | "|" { BAR } | "||" { BARBAR } | "^" { CARET } + | "case" { CASE } | ":" { COLON } | "," { COMMA } + | "default" { DEFAULT } | "$" { DOLLAR } | "else" { ELSE } | "=" { EQUAL } @@ -75,6 +77,7 @@ rule token = parse | "let" { LET } | "loop" { LOOP } | "(" { LPAREN } + | "match" { MATCH } | "-" { MINUS } | "->" { MINUSGREATER } | "-f" { MINUSF } diff --git a/caml/CMparser.mly b/caml/CMparser.mly index d9a81874..0db0af2b 100644 --- a/caml/CMparser.mly +++ b/caml/CMparser.mly @@ -8,16 +8,67 @@ open BinPos open BinInt open Integers open AST -open Op open Cminor let intconst n = - Eop(Ointconst(coqint_of_camlint n), Enil) + Econst(Ointconst(coqint_of_camlint n)) let andbool e1 e2 = - Cmconstr.conditionalexpr e1 e2 (intconst 0l) + Econdition(e1, e2, intconst 0l) let orbool e1 e2 = - Cmconstr.conditionalexpr e1 (intconst 1l) e2 + Econdition(e1, intconst 1l, e2) + +let exitnum n = nat_of_camlint(Int32.pred n) + +let mkswitch expr (cases, dfl) = + let rec mktable = function + | [] -> Coq_nil + | (key, exit) :: rem -> + Coq_cons(Coq_pair(coqint_of_camlint key, exitnum exit), mktable rem) in + Sswitch(expr, mktable cases, exitnum dfl) + +(*** + match (a) { case 0: s0; case 1: s1; case 2: s2; } ---> + + block { + block { + block { + block { + switch(a) { case 0: exit 0; case 1: exit 1; default: exit 2; } + }; s0; exit 2; + }; s1; exit 1; + }; s2; + } + + Note that matches are assumed to be exhaustive +***) + +let mkmatch_aux expr cases = + let ncases = Int32.of_int (List.length cases) in + let rec mktable n = function + | [] -> assert false + | [key, action] -> Coq_nil + | (key, action) :: rem -> + Coq_cons(Coq_pair(coqint_of_camlint key, nat_of_camlint n), + mktable (Int32.succ n) rem) in + let sw = + Sswitch(expr, mktable 0l cases, nat_of_camlint (Int32.pred ncases)) in + let rec mkblocks body n = function + | [] -> assert false + | [key, action] -> + Sblock(Sseq(body, action)) + | (key, action) :: rem -> + mkblocks + (Sblock(Sseq(body, Sseq(action, Sexit (nat_of_camlint n))))) + (Int32.pred n) + rem in + mkblocks (Sblock sw) (Int32.pred ncases) cases + +let mkmatch expr cases = + match cases with + | [] -> Sskip (* ??? *) + | [key, action] -> action + | _ -> mkmatch_aux expr cases %} @@ -32,8 +83,10 @@ let orbool e1 e2 = %token BAR %token BARBAR %token CARET +%token CASE %token COLON %token COMMA +%token DEFAULT %token DOLLAR %token ELSE %token EQUAL @@ -81,6 +134,7 @@ let orbool e1 e2 = %token LET %token LOOP %token LPAREN +%token MATCH %token MINUS %token MINUSF %token MINUSGREATER @@ -200,7 +254,7 @@ parameter_list: stack_declaration: /* empty */ { Z0 } - | STACK INTLIT { z_of_camlint $2 } + | STACK INTLIT SEMICOLON { z_of_camlint $2 } ; var_declarations: @@ -217,14 +271,18 @@ var_declaration: stmt: expr SEMICOLON { Sexpr $1 } | IDENT EQUAL expr SEMICOLON { Sassign($1, $3) } - | IF LPAREN expr RPAREN stmts ELSE stmts { Cmconstr.ifthenelse $3 $5 $7 } - | IF LPAREN expr RPAREN stmts { Cmconstr.ifthenelse $3 $5 Sskip } + | IF LPAREN expr RPAREN stmts ELSE stmts { Sifthenelse($3, $5, $7) } + | IF LPAREN expr RPAREN stmts { Sifthenelse($3, $5, Sskip) } | LOOP stmts { Sloop($2) } | LBRACELBRACE stmt_list RBRACERBRACE { Sblock($2) } | EXIT SEMICOLON { Sexit O } - | EXIT INTLIT SEMICOLON { Sexit (nat_of_camlint(Int32.pred $2)) } + | EXIT INTLIT SEMICOLON { Sexit (exitnum $2) } | RETURN SEMICOLON { Sreturn None } | RETURN expr SEMICOLON { Sreturn (Some $2) } + | SWITCH LPAREN expr RPAREN LBRACE switch_cases RBRACE + { mkswitch $3 $6 } + | MATCH LPAREN expr RPAREN LBRACE match_cases RBRACE + { mkmatch $3 $6 } ; stmts: @@ -237,72 +295,84 @@ stmt_list: | stmt stmt_list { Sseq($1, $2) } ; +switch_cases: + DEFAULT COLON EXIT INTLIT SEMICOLON + { ([], $4) } + | CASE INTLIT COLON EXIT INTLIT SEMICOLON switch_cases + { let (cases, dfl) = $7 in (($2, $5) :: cases, dfl) } +; + +match_cases: + /* empty */ { [] } + | CASE INTLIT COLON stmt_list match_cases { ($2, $4) :: $5 } +; + /* Expressions */ expr: LPAREN expr RPAREN { $2 } | IDENT { Evar $1 } | INTLIT { intconst $1 } - | FLOATLIT { Eop(Ofloatconst $1, Enil) } - | STRINGLIT { Eop(Oaddrsymbol($1, Int.zero), Enil) } - | AMPERSAND INTLIT { Eop(Oaddrstack(coqint_of_camlint $2), Enil) } - | MINUS expr %prec p_uminus { Cmconstr.negint $2 } - | MINUSF expr %prec p_uminus { Cmconstr.negfloat $2 } - | ABSF expr { Cmconstr.absfloat $2 } - | INTOFFLOAT expr { Cmconstr.intoffloat $2 } - | FLOATOFINT expr { Cmconstr.floatofint $2 } - | FLOATOFINTU expr { Cmconstr.floatofintu $2 } - | TILDE expr { Cmconstr.notint $2 } - | BANG expr { Cmconstr.notbool $2 } - | INT8S expr { Cmconstr.cast8signed $2 } - | INT8U expr { Cmconstr.cast8unsigned $2 } - | INT16S expr { Cmconstr.cast16signed $2 } - | INT16U expr { Cmconstr.cast16unsigned $2 } - | FLOAT32 expr { Cmconstr.singleoffloat $2 } + | FLOATLIT { Econst(Ofloatconst $1) } + | STRINGLIT { Econst(Oaddrsymbol($1, Int.zero)) } + | AMPERSAND INTLIT { Econst(Oaddrstack(coqint_of_camlint $2)) } + | MINUS expr %prec p_uminus { Eunop(Onegint, $2) } + | MINUSF expr %prec p_uminus { Eunop(Onegf, $2) } + | ABSF expr { Eunop(Oabsf, $2) } + | INTOFFLOAT expr { Eunop(Ointoffloat, $2) } + | FLOATOFINT expr { Eunop(Ofloatofint, $2) } + | FLOATOFINTU expr { Eunop(Ofloatofintu, $2) } + | TILDE expr { Eunop(Onotint, $2) } + | BANG expr { Eunop(Onotbool, $2) } + | INT8S expr { Eunop(Ocast8signed, $2) } + | INT8U expr { Eunop(Ocast8unsigned, $2) } + | INT16S expr { Eunop(Ocast16signed, $2) } + | INT16U expr { Eunop(Ocast16unsigned, $2) } + | FLOAT32 expr { Eunop(Osingleoffloat, $2) } | ALLOC expr { Ealloc $2 } - | expr PLUS expr { Cmconstr.add $1 $3 } - | expr MINUS expr { Cmconstr.sub $1 $3 } - | expr STAR expr { Cmconstr.mul $1 $3 } - | expr SLASH expr { Cmconstr.divs $1 $3 } - | expr PERCENT expr { Cmconstr.mods $1 $3 } - | expr SLASHU expr { Cmconstr.divu $1 $3 } - | expr PERCENTU expr { Cmconstr.modu $1 $3 } - | expr AMPERSAND expr { Cmconstr.coq_and $1 $3 } - | expr BAR expr { Cmconstr.coq_or $1 $3 } - | expr CARET expr { Cmconstr.xor $1 $3 } - | expr LESSLESS expr { Cmconstr.shl $1 $3 } - | expr GREATERGREATER expr { Cmconstr.shr $1 $3 } - | expr GREATERGREATERU expr { Cmconstr.shru $1 $3 } - | expr PLUSF expr { Cmconstr.addf $1 $3 } - | expr MINUSF expr { Cmconstr.subf $1 $3 } - | expr STARF expr { Cmconstr.mulf $1 $3 } - | expr SLASHF expr { Cmconstr.divf $1 $3 } - | expr EQUALEQUAL expr { Cmconstr.cmp Ceq $1 $3 } - | expr BANGEQUAL expr { Cmconstr.cmp Cne $1 $3 } - | expr LESS expr { Cmconstr.cmp Clt $1 $3 } - | expr LESSEQUAL expr { Cmconstr.cmp Cle $1 $3 } - | expr GREATER expr { Cmconstr.cmp Cgt $1 $3 } - | expr GREATEREQUAL expr { Cmconstr.cmp Cge $1 $3 } - | expr EQUALEQUALU expr { Cmconstr.cmpu Ceq $1 $3 } - | expr BANGEQUALU expr { Cmconstr.cmpu Cne $1 $3 } - | expr LESSU expr { Cmconstr.cmpu Clt $1 $3 } - | expr LESSEQUALU expr { Cmconstr.cmpu Cle $1 $3 } - | expr GREATERU expr { Cmconstr.cmpu Cgt $1 $3 } - | expr GREATEREQUALU expr { Cmconstr.cmpu Cge $1 $3 } - | expr EQUALEQUALF expr { Cmconstr.cmpf Ceq $1 $3 } - | expr BANGEQUALF expr { Cmconstr.cmpf Cne $1 $3 } - | expr LESSF expr { Cmconstr.cmpf Clt $1 $3 } - | expr LESSEQUALF expr { Cmconstr.cmpf Cle $1 $3 } - | expr GREATERF expr { Cmconstr.cmpf Cgt $1 $3 } - | expr GREATEREQUALF expr { Cmconstr.cmpf Cge $1 $3 } - | memory_chunk LBRACKET expr RBRACKET { Cmconstr.load $1 $3 } + | expr PLUS expr { Ebinop(Oadd, $1, $3) } + | expr MINUS expr { Ebinop(Osub, $1, $3) } + | expr STAR expr { Ebinop(Omul, $1, $3) } + | expr SLASH expr { Ebinop(Odiv, $1, $3) } + | expr PERCENT expr { Ebinop(Omod, $1, $3) } + | expr SLASHU expr { Ebinop(Odivu, $1, $3) } + | expr PERCENTU expr { Ebinop(Omodu, $1, $3) } + | expr AMPERSAND expr { Ebinop(Oand, $1, $3) } + | expr BAR expr { Ebinop(Oor, $1, $3) } + | expr CARET expr { Ebinop(Oxor, $1, $3) } + | expr LESSLESS expr { Ebinop(Oshl, $1, $3) } + | expr GREATERGREATER expr { Ebinop(Oshr, $1, $3) } + | expr GREATERGREATERU expr { Ebinop(Oshru, $1, $3) } + | expr PLUSF expr { Ebinop(Oaddf, $1, $3) } + | expr MINUSF expr { Ebinop(Osubf, $1, $3) } + | expr STARF expr { Ebinop(Omulf, $1, $3) } + | expr SLASHF expr { Ebinop(Odivf, $1, $3) } + | expr EQUALEQUAL expr { Ebinop(Ocmp Ceq, $1, $3) } + | expr BANGEQUAL expr { Ebinop(Ocmp Cne, $1, $3) } + | expr LESS expr { Ebinop(Ocmp Clt, $1, $3) } + | expr LESSEQUAL expr { Ebinop(Ocmp Cle, $1, $3) } + | expr GREATER expr { Ebinop(Ocmp Cgt, $1, $3) } + | expr GREATEREQUAL expr { Ebinop(Ocmp Cge, $1, $3) } + | expr EQUALEQUALU expr { Ebinop(Ocmpu Ceq, $1, $3) } + | expr BANGEQUALU expr { Ebinop(Ocmpu Cne, $1, $3) } + | expr LESSU expr { Ebinop(Ocmpu Clt, $1, $3) } + | expr LESSEQUALU expr { Ebinop(Ocmpu Cle, $1, $3) } + | expr GREATERU expr { Ebinop(Ocmpu Cgt, $1, $3) } + | expr GREATEREQUALU expr { Ebinop(Ocmpu Cge, $1, $3) } + | expr EQUALEQUALF expr { Ebinop(Ocmpf Ceq, $1, $3) } + | expr BANGEQUALF expr { Ebinop(Ocmpf Cne, $1, $3) } + | expr LESSF expr { Ebinop(Ocmpf Clt, $1, $3) } + | expr LESSEQUALF expr { Ebinop(Ocmpf Cle, $1, $3) } + | expr GREATERF expr { Ebinop(Ocmpf Cgt, $1, $3) } + | expr GREATEREQUALF expr { Ebinop(Ocmpf Cge, $1, $3) } + | memory_chunk LBRACKET expr RBRACKET { Eload($1, $3) } | memory_chunk LBRACKET expr RBRACKET EQUAL expr - { Cmconstr.store $1 $3 $6 } + { Estore($1, $3, $6) } | expr LPAREN expr_list RPAREN COLON signature { Ecall($6, $1, $3) } | expr AMPERSANDAMPERSAND expr { andbool $1 $3 } | expr BARBAR expr { orbool $1 $3 } - | expr QUESTION expr COLON expr { Cmconstr.conditionalexpr $1 $3 $5 } + | expr QUESTION expr COLON expr { Econdition($1, $3, $5) } | LET expr IN expr %prec p_let { Elet($2, $4) } | DOLLAR INTLIT { Eletvar (nat_of_camlint $2) } ; diff --git a/caml/CMtypecheck.ml b/caml/CMtypecheck.ml index a926039d..495ded0c 100644 --- a/caml/CMtypecheck.ml +++ b/caml/CMtypecheck.ml @@ -6,7 +6,6 @@ open CList open Camlcoq open AST open Integers -open Op open Cminor exception Error of string @@ -67,135 +66,91 @@ let name_of_comparison = function | Cgt -> "gt" | Cge -> "ge" -let type_condition = function - | Ccomp _ -> [tint;tint] - | Ccompu _ -> [tint;tint] - | Ccompimm _ -> [tint] - | Ccompuimm _ -> [tint] - | Ccompf _ -> [tfloat;tfloat] - | Cnotcompf _ -> [tfloat;tfloat] - | Cmaskzero _ -> [tint] - | Cmasknotzero _ -> [tint] +let type_constant = function + | Ointconst _ -> tint + | Ofloatconst _ -> tfloat + | Oaddrsymbol _ -> tint + | Oaddrstack _ -> tint -let name_of_condition = function - | Ccomp c -> sprintf "comp %s" (name_of_comparison c) - | Ccompu c -> sprintf "compu %s" (name_of_comparison c) - | Ccompimm(c, n) -> sprintf "compimm %s %ld" (name_of_comparison c) (camlint_of_coqint n) - | Ccompuimm(c, n) -> sprintf "compuimm %s %ld" (name_of_comparison c) (camlint_of_coqint n) - | Ccompf c -> sprintf "compf %s" (name_of_comparison c) - | Cnotcompf c -> sprintf "notcompf %s" (name_of_comparison c) - | Cmaskzero n -> sprintf "maskzero %ld" (camlint_of_coqint n) - | Cmasknotzero n -> sprintf "masknotzero %ld" (camlint_of_coqint n) +let type_unary_operation = function + | Ocast8signed -> tint, tint + | Ocast16signed -> tint, tint + | Ocast8unsigned -> tint, tint + | Ocast16unsigned -> tint, tint + | Onegint -> tint, tint + | Onotbool -> tint, tint + | Onotint -> tint, tint + | Onegf -> tfloat, tfloat + | Oabsf -> tfloat, tfloat + | Osingleoffloat -> tfloat, tfloat + | Ointoffloat -> tfloat, tint + | Ofloatofint -> tint, tfloat + | Ofloatofintu -> tint, tfloat -let type_operation = function - | Omove -> let v = newvar() in [v], v - | Ointconst _ -> [], tint - | Ofloatconst _ -> [], tfloat - | Oaddrsymbol _ -> [], tint - | Oaddrstack _ -> [], tint - | Oundef -> [], newvar() - | Ocast8signed -> [tint], tint - | Ocast16signed -> [tint], tint - | Ocast8unsigned -> [tint], tint - | Ocast16unsigned -> [tint], tint - | Oadd -> [tint;tint], tint - | Oaddimm _ -> [tint], tint - | Osub -> [tint;tint], tint - | Osubimm _ -> [tint], tint - | Omul -> [tint;tint], tint - | Omulimm _ -> [tint], tint - | Odiv -> [tint;tint], tint - | Odivu -> [tint;tint], tint - | Oand -> [tint;tint], tint - | Oandimm _ -> [tint], tint - | Oor -> [tint;tint], tint - | Oorimm _ -> [tint], tint - | Oxor -> [tint;tint], tint - | Oxorimm _ -> [tint], tint - | Onand -> [tint;tint], tint - | Onor -> [tint;tint], tint - | Onxor -> [tint;tint], tint - | Oshl -> [tint;tint], tint - | Oshr -> [tint;tint], tint - | Oshrimm _ -> [tint], tint - | Oshrximm _ -> [tint], tint - | Oshru -> [tint;tint], tint - | Orolm _ -> [tint], tint - | Onegf -> [tfloat], tfloat - | Oabsf -> [tfloat], tfloat - | Oaddf -> [tfloat;tfloat], tfloat - | Osubf -> [tfloat;tfloat], tfloat - | Omulf -> [tfloat;tfloat], tfloat - | Odivf -> [tfloat;tfloat], tfloat - | Omuladdf -> [tfloat;tfloat;tfloat], tfloat - | Omulsubf -> [tfloat;tfloat;tfloat], tfloat - | Osingleoffloat -> [tfloat], tfloat - | Ointoffloat -> [tfloat], tint - | Ofloatofint -> [tint], tfloat - | Ofloatofintu -> [tint], tfloat - | Ocmp c -> type_condition c, tint +let type_binary_operation = function + | Oadd -> tint, tint, tint + | Osub -> tint, tint, tint + | Omul -> tint, tint, tint + | Odiv -> tint, tint, tint + | Odivu -> tint, tint, tint + | Omod -> tint, tint, tint + | Omodu -> tint, tint, tint + | Oand -> tint, tint, tint + | Oor -> tint, tint, tint + | Oxor -> tint, tint, tint + | Oshl -> tint, tint, tint + | Oshr -> tint, tint, tint + | Oshru -> tint, tint, tint + | Oaddf -> tfloat, tfloat, tfloat + | Osubf -> tfloat, tfloat, tfloat + | Omulf -> tfloat, tfloat, tfloat + | Odivf -> tfloat, tfloat, tfloat + | Ocmp _ -> tint, tint, tint + | Ocmpu _ -> tint, tint, tint + | Ocmpf _ -> tfloat, tfloat, tint -let name_of_operation = function - | Omove -> "move" +let name_of_constant = function | Ointconst n -> sprintf "intconst %ld" (camlint_of_coqint n) | Ofloatconst n -> sprintf "floatconst %g" n | Oaddrsymbol (s, ofs) -> sprintf "addrsymbol %s %ld" (extern_atom s) (camlint_of_coqint ofs) | Oaddrstack n -> sprintf "addrstack %ld" (camlint_of_coqint n) - | Oundef -> "undef" + +let name_of_unary_operation = function | Ocast8signed -> "cast8signed" | Ocast16signed -> "cast16signed" | Ocast8unsigned -> "cast8unsigned" | Ocast16unsigned -> "cast16unsigned" + | Onegint -> "negint" + | Onotbool -> "notbool" + | Onotint -> "notint" + | Onegf -> "negf" + | Oabsf -> "absf" + | Osingleoffloat -> "singleoffloat" + | Ointoffloat -> "intoffloat" + | Ofloatofint -> "floatofint" + | Ofloatofintu -> "floatofintu" + +let name_of_binary_operation = function | Oadd -> "add" - | Oaddimm n -> sprintf "addimm %ld" (camlint_of_coqint n) | Osub -> "sub" - | Osubimm n -> sprintf "subimm %ld" (camlint_of_coqint n) | Omul -> "mul" - | Omulimm n -> sprintf "mulimm %ld" (camlint_of_coqint n) | Odiv -> "div" | Odivu -> "divu" + | Omod -> "mod" + | Omodu -> "modu" | Oand -> "and" - | Oandimm n -> sprintf "andimm %ld" (camlint_of_coqint n) | Oor -> "or" - | Oorimm n -> sprintf "orimm %ld" (camlint_of_coqint n) | Oxor -> "xor" - | Oxorimm n -> sprintf "xorimm %ld" (camlint_of_coqint n) - | Onand -> "nand" - | Onor -> "nor" - | Onxor -> "nxor" | Oshl -> "shl" | Oshr -> "shr" - | Oshrimm n -> sprintf "shrimm %ld" (camlint_of_coqint n) - | Oshrximm n -> sprintf "shrximm %ld" (camlint_of_coqint n) | Oshru -> "shru" - | Orolm(n, m) -> sprintf "rolm %ld %ld" (camlint_of_coqint n) (camlint_of_coqint m) - | Onegf -> "negf" - | Oabsf -> "absf" | Oaddf -> "addf" | Osubf -> "subf" | Omulf -> "mulf" | Odivf -> "divf" - | Omuladdf -> "muladdf" - | Omulsubf -> "mulsubf" - | Osingleoffloat -> "singleoffloat" - | Ointoffloat -> "intoffloat" - | Ofloatofint -> "floatofint" - | Ofloatofintu -> "floatofintu" - | Ocmp c -> name_of_condition c - -let type_addressing = function - | Aindexed _ -> [tint] - | Aindexed2 -> [tint;tint] - | Aglobal _ -> [] - | Abased _ -> [tint] - | Ainstack _ -> [] - -let name_of_addressing = function - | Aindexed n -> sprintf "indexed %ld" (camlint_of_coqint n) - | Aindexed2 -> sprintf "indexed2" - | Aglobal(s, ofs) -> sprintf "global %s %ld" (extern_atom s) (camlint_of_coqint ofs) - | Abased(s, ofs) -> sprintf "based %s %ld" (extern_atom s) (camlint_of_coqint ofs) - | Ainstack n -> sprintf "instack %ld" (camlint_of_coqint n) + | Ocmp c -> sprintf "cmp %s" (name_of_comparison c) + | Ocmpu c -> sprintf "cmpu %s" (name_of_comparison c) + | Ocmpf c -> sprintf "cmpf %s" (name_of_comparison c) let type_chunk = function | Mint8signed -> tint @@ -219,34 +174,47 @@ let rec type_expr env lenv e = match e with | Evar id -> type_var env id - | Eop(op, el) -> - let tel = type_exprlist env lenv el in - let (targs, tres) = type_operation op in + | Econst cst -> + type_constant cst + | Eunop(op, e1) -> + let te1 = type_expr env lenv e1 in + let (targ, tres) = type_unary_operation op in begin try - unify_list targs tel + unify targ te1 with Error s -> raise (Error (sprintf "In application of operator %s:\n%s" - (name_of_operation op) s)) + (name_of_unary_operation op) s)) end; tres - | Eload(chunk, addr, el) -> - let tel = type_exprlist env lenv el in + | Ebinop(op, e1, e2) -> + let te1 = type_expr env lenv e1 in + let te2 = type_expr env lenv e2 in + let (targ1, targ2, tres) = type_binary_operation op in begin try - unify_list (type_addressing addr) tel + unify targ1 te1; unify targ2 te2 with Error s -> - raise (Error (sprintf "In load %s %s:\n%s" - (name_of_chunk chunk) (name_of_addressing addr) s)) + raise (Error (sprintf "In application of operator %s:\n%s" + (name_of_binary_operation op) s)) + end; + tres + | Eload(chunk, e) -> + let te = type_expr env lenv e in + begin try + unify tint te + with Error s -> + raise (Error (sprintf "In load %s:\n%s" + (name_of_chunk chunk) s)) end; type_chunk chunk - | Estore(chunk, addr, el, e1) -> - let tel = type_exprlist env lenv el in + | Estore(chunk, e1, e2) -> let te1 = type_expr env lenv e1 in + let te2 = type_expr env lenv e2 in begin try - unify_list (type_addressing addr) tel; - unify (type_chunk chunk) te1 + unify tint te1; + unify (type_chunk chunk) te2 with Error s -> - raise (Error (sprintf "In store %s %s:\n%s" - (name_of_chunk chunk) (name_of_addressing addr) s)) + raise (Error (sprintf "In store %s:\n%s" + (name_of_chunk chunk) s)) end; te1 | Ecall(sg, e1, el) -> @@ -295,21 +263,13 @@ and type_exprlist env lenv el = let tet = type_exprlist env lenv et in (te1 :: tet) -and type_condexpr env lenv ce = - match ce with - | CEtrue -> () - | CEfalse -> () - | CEcond(c, el) -> - let tel = type_exprlist env lenv el in - begin try - unify_list (type_condition c) tel - with Error s -> - raise (Error (sprintf "In condition %s:\n%s" (name_of_condition c) s)) - end - | CEcondition(ce1, ce2, ce3) -> - type_condexpr env lenv ce1; - type_condexpr env lenv ce2; - type_condexpr env lenv ce3 +and type_condexpr env lenv e = + let te = type_expr env lenv e in + begin try + unify tint te + with Error s -> + raise (Error (sprintf "In condition:\n%s" s)) + end let rec type_stmt env blk ret s = match s with @@ -355,6 +315,15 @@ let rec type_stmt env blk ret s = raise (Error (sprintf "In return:\n%s" s)) end end + | Stailcall(sg, e1, el) -> + let te1 = type_expr env [] e1 in + let tel = type_exprlist env [] el in + begin try + unify tint te1; + unify_list (ty_of_sig_args sg.sig_args) tel + with Error s -> + raise (Error (sprintf "In tail call:\n%s" s)) + end let rec env_of_vars idl = match idl with diff --git a/caml/Camlcoq.ml b/caml/Camlcoq.ml index c2115dfb..ec2447fa 100644 --- a/caml/Camlcoq.ml +++ b/caml/Camlcoq.ml @@ -41,7 +41,7 @@ let z_of_camlint n = let coqint_of_camlint : int32 -> Integers.int = z_of_camlint -(* Strings *) +(* Atoms (positive integers representing strings) *) let atom_of_string = (Hashtbl.create 17 : (string, positive) Hashtbl.t) let string_of_atom = (Hashtbl.create 17 : (positive, string) Hashtbl.t) @@ -69,24 +69,6 @@ let rec coqlist_iter f = function Coq_nil -> () | Coq_cons(a,l) -> f a; coqlist_iter f l -(* Helpers *) - -let rec list_iter f = function - [] -> () - | a::l -> f a; list_iter f l - -let rec list_memq x = function - [] -> false - | a::l -> a == x || list_memq x l - -let rec list_exists p = function - [] -> false - | a::l -> p a || list_exists p l - -let rec list_filter p = function - [] -> [] - | x :: l -> if p x then x :: list_filter p l else list_filter p l - let rec length_coqlist = function | Coq_nil -> 0 | Coq_cons (x, l) -> 1 + length_coqlist l @@ -100,6 +82,31 @@ let array_of_coqlist = function | Coq_cons(hd, tl) -> a.(i) <- hd; fill (i + 1) tl in fill 1 tl +(* Strings *) + +let char_of_ascii (Ascii.Ascii(a0, a1, a2, a3, a4, a5, a6, a7)) = + Char.chr( (if a0 then 1 else 0) + + (if a1 then 2 else 0) + + (if a2 then 4 else 0) + + (if a3 then 8 else 0) + + (if a4 then 16 else 0) + + (if a5 then 32 else 0) + + (if a6 then 64 else 0) + + (if a7 then 128 else 0)) + +let coqstring_length s = + let rec len accu = function + | CString.EmptyString -> accu + | CString.CString(_, s) -> len (accu + 1) s + in len 0 s + +let camlstring_of_coqstring s = + let r = String.create (coqstring_length s) in + let rec fill pos = function + | CString.EmptyString -> r + | CString.CString(c, s) -> r.[pos] <- char_of_ascii c; fill (pos + 1) s + in fill 0 s + (* Timing facility *) (* diff --git a/caml/Coloringaux.ml b/caml/Coloringaux.ml index a7c8db5c..b3f4515e 100644 --- a/caml/Coloringaux.ml +++ b/caml/Coloringaux.ml @@ -185,8 +185,8 @@ let init() = let interfere n1 n2 = if n1.degree < n2.degree - then list_memq n2 n1.adjlist - else list_memq n1 n2.adjlist + then List.memq n2 n1.adjlist + else List.memq n1 n2.adjlist (* Add an edge to the graph. Assume edge is not in graph already *) @@ -199,7 +199,7 @@ let addEdge n1 n2 = (* Apply the given function to the relevant adjacent nodes of a node *) let iterAdjacent f n = - list_iter + List.iter (fun n -> match n.nstate with | SelectStack | CoalescedNodes -> () @@ -214,12 +214,12 @@ let moveIsActiveOrWorklist m = | _ -> false let nodeMoves n = - list_filter moveIsActiveOrWorklist n.movelist + List.filter moveIsActiveOrWorklist n.movelist (* Determine whether a node is involved in a move *) let moveRelated n = - list_exists moveIsActiveOrWorklist n.movelist + List.exists moveIsActiveOrWorklist n.movelist (*i (* Check invariants *) @@ -361,7 +361,7 @@ let build g typenv spillcosts = (* Enable moves that have become low-degree related *) let enableMoves n = - list_iter + List.iter (fun m -> if m.mstate = ActiveMoves then DLinkMove.move m activeMoves worklistMoves) @@ -481,7 +481,7 @@ let freezeMoves u = && v.degree < num_available_registers.(v.regclass) && v.nstate <> Colored then DLinkNode.move v freezeWorklist simplifyWorklist in - list_iter freeze (nodeMoves u) + List.iter freeze (nodeMoves u) (* Pick a move and freeze it *) @@ -577,7 +577,7 @@ let find_slot conflicts typ = let assign_color n = let conflicts = ref Locset.empty in - list_iter + List.iter (fun n' -> match (getAlias n').color with | None -> () @@ -607,7 +607,7 @@ let graph_coloring (f: coq_function) (g: graph) (env: regenv) (regs: Regset.t) init(); Array.fill start_points 0 num_register_classes 0; let mapping = build g env (spill_costs f) in - list_iter assign_color (nodeOrder []); + List.iter assign_color (nodeOrder []); fun r -> try location_of_node (getAlias (Hashtbl.find mapping r)) with Not_found -> R IT1 (* any location *) diff --git a/caml/Main2.ml b/caml/Main2.ml index ff9f3509..e3399fb9 100644 --- a/caml/Main2.ml +++ b/caml/Main2.ml @@ -94,8 +94,8 @@ let process_c_file sourcename = (* Convert to PPC *) let ppc = match Main.transf_c_program csyntax with - | Datatypes.Some x -> x - | Datatypes.None -> + | Errors.OK x -> x + | Errors.Error msg -> eprintf "Error in translation Csyntax -> PPC\n"; exit 2 in (* Save PPC asm *) @@ -111,10 +111,10 @@ let process_cminor_file sourcename = match Main.transf_cminor_program (CMtypecheck.type_program (CMparser.prog CMlexer.token lb)) with - | Datatypes.None -> + | Errors.Error msg -> eprintf "Compiler failure\n"; exit 2 - | Datatypes.Some p -> + | Errors.OK p -> let oc = open_out targetname in PrintPPC.print_program oc p; close_out oc diff --git a/caml/PrintPPC.ml b/caml/PrintPPC.ml index 3ee79d12..bf7b2cc7 100644 --- a/caml/PrintPPC.ml +++ b/caml/PrintPPC.ml @@ -137,6 +137,8 @@ let print_instruction oc labels = function fprintf oc " bf %a, %a\n" print_crbit bit print_label lbl | Pbl s -> fprintf oc " bl %a\n" print_symb s + | Pbs s -> + fprintf oc " b %a\n" print_symb s | Pblr -> fprintf oc " blr\n" | Pbt(bit, lbl) -> @@ -318,10 +320,6 @@ let print_instruction oc labels = function fprintf oc " xoris %a, %a, %a\n" ireg r1 ireg r2 print_constant c | Plabel lbl -> if Labelset.mem lbl labels then fprintf oc "%a:\n" print_label lbl - | Piundef r -> - fprintf oc " # undef %a\n" ireg r - | Pfundef r -> - fprintf oc " # undef %a\n" freg r let rec labels_of_code = function | Coq_nil -> Labelset.empty diff --git a/caml/RTLgenaux.ml b/caml/RTLgenaux.ml index 336346af..61abecfa 100644 --- a/caml/RTLgenaux.ml +++ b/caml/RTLgenaux.ml @@ -1,3 +1,47 @@ -open Cminor +open Switch +open CminorSel let more_likely (c: condexpr) (ifso: stmt) (ifnot: stmt) = false + +module IntOrd = + struct + type t = Integers.int + let compare x y = + if Integers.Int.eq x y then 0 else + if Integers.Int.ltu x y then -1 else 1 + end + +module IntSet = Set.Make(IntOrd) + +let normalize_table tbl = + let rec norm seen = function + | CList.Coq_nil -> [] + | CList.Coq_cons(Datatypes.Coq_pair(key, act), rem) -> + if IntSet.mem key seen + then norm seen rem + else (key, act) :: norm (IntSet.add key seen) rem + in norm IntSet.empty tbl + +let compile_switch default table = + let sw = Array.of_list (normalize_table table) in + Array.stable_sort (fun (n1, _) (n2, _) -> IntOrd.compare n1 n2) sw; + let rec build lo hi = + match hi - lo with + | 0 -> + CTaction default + | 1 -> + CTifeq(fst sw.(lo), snd sw.(lo), CTaction default) + | 2 -> + CTifeq(fst sw.(lo), snd sw.(lo), + CTifeq(fst sw.(lo+1), snd sw.(lo+1), + CTaction default)) + | 3 -> + CTifeq(fst sw.(lo), snd sw.(lo), + CTifeq(fst sw.(lo+1), snd sw.(lo+1), + CTifeq(fst sw.(lo+2), snd sw.(lo+2), + CTaction default))) + | _ -> + let mid = (lo + hi) / 2 in + CTiflt(fst sw.(mid), build lo mid, build mid hi) + in build 0 (Array.length sw) + diff --git a/caml/RTLtypingaux.ml b/caml/RTLtypingaux.ml index 64f839a2..5ed7e6e2 100644 --- a/caml/RTLtypingaux.ml +++ b/caml/RTLtypingaux.ml @@ -32,10 +32,6 @@ let type_instr retty (Coq_pair(pc, i)) = () | Iop(Omove, _, _, _) -> () - | Iop(Oundef, Coq_nil, res, _) -> - () - | Iop(Oundef, _, _, _) -> - raise (Type_error "wrong Oundef") | Iop(op, args, res, _) -> let (Coq_pair(targs, tres)) = type_of_operation op in set_types args targs; set_type res tres @@ -61,6 +57,23 @@ let type_instr retty (Coq_pair(pc, i)) = raise(Type_error (Printf.sprintf "type mismatch in Icall(%s): %s" name msg)) end + | Itailcall(sg, ros, args) -> + begin try + begin match ros with + | Coq_inl r -> set_type r Tint + | Coq_inr _ -> () + end; + set_types args sg.sig_args; + if sg.sig_res <> retty then + raise (Type_error "mismatch on return type") + with Type_error msg -> + let name = + match ros with + | Coq_inl _ -> "" + | Coq_inr id -> extern_atom id in + raise(Type_error (Printf.sprintf "type mismatch in Itailcall(%s): %s" + name msg)) + end | Ialloc(arg, res, _) -> set_type arg Tint; set_type res Tint | Icond(cond, args, _, _) -> diff --git a/cfrontend/Cminorgen.v b/cfrontend/Cminorgen.v index a3afae20..23faf785 100644 --- a/cfrontend/Cminorgen.v +++ b/cfrontend/Cminorgen.v @@ -3,6 +3,7 @@ Require Import FSets. Require FSetAVL. Require Import Coqlib. +Require Import Errors. Require Import Maps. Require Import Ordered. Require Import AST. @@ -11,7 +12,9 @@ Require Mem. Require Import Csharpminor. Require Import Op. Require Import Cminor. -Require Cmconstr. + +Open Local Scope string_scope. +Open Local Scope error_monad_scope. (** The main task in translating Csharpminor to Cminor is to explicitly stack-allocate local variables whose address is taken: these local @@ -35,57 +38,12 @@ Require Cmconstr. the ``normalize at assignment-time'' semantics of Csharpminor. *) -(** Translation of operators. *) +(** Translation of constants. *) -Definition make_op (op: Csharpminor.operation) (el: exprlist): option expr := - match el with - | Enil => - match op with - | Csharpminor.Ointconst n => Some(Eop (Ointconst n) Enil) - | Csharpminor.Ofloatconst n => Some(Eop (Ofloatconst n) Enil) - | _ => None - end - | Econs e1 Enil => - match op with - | Csharpminor.Ocast8unsigned => Some(Cmconstr.cast8unsigned e1) - | Csharpminor.Ocast8signed => Some(Cmconstr.cast8signed e1) - | Csharpminor.Ocast16unsigned => Some(Cmconstr.cast16unsigned e1) - | Csharpminor.Ocast16signed => Some(Cmconstr.cast16signed e1) - | Csharpminor.Onotint => Some(Cmconstr.notint e1) - | Csharpminor.Onotbool => Some(Cmconstr.notbool e1) - | Csharpminor.Onegf => Some(Cmconstr.negfloat e1) - | Csharpminor.Oabsf => Some(Cmconstr.absfloat e1) - | Csharpminor.Osingleoffloat => Some(Cmconstr.singleoffloat e1) - | Csharpminor.Ointoffloat => Some(Cmconstr.intoffloat e1) - | Csharpminor.Ofloatofint => Some(Cmconstr.floatofint e1) - | Csharpminor.Ofloatofintu => Some(Cmconstr.floatofintu e1) - | _ => None - end - | Econs e1 (Econs e2 Enil) => - match op with - | Csharpminor.Oadd => Some(Cmconstr.add e1 e2) - | Csharpminor.Osub => Some(Cmconstr.sub e1 e2) - | Csharpminor.Omul => Some(Cmconstr.mul e1 e2) - | Csharpminor.Odiv => Some(Cmconstr.divs e1 e2) - | Csharpminor.Odivu => Some(Cmconstr.divu e1 e2) - | Csharpminor.Omod => Some(Cmconstr.mods e1 e2) - | Csharpminor.Omodu => Some(Cmconstr.modu e1 e2) - | Csharpminor.Oand => Some(Cmconstr.and e1 e2) - | Csharpminor.Oor => Some(Cmconstr.or e1 e2) - | Csharpminor.Oxor => Some(Cmconstr.xor e1 e2) - | Csharpminor.Oshl => Some(Cmconstr.shl e1 e2) - | Csharpminor.Oshr => Some(Cmconstr.shr e1 e2) - | Csharpminor.Oshru => Some(Cmconstr.shru e1 e2) - | Csharpminor.Oaddf => Some(Cmconstr.addf e1 e2) - | Csharpminor.Osubf => Some(Cmconstr.subf e1 e2) - | Csharpminor.Omulf => Some(Cmconstr.mulf e1 e2) - | Csharpminor.Odivf => Some(Cmconstr.divf e1 e2) - | Csharpminor.Ocmp c => Some(Cmconstr.cmp c e1 e2) - | Csharpminor.Ocmpu c => Some(Cmconstr.cmpu c e1 e2) - | Csharpminor.Ocmpf c => Some(Cmconstr.cmpf c e1 e2) - | _ => None - end - | _ => None +Definition transl_constant (cst: Csharpminor.constant): constant := + match cst with + | Csharpminor.Ointconst n => Ointconst n + | Csharpminor.Ofloatconst n => Ofloatconst n end. (** [make_cast chunk e] returns a Cminor expression that normalizes @@ -95,45 +53,38 @@ Definition make_op (op: Csharpminor.operation) (el: exprlist): option expr := Definition make_cast (chunk: memory_chunk) (e: expr): expr := match chunk with - | Mint8signed => Cmconstr.cast8signed e - | Mint8unsigned => Cmconstr.cast8unsigned e - | Mint16signed => Cmconstr.cast16signed e - | Mint16unsigned => Cmconstr.cast16unsigned e + | Mint8signed => Eunop Ocast8signed e + | Mint8unsigned => Eunop Ocast8unsigned e + | Mint16signed => Eunop Ocast16signed e + | Mint16unsigned => Eunop Ocast16unsigned e | Mint32 => e - | Mfloat32 => Cmconstr.singleoffloat e + | Mfloat32 => Eunop Osingleoffloat e | Mfloat64 => e end. -Definition make_load (chunk: memory_chunk) (e: expr): expr := - Cmconstr.load chunk e. - Definition store_arg (chunk: memory_chunk) (e: expr) : expr := match e with - | Eop op (Econs e1 Enil) => - match op with - | Ocast8signed => - match chunk with Mint8signed => e1 | _ => e end - | Ocast8unsigned => - match chunk with Mint8unsigned => e1 | _ => e end - | Ocast16signed => - match chunk with Mint16signed => e1 | _ => e end - | Ocast16unsigned => - match chunk with Mint16unsigned => e1 | _ => e end - | Osingleoffloat => - match chunk with Mfloat32 => e1 | _ => e end - | _ => e - end + | Eunop Ocast8signed e1 => + match chunk with Mint8signed => e1 | _ => e end + | Eunop Ocast8unsigned e1 => + match chunk with Mint8unsigned => e1 | _ => e end + | Eunop Ocast16signed e1 => + match chunk with Mint16signed => e1 | _ => e end + | Eunop Ocast16unsigned e1 => + match chunk with Mint16unsigned => e1 | _ => e end + | Eunop Osingleoffloat e1 => + match chunk with Mfloat32 => e1 | _ => e end | _ => e end. Definition make_store (chunk: memory_chunk) (e1 e2: expr): stmt := - Sexpr(Cmconstr.store chunk e1 (store_arg chunk e2)). + Sexpr (Estore chunk e1 (store_arg chunk e2)). Definition make_stackaddr (ofs: Z): expr := - Eop (Oaddrstack (Int.repr ofs)) Enil. + Econst (Oaddrstack (Int.repr ofs)). Definition make_globaladdr (id: ident): expr := - Eop (Oaddrsymbol id Int.zero) Enil. + Econst (Oaddrsymbol id Int.zero). (** Compile-time information attached to each Csharpminor variable: global variables, local variables, function parameters. @@ -156,134 +107,127 @@ Definition compilenv := PMap.t var_info. (** Generation of Cminor code corresponding to accesses to Csharpminor local variables: reads, assignments, and taking the address of. *) -Definition var_get (cenv: compilenv) (id: ident): option expr := +Definition var_get (cenv: compilenv) (id: ident): res expr := match PMap.get id cenv with | Var_local chunk => - Some(Evar id) + OK(Evar id) | Var_stack_scalar chunk ofs => - Some(make_load chunk (make_stackaddr ofs)) + OK(Eload chunk (make_stackaddr ofs)) | Var_global_scalar chunk => - Some(make_load chunk (make_globaladdr id)) + OK(Eload chunk (make_globaladdr id)) | _ => - None + Error(msg "Cminorgen.var_get") end. -Definition var_set (cenv: compilenv) (id: ident) (rhs: expr): option stmt := +Definition var_set (cenv: compilenv) (id: ident) (rhs: expr): res stmt := match PMap.get id cenv with | Var_local chunk => - Some(Sassign id (make_cast chunk rhs)) + OK(Sassign id (make_cast chunk rhs)) | Var_stack_scalar chunk ofs => - Some(make_store chunk (make_stackaddr ofs) rhs) + OK(make_store chunk (make_stackaddr ofs) rhs) | Var_global_scalar chunk => - Some(make_store chunk (make_globaladdr id) rhs) + OK(make_store chunk (make_globaladdr id) rhs) | _ => - None + Error(msg "Cminorgen.var_set") end. -Definition var_addr (cenv: compilenv) (id: ident): option expr := +Definition var_addr (cenv: compilenv) (id: ident): res expr := match PMap.get id cenv with - | Var_local chunk => None - | Var_stack_scalar chunk ofs => Some (make_stackaddr ofs) - | Var_stack_array ofs => Some (make_stackaddr ofs) - | _ => Some (make_globaladdr id) - end. - -(** The translation from Csharpminor to Cminor can fail, which we - encode by returning option types ([None] denotes error). - Propagation of errors is done in monadic style, using the following - [bind] monadic composition operator, and a [do] notation inspired - by Haskell's. *) - -Definition bind (A B: Set) (a: option A) (b: A -> option B): option B := - match a with - | None => None - | Some x => b x + | Var_local chunk => Error(msg "Cminorgen.var_addr") + | Var_stack_scalar chunk ofs => OK (make_stackaddr ofs) + | Var_stack_array ofs => OK (make_stackaddr ofs) + | _ => OK (make_globaladdr id) end. -Notation "'do' X <- A ; B" := (bind _ _ A (fun X => B)) - (at level 200, X ident, A at level 100, B at level 200). - (** Translation of expressions. All the hard work is done by the [make_*] and [var_*] functions defined above. *) Fixpoint transl_expr (cenv: compilenv) (e: Csharpminor.expr) - {struct e}: option expr := + {struct e}: res expr := match e with | Csharpminor.Evar id => var_get cenv id | Csharpminor.Eaddrof id => var_addr cenv id - | Csharpminor.Eop op el => - do tel <- transl_exprlist cenv el; make_op op tel + | Csharpminor.Econst cst => + OK (Econst (transl_constant cst)) + | Csharpminor.Eunop op e1 => + do te1 <- transl_expr cenv e1; + OK (Eunop op te1) + | Csharpminor.Ebinop op e1 e2 => + do te1 <- transl_expr cenv e1; + do te2 <- transl_expr cenv e2; + OK (Ebinop op te1 te2) | Csharpminor.Eload chunk e => - do te <- transl_expr cenv e; Some (make_load chunk te) + do te <- transl_expr cenv e; + OK (Eload chunk te) | Csharpminor.Ecall sig e el => do te <- transl_expr cenv e; do tel <- transl_exprlist cenv el; - Some (Ecall sig te tel) + OK (Ecall sig te tel) | Csharpminor.Econdition e1 e2 e3 => do te1 <- transl_expr cenv e1; do te2 <- transl_expr cenv e2; do te3 <- transl_expr cenv e3; - Some (Cmconstr.conditionalexpr te1 te2 te3) + OK (Econdition te1 te2 te3) | Csharpminor.Elet e1 e2 => do te1 <- transl_expr cenv e1; do te2 <- transl_expr cenv e2; - Some (Elet te1 te2) + OK (Elet te1 te2) | Csharpminor.Eletvar n => - Some (Eletvar n) + OK (Eletvar n) | Csharpminor.Ealloc e => do te <- transl_expr cenv e; - Some (Ealloc te) + OK (Ealloc te) end with transl_exprlist (cenv: compilenv) (el: Csharpminor.exprlist) - {struct el}: option exprlist := + {struct el}: res exprlist := match el with | Csharpminor.Enil => - Some Enil + OK Enil | Csharpminor.Econs e1 e2 => do te1 <- transl_expr cenv e1; do te2 <- transl_exprlist cenv e2; - Some (Econs te1 te2) + OK (Econs te1 te2) end. (** Translation of statements. Entirely straightforward. *) Fixpoint transl_stmt (cenv: compilenv) (s: Csharpminor.stmt) - {struct s}: option stmt := + {struct s}: res stmt := match s with | Csharpminor.Sskip => - Some Sskip + OK Sskip | Csharpminor.Sexpr e => - do te <- transl_expr cenv e; Some(Sexpr te) + do te <- transl_expr cenv e; OK(Sexpr te) | Csharpminor.Sassign id e => do te <- transl_expr cenv e; var_set cenv id te | Csharpminor.Sstore chunk e1 e2 => do te1 <- transl_expr cenv e1; do te2 <- transl_expr cenv e2; - Some (make_store chunk te1 te2) + OK (make_store chunk te1 te2) | Csharpminor.Sseq s1 s2 => do ts1 <- transl_stmt cenv s1; do ts2 <- transl_stmt cenv s2; - Some (Sseq ts1 ts2) + OK (Sseq ts1 ts2) | Csharpminor.Sifthenelse e s1 s2 => do te <- transl_expr cenv e; do ts1 <- transl_stmt cenv s1; do ts2 <- transl_stmt cenv s2; - Some (Cmconstr.ifthenelse te ts1 ts2) + OK (Sifthenelse te ts1 ts2) | Csharpminor.Sloop s => do ts <- transl_stmt cenv s; - Some (Sloop ts) + OK (Sloop ts) | Csharpminor.Sblock s => do ts <- transl_stmt cenv s; - Some (Sblock ts) + OK (Sblock ts) | Csharpminor.Sexit n => - Some (Sexit n) + OK (Sexit n) | Csharpminor.Sswitch e cases default => - do te <- transl_expr cenv e; Some(Sswitch te cases default) + do te <- transl_expr cenv e; OK(Sswitch te cases default) | Csharpminor.Sreturn None => - Some (Sreturn None) + OK (Sreturn None) | Csharpminor.Sreturn (Some e) => - do te <- transl_expr cenv e; Some (Sreturn (Some te)) + do te <- transl_expr cenv e; OK (Sreturn (Some te)) end. (** Computation of the set of variables whose address is taken in @@ -295,7 +239,10 @@ Fixpoint addr_taken_expr (e: Csharpminor.expr): Identset.t := match e with | Csharpminor.Evar id => Identset.empty | Csharpminor.Eaddrof id => Identset.add id Identset.empty - | Csharpminor.Eop op el => addr_taken_exprlist el + | Csharpminor.Econst cst => Identset.empty + | Csharpminor.Eunop op e1 => addr_taken_expr e1 + | Csharpminor.Ebinop op e1 e2 => + Identset.union (addr_taken_expr e1) (addr_taken_expr e2) | Csharpminor.Eload chunk e => addr_taken_expr e | Csharpminor.Ecall sig e el => Identset.union (addr_taken_expr e) (addr_taken_exprlist el) @@ -416,23 +363,23 @@ Fixpoint store_parameters overflow machine arithmetic and lead to incorrect code. *) Definition transl_function - (gce: compilenv) (f: Csharpminor.function): option function := + (gce: compilenv) (f: Csharpminor.function): res function := let (cenv, stacksize) := build_compilenv gce f in if zle stacksize Int.max_signed then do tbody <- transl_stmt cenv f.(Csharpminor.fn_body); - Some (mkfunction + OK (mkfunction (Csharpminor.fn_sig f) (Csharpminor.fn_params_names f) (Csharpminor.fn_vars_names f) stacksize (Sseq (store_parameters cenv f.(Csharpminor.fn_params)) tbody)) - else None. + else Error(msg "Cminorgen: too many local variables, stack size exceeded"). -Definition transl_fundef (gce: compilenv) (f: Csharpminor.fundef): option fundef := +Definition transl_fundef (gce: compilenv) (f: Csharpminor.fundef): res fundef := transf_partial_fundef (transl_function gce) f. -Definition transl_globvar (vk: var_kind) := Some tt. +Definition transl_globvar (vk: var_kind) := OK tt. -Definition transl_program (p: Csharpminor.program) : option program := +Definition transl_program (p: Csharpminor.program) : res program := let gce := build_global_compilenv p in transform_partial_program2 (transl_fundef gce) transl_globvar p. diff --git a/cfrontend/Cminorgenproof.v b/cfrontend/Cminorgenproof.v index ad31ff19..5bcb8801 100644 --- a/cfrontend/Cminorgenproof.v +++ b/cfrontend/Cminorgenproof.v @@ -2,6 +2,7 @@ Require Import FSets. Require Import Coqlib. +Require Import Errors. Require Import Maps. Require Import AST. Require Import Integers. @@ -11,68 +12,49 @@ Require Import Mem. Require Import Events. Require Import Globalenvs. Require Import Csharpminor. -Require Import Op. Require Import Cminor. -Require Cmconstr. Require Import Cminorgen. -Require Import Cmconstrproof. + +Open Local Scope error_monad_scope. Section TRANSLATION. Variable prog: Csharpminor.program. Variable tprog: program. -Hypothesis TRANSL: transl_program prog = Some tprog. +Hypothesis TRANSL: transl_program prog = OK tprog. Let ge : Csharpminor.genv := Genv.globalenv prog. Let tge: genv := Genv.globalenv tprog. Let gce : compilenv := build_global_compilenv 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_partial2 with (transl_fundef gce) transl_globvar. - exact TRANSL. -Qed. +Proof (Genv.find_symbol_transf_partial2 (transl_fundef gce) transl_globvar _ 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 gce f = Some tf. -Proof. - intros. - generalize - (Genv.find_funct_ptr_transf_partial2 (transl_fundef gce) transl_globvar TRANSL H). - case (transl_fundef gce f). - intros tf [A B]. exists tf. tauto. - intros [A B]. elim B. reflexivity. -Qed. + Genv.find_funct_ptr tge b = Some tf /\ transl_fundef gce f = OK tf. +Proof (Genv.find_funct_ptr_transf_partial2 (transl_fundef gce) transl_globvar TRANSL). + Lemma functions_translated: forall (v: val) (f: Csharpminor.fundef), Genv.find_funct ge v = Some f -> exists tf, - Genv.find_funct tge v = Some tf /\ transl_fundef gce f = Some tf. -Proof. - intros. - generalize - (Genv.find_funct_transf_partial2 (transl_fundef gce) transl_globvar TRANSL H). - case (transl_fundef gce f). - intros tf [A B]. exists tf. tauto. - intros [A B]. elim B. reflexivity. -Qed. + Genv.find_funct tge v = Some tf /\ transl_fundef gce f = OK tf. +Proof (Genv.find_funct_transf_partial2 (transl_fundef gce) transl_globvar TRANSL). Lemma sig_preserved: forall f tf, - transl_fundef gce f = Some tf -> + transl_fundef gce f = OK tf -> Cminor.funsig tf = Csharpminor.funsig f. Proof. intros until tf; destruct f; simpl. unfold transl_function. destruct (build_compilenv gce f). - case (zle z Int.max_signed); try congruence. - intro. case (transl_stmt c (Csharpminor.fn_body f)); simpl; try congruence. - intros. inversion H. reflexivity. - intro. inversion H; reflexivity. + case (zle z Int.max_signed); simpl; try congruence. + intros. monadInv H. monadInv EQ. reflexivity. + intro. inv H. reflexivity. Qed. Definition global_compilenv_match (ce: compilenv) (gv: gvarenv) : Prop := @@ -510,15 +492,12 @@ Lemma load_from_alloc_is_undef: alloc m1 0 (size_chunk chunk) = (m2, b) -> load chunk m2 b 0 = Some Vundef. Proof. - intros. - assert (valid_block m2 b). eapply valid_new_block; eauto. - assert (low_bound m2 b <= 0). - generalize (low_bound_alloc _ _ b _ _ _ H). rewrite zeq_true. omega. - assert (0 + size_chunk chunk <= high_bound m2 b). - generalize (high_bound_alloc _ _ b _ _ _ H). rewrite zeq_true. omega. - elim (load_in_bounds _ _ _ _ H0 H1 H2). intros v LOAD. - assert (v = Vundef). eapply load_alloc_same; eauto. - congruence. + intros. + assert (exists v, load chunk m2 b 0 = Some v). + apply valid_access_load. + eapply valid_access_alloc_same; eauto; omega. + destruct H0 as [v LOAD]. rewrite LOAD. decEq. + eapply load_alloc_same; eauto. Qed. Lemma match_env_alloc_same: @@ -577,14 +556,20 @@ Proof. contradiction. (* other vars *) generalize (me_vars0 id0); intros. - inversion H6; econstructor; eauto. - unfold e2; rewrite PTree.gso; auto. - unfold f2, extend_inject, eq_block; rewrite zeq_false; auto. - generalize (me_bounded0 _ _ _ H8). unfold block in *; omega. - unfold e2; rewrite PTree.gso; eauto. - unfold e2; rewrite PTree.gso; eauto. - unfold e2; rewrite PTree.gso; eauto. - unfold e2; rewrite PTree.gso; eauto. + inversion H6. + eapply match_var_local with (v := v); eauto. + unfold e2; rewrite PTree.gso; eauto. + eapply load_alloc_other; eauto. + unfold f2, extend_inject, eq_block; rewrite zeq_false; auto. + generalize (me_bounded0 _ _ _ H8). unfold block in *; omega. + econstructor; eauto. + unfold e2; rewrite PTree.gso; eauto. + econstructor; eauto. + unfold e2; rewrite PTree.gso; eauto. + econstructor; eauto. + unfold e2; rewrite PTree.gso; eauto. + econstructor; eauto. + unfold e2; rewrite PTree.gso; eauto. (* lo <= hi *) unfold block in *; omega. (* me_bounded *) @@ -629,9 +614,15 @@ Proof. inversion H2. constructor; auto. (* me_vars *) intros. generalize (me_vars0 id); intro. - inversion H5; econstructor; eauto. - unfold f2, extend_inject, eq_block. rewrite zeq_false. auto. - generalize (me_bounded0 _ _ _ H7). unfold block in *; omega. + inversion H5. + eapply match_var_local with (v := v); eauto. + eapply load_alloc_other; eauto. + unfold f2, extend_inject, eq_block. rewrite zeq_false. auto. + generalize (me_bounded0 _ _ _ H7). unfold block in *; omega. + econstructor; eauto. + econstructor; eauto. + econstructor; eauto. + econstructor; eauto. (* me_bounded *) intros until delta. unfold f2, extend_inject, eq_block. case (zeq b0 b); intros. rewrite H5 in H0. omegaContradiction. @@ -726,9 +717,10 @@ Proof. (* me_vars *) intros. generalize (me_vars0 id); intro. inversion H5. (* var_local *) - econstructor; eauto. + eapply match_var_local with (v := v); eauto. + eapply load_alloc_other; eauto. generalize (me_bounded0 _ _ _ H7). intro. - unfold f2, extend_inject. case (eq_block b0 b); intro. + unfold f2, extend_inject. case (zeq b0 b); intro. subst b0. rewrite BEQ in H12. omegaContradiction. auto. (* var_stack_scalar *) @@ -740,12 +732,12 @@ Proof. (* var_global_array *) econstructor; eauto. (* me_bounded *) - intros until delta. unfold f2, extend_inject. case (eq_block b0 b); intro. + intros until delta. unfold f2, extend_inject. case (zeq b0 b); intro. intro. injection H5; clear H5; intros. rewrite H6 in TBEQ. rewrite TBEQ in H3. omegaContradiction. eauto. (* me_inj *) - intros until delta. unfold f2, extend_inject. case (eq_block b0 b); intros. + intros until delta. unfold f2, extend_inject. case (zeq b0 b); intros. injection H5; clear H5; intros; subst b0 tb0 delta. rewrite BEQ in H6. omegaContradiction. eauto. @@ -804,16 +796,7 @@ Qed. (** * Correctness of Cminor construction functions *) -Hint Resolve eval_negint eval_negfloat eval_absfloat eval_intoffloat - eval_floatofint eval_floatofintu eval_notint eval_notbool - eval_cast8signed eval_cast8unsigned eval_cast16signed - eval_cast16unsigned eval_singleoffloat eval_add eval_add_ptr - eval_add_ptr_2 eval_sub eval_sub_ptr_int eval_sub_ptr_ptr - eval_mul eval_divs eval_mods eval_divu eval_modu - eval_and eval_or eval_xor eval_shl eval_shr eval_shru - eval_addf eval_subf eval_mulf eval_divf - eval_cmp eval_cmp_null_r eval_cmp_null_l eval_cmp_ptr - eval_cmpu eval_cmpf: evalexpr. +Hint Resolve eval_Econst eval_Eunop eval_Ebinop eval_Eload: evalexpr. Remark val_inject_val_of_bool: forall f b, val_inject f (Val.of_bool b) (Val.of_bool b). @@ -821,151 +804,146 @@ Proof. intros; destruct b; unfold Val.of_bool, Vtrue, Vfalse; constructor. Qed. +Remark val_inject_bool_of_val: + forall f v b tv, + val_inject f v tv -> Val.bool_of_val v b -> Val.bool_of_val tv b. +Proof. + intros. inv H; inv H0; constructor; auto. +Qed. + +Remark val_inject_eval_compare_null: + forall f c i v, + eval_compare_null c i = Some v -> + val_inject f v v. +Proof. + unfold eval_compare_null; intros. + destruct (Int.eq i Int.zero). + destruct c; inv H; unfold Vfalse, Vtrue; constructor. + discriminate. +Qed. + Ltac TrivialOp := match goal with - | [ |- exists x, _ /\ val_inject _ (Vint ?x) _ ] => + | [ |- exists y, _ /\ val_inject _ (Vint ?x) _ ] => exists (Vint x); split; [eauto with evalexpr | constructor] - | [ |- exists x, _ /\ val_inject _ (Vfloat ?x) _ ] => + | [ |- exists y, _ /\ val_inject _ (Vfloat ?x) _ ] => exists (Vfloat x); split; [eauto with evalexpr | constructor] - | [ |- exists x, _ /\ val_inject _ (Val.of_bool ?x) _ ] => + | [ |- exists y, _ /\ val_inject _ (Val.of_bool ?x) _ ] => exists (Val.of_bool x); split; [eauto with evalexpr | apply val_inject_val_of_bool] + | [ |- exists y, Some ?x = Some y /\ val_inject _ _ _ ] => + exists x; split; [auto | econstructor; eauto] | _ => idtac end. -Remark eval_compare_null_inv: - forall c i v, - Csharpminor.eval_compare_null c i = Some v -> - i = Int.zero /\ (c = Ceq /\ v = Vfalse \/ c = Cne /\ v = Vtrue). +(** Correctness of [transl_constant]. *) + +Lemma transl_constant_correct: + forall f sp cst v, + Csharpminor.eval_constant cst = Some v -> + exists tv, + eval_constant tge sp (transl_constant cst) = Some tv + /\ val_inject f v tv. Proof. - intros until v. unfold Csharpminor.eval_compare_null. - predSpec Int.eq Int.eq_spec i Int.zero. - case c; intro EQ; simplify_eq EQ; intro; subst v; tauto. - congruence. + destruct cst; simpl; intros; inv H; TrivialOp. Qed. -(** Correctness of [make_op]. The generated Cminor code evaluates - to a value that matches the result value of the Csharpminor operation, - provided arguments match pairwise ([val_list_inject f] hypothesis). *) +(** Compatibility of [eval_unop] with respect to [val_inject]. *) -Lemma make_op_correct: - forall al a op vl m2 v sp le te tm1 t tm2 tvl f, - make_op op al = Some a -> - Csharpminor.eval_operation op vl m2 = Some v -> - eval_exprlist tge (Vptr sp Int.zero) le te tm1 al t tm2 tvl -> - val_list_inject f vl tvl -> - mem_inject f m2 tm2 -> +Lemma eval_unop_compat: + forall f op v1 tv1 v, + eval_unop op v1 = Some v -> + val_inject f v1 tv1 -> exists tv, - eval_expr tge (Vptr sp Int.zero) le te tm1 a t tm2 tv + eval_unop op tv1 = Some tv /\ val_inject f v tv. Proof. - intros. - destruct al as [ | a1 al]; - [idtac | destruct al as [ | a2 al]; - [idtac | destruct al as [ | a3 al]]]; - simpl in H; try discriminate. - (* Constant operators *) - inversion H1. subst sp0 le0 e m tm1 tvl. - inversion H2. subst vl. - destruct op; simplify_eq H; intro; subst a; - simpl in H0; injection H0; intro; subst v. - (* intconst *) - TrivialOp. econstructor. constructor. reflexivity. - (* floatconst *) - TrivialOp. econstructor. constructor. reflexivity. - (* Unary operators *) - inversion H1; clear H1; subst. - inversion H11; clear H11; subst. - rewrite E0_right. - inversion H2; clear H2; subst. inversion H8; clear H8; subst. - destruct op; simplify_eq H; intro; subst a; - simpl in H0; destruct v1; simplify_eq H0; intro; subst v; - inversion H7; subst v0; - TrivialOp. - change (Vint (Int.cast8unsigned i)) with (Val.cast8unsigned (Vint i)). eauto with evalexpr. - change (Vint (Int.cast8signed i)) with (Val.cast8signed (Vint i)). eauto with evalexpr. - change (Vint (Int.cast16unsigned i)) with (Val.cast16unsigned (Vint i)). eauto with evalexpr. - change (Vint (Int.cast16signed i)) with (Val.cast16signed (Vint i)). eauto with evalexpr. - replace (Int.eq i Int.zero) with (negb (negb (Int.eq i Int.zero))). - eapply eval_notbool. eauto. - generalize (Int.eq_spec i Int.zero). destruct (Int.eq i Int.zero); intro; simpl. - rewrite H1; constructor. constructor; auto. - apply negb_elim. - unfold Vfalse; TrivialOp. change (Vint Int.zero) with (Val.of_bool (negb true)). - eapply eval_notbool. eauto. constructor. - change (Vfloat (Float.singleoffloat f0)) with (Val.singleoffloat (Vfloat f0)). eauto with evalexpr. - (* Binary operations *) - inversion H1; clear H1; subst. inversion H11; clear H11; subst. - inversion H12; clear H12; subst. rewrite E0_right. - inversion H2; clear H2; subst. inversion H9; clear H9; subst. - inversion H10; clear H10; subst. - destruct op; simplify_eq H; intro; subst a; - simpl in H0; destruct v2; destruct v3; simplify_eq H0; intro; try subst v; - inversion H7; inversion H8; subst v0; subst v1; - TrivialOp. - (* add int ptr *) - exists (Vptr b2 (Int.add ofs2 i)); split. - eauto with evalexpr. apply val_inject_ptr with x. auto. - subst ofs2. repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. - (* add ptr int *) - exists (Vptr b2 (Int.add ofs2 i0)); split. - eauto with evalexpr. apply val_inject_ptr with x. auto. - subst ofs2. repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. - (* sub ptr int *) - exists (Vptr b2 (Int.sub ofs2 i0)); split. - eauto with evalexpr. apply val_inject_ptr with x. auto. - subst ofs2. apply Int.sub_add_l. - (* sub ptr ptr *) - destruct (eq_block b b0); simplify_eq H0; intro; subst v; subst b0. - assert (b4 = b2). congruence. subst b4. - exists (Vint (Int.sub ofs3 ofs2)); split. - eauto with evalexpr. - subst ofs2 ofs3. replace x0 with x. rewrite Int.sub_shifted. constructor. - congruence. - (* divs *) - generalize (Int.eq_spec i0 Int.zero); destruct (Int.eq i0 Int.zero); intro; - simplify_eq H0; intro; subst v. TrivialOp. - (* divu *) - generalize (Int.eq_spec i0 Int.zero); destruct (Int.eq i0 Int.zero); intro; - simplify_eq H0; intro; subst v. TrivialOp. - (* mods *) - generalize (Int.eq_spec i0 Int.zero); destruct (Int.eq i0 Int.zero); intro; - simplify_eq H0; intro; subst v. TrivialOp. - (* modu *) - generalize (Int.eq_spec i0 Int.zero); destruct (Int.eq i0 Int.zero); intro; - simplify_eq H0; intro; subst v. TrivialOp. - (* shl *) - caseEq (Int.ltu i0 (Int.repr 32)); intro EQ; rewrite EQ in H0; - simplify_eq H0; intro; subst v. TrivialOp. - (* shr *) - caseEq (Int.ltu i0 (Int.repr 32)); intro EQ; rewrite EQ in H0; - simplify_eq H0; intro; subst v. TrivialOp. - (* shru *) - caseEq (Int.ltu i0 (Int.repr 32)); intro EQ; rewrite EQ in H0; - simplify_eq H0; intro; subst v. TrivialOp. - (* cmp int ptr *) - elim (eval_compare_null_inv _ _ _ H0); intros; subst i1 i. - exists v; split. eauto with evalexpr. - elim H12; intros [A B]; subst v; unfold Vtrue, Vfalse; constructor. - (* cmp ptr int *) - elim (eval_compare_null_inv _ _ _ H0); intros; subst i1 i0. - exists v; split. eauto with evalexpr. - elim H12; intros [A B]; subst v; unfold Vtrue, Vfalse; constructor. + destruct op; simpl; intros. + inv H; inv H0; simpl; TrivialOp. + inv H; inv H0; simpl; TrivialOp. + inv H; inv H0; simpl; TrivialOp. + inv H; inv H0; simpl; TrivialOp. + inv H0; inv H. TrivialOp. + inv H0; inv H. TrivialOp. unfold Vfalse; TrivialOp. + inv H0; inv H; TrivialOp. + inv H0; inv H; TrivialOp. + inv H0; inv H; TrivialOp. + inv H; inv H0; simpl; TrivialOp. + inv H0; inv H; TrivialOp. + inv H0; inv H; TrivialOp. + inv H0; inv H; TrivialOp. +Qed. + +(** Compatibility of [eval_binop] with respect to [val_inject]. *) + +Lemma eval_binop_compat: + forall f op v1 tv1 v2 tv2 v m tm, + eval_binop op v1 v2 m = Some v -> + val_inject f v1 tv1 -> + val_inject f v2 tv2 -> + mem_inject f m tm -> + exists tv, + eval_binop op tv1 tv2 tm = Some tv + /\ val_inject f v tv. +Proof. + destruct op; simpl; intros. + inv H0; try discriminate; inv H1; inv H; TrivialOp. + repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. + repeat rewrite Int.add_assoc. decEq. apply Int.add_commut. + inv H0; try discriminate; inv H1; inv H; TrivialOp. + apply Int.sub_add_l. + destruct (eq_block b1 b0); inv H4. + assert (b3 = b2) by congruence. subst b3. + unfold eq_block; rewrite zeq_true. TrivialOp. + replace x0 with x by congruence. decEq. decEq. + apply Int.sub_shifted. + inv H0; try discriminate; inv H1; inv H; TrivialOp. + inv H0; try discriminate; inv H1; inv H; TrivialOp. + destruct (Int.eq i0 Int.zero); inv H1. TrivialOp. + inv H0; try discriminate; inv H1; inv H; TrivialOp. + destruct (Int.eq i0 Int.zero); inv H1. TrivialOp. + inv H0; try discriminate; inv H1; inv H; TrivialOp. + destruct (Int.eq i0 Int.zero); inv H1. TrivialOp. + inv H0; try discriminate; inv H1; inv H; TrivialOp. + destruct (Int.eq i0 Int.zero); inv H1. TrivialOp. + inv H0; try discriminate; inv H1; inv H; TrivialOp. + inv H0; try discriminate; inv H1; inv H; TrivialOp. + inv H0; try discriminate; inv H1; inv H; TrivialOp. + inv H0; try discriminate; inv H1; inv H; TrivialOp. + destruct (Int.ltu i0 (Int.repr 32)); inv H1. TrivialOp. + inv H0; try discriminate; inv H1; inv H; TrivialOp. + destruct (Int.ltu i0 (Int.repr 32)); inv H1. TrivialOp. + inv H0; try discriminate; inv H1; inv H; TrivialOp. + destruct (Int.ltu i0 (Int.repr 32)); inv H1. TrivialOp. + inv H0; try discriminate; inv H1; inv H; TrivialOp. + inv H0; try discriminate; inv H1; inv H; TrivialOp. + inv H0; try discriminate; inv H1; inv H; TrivialOp. + inv H0; try discriminate; inv H1; inv H; TrivialOp. + inv H0; try discriminate; inv H1; inv H; TrivialOp. + exists v; split; auto. eapply val_inject_eval_compare_null; eauto. + exists v; split; auto. eapply val_inject_eval_compare_null; eauto. (* cmp ptr ptr *) - caseEq (valid_pointer m2 b (Int.signed i) && valid_pointer m2 b0 (Int.signed i0)); - intro EQ; rewrite EQ in H0; try discriminate. - destruct (eq_block b b0); simplify_eq H0; intro; subst v b0. - assert (b4 = b2); [congruence|subst b4]. - assert (x0 = x); [congruence|subst x0]. + caseEq (valid_pointer m b1 (Int.signed ofs1) && valid_pointer m b0 (Int.signed ofs0)); + intro EQ; rewrite EQ in H4; try discriminate. + destruct (eq_block b1 b0); inv H4. + assert (b3 = b2) by congruence. subst b3. + assert (x0 = x) by congruence. subst x0. elim (andb_prop _ _ EQ); intros. - exists (Val.of_bool (Int.cmp c ofs3 ofs2)); split. - eauto with evalexpr. - subst ofs2 ofs3. rewrite Int.translate_cmp. - apply val_inject_val_of_bool. + exists (Val.of_bool (Int.cmp c ofs1 ofs0)); split. + exploit (Mem.valid_pointer_inject f m tm b0 ofs0); eauto. + intro VP; rewrite VP; clear VP. + exploit (Mem.valid_pointer_inject f m tm b0 ofs1); eauto. + intro VP; rewrite VP; clear VP. + unfold eq_block; rewrite zeq_true; simpl. + decEq. decEq. rewrite Int.translate_cmp. auto. eapply valid_pointer_inject_no_overflow; eauto. eapply valid_pointer_inject_no_overflow; eauto. + apply val_inject_val_of_bool. + (* *) + inv H0; try discriminate; inv H1; inv H; TrivialOp. + inv H0; try discriminate; inv H1; inv H; TrivialOp. Qed. (** Correctness of [make_cast]. Note that the resulting Cminor value is @@ -980,35 +958,28 @@ Lemma make_cast_correct: te tm1 (make_cast chunk a) t tm2 tv' /\ val_inject f (Val.load_result chunk v) tv'. Proof. - intros. destruct chunk. + intros. destruct chunk; simpl make_cast. exists (Val.cast8signed tv). - split. apply eval_cast8signed; auto. - inversion H0; simpl; constructor. + split. eauto with evalexpr. inversion H0; simpl; constructor. exists (Val.cast8unsigned tv). - split. apply eval_cast8unsigned; auto. - inversion H0; simpl; constructor. + split. eauto with evalexpr. inversion H0; simpl; constructor. exists (Val.cast16signed tv). - split. apply eval_cast16signed; auto. - inversion H0; simpl; constructor. + split. eauto with evalexpr. inversion H0; simpl; constructor. exists (Val.cast16unsigned tv). - split. apply eval_cast16unsigned; auto. - inversion H0; simpl; constructor. + split. eauto with evalexpr. inversion H0; simpl; constructor. - exists tv. - split. simpl; auto. - inversion H0; simpl; econstructor; eauto. + exists tv. + split. auto. inversion H0; simpl; econstructor; eauto. exists (Val.singleoffloat tv). - split. apply eval_singleoffloat; auto. - inversion H0; simpl; constructor. + split. eauto with evalexpr. inversion H0; simpl; constructor. - exists tv. - split. simpl; auto. - inversion H0; simpl; constructor. + exists tv. + split. auto. inversion H0; simpl; econstructor; eauto. Qed. Lemma make_stackaddr_correct: @@ -1018,7 +989,7 @@ Lemma make_stackaddr_correct: E0 tm (Vptr sp (Int.repr ofs)). Proof. intros; unfold make_stackaddr. - eapply eval_Eop. econstructor. simpl. decEq. decEq. + econstructor. simpl. decEq. decEq. rewrite Int.add_commut. apply Int.add_zero. Qed. @@ -1030,22 +1001,10 @@ Lemma make_globaladdr_correct: E0 tm (Vptr b Int.zero). Proof. intros; unfold make_globaladdr. - eapply eval_Eop. econstructor. simpl. rewrite H. auto. + econstructor. simpl. rewrite H. auto. Qed. -(** Correctness of [make_load] and [make_store]. *) - -Lemma make_load_correct: - forall sp le te tm1 a t tm2 va chunk v, - eval_expr tge (Vptr sp Int.zero) le te tm1 a t tm2 va -> - Mem.loadv chunk tm2 va = Some v -> - eval_expr tge (Vptr sp Int.zero) le - te tm1 (make_load chunk a) - t tm2 v. -Proof. - intros; unfold make_load. - eapply eval_load; eauto. -Qed. +(** Correctness of [make_store]. *) Lemma store_arg_content_inject: forall f sp le te tm1 a t tm2 v va chunk, @@ -1053,25 +1012,23 @@ Lemma store_arg_content_inject: val_inject f v va -> exists vb, eval_expr tge (Vptr sp Int.zero) le te tm1 (store_arg chunk a) t tm2 vb - /\ val_content_inject f (mem_chunk chunk) v vb. + /\ val_content_inject f chunk v vb. Proof. intros. assert (exists vb, eval_expr tge (Vptr sp Int.zero) le te tm1 a t tm2 vb - /\ val_content_inject f (mem_chunk chunk) v vb). + /\ val_content_inject f chunk v vb). exists va; split. assumption. constructor. assumption. - inversion H; clear H; subst; simpl; trivial. - inversion H2; clear H2; subst; trivial. - inversion H4; clear H4; subst; trivial. - rewrite E0_right. rewrite E0_right in H1. - destruct op; trivial; destruct chunk; trivial; - exists v0; (split; [auto| - simpl in H3; inversion H3; clear H3; subst va; - destruct v0; simpl in H0; inversion H0; subst; try (constructor; constructor)]). - apply val_content_inject_8. apply Int.cast8_unsigned_signed. - apply val_content_inject_8. apply Int.cast8_unsigned_idem. - apply val_content_inject_16. apply Int.cast16_unsigned_signed. - apply val_content_inject_16. apply Int.cast16_unsigned_idem. + destruct a; simpl store_arg; trivial; + destruct u; trivial; + destruct chunk; trivial; + inv H; simpl in H12; inv H12; + econstructor; (split; [eauto|idtac]); + destruct v1; simpl in H0; inv H0; try (constructor; constructor). + apply val_content_inject_8. auto. apply Int.cast8_unsigned_idem. + apply val_content_inject_8; auto. apply Int.cast8_unsigned_signed. + apply val_content_inject_16; auto. apply Int.cast16_unsigned_idem. + apply val_content_inject_16; auto. apply Int.cast16_unsigned_signed. apply val_content_inject_32. apply Float.singleoffloat_idem. Qed. @@ -1098,13 +1055,11 @@ Proof. intros [tv [EVAL VCINJ]]. exploit storev_mapped_inject_1; eauto. intros [tm4 [STORE MEMINJ]]. - exploit eval_store. eexact H. eexact EVAL. eauto. - intro EVALSTORE. exists tm4. - split. apply exec_Sexpr with tv. auto. + split. apply exec_Sexpr with tv. eapply eval_Estore; eauto. split. auto. unfold storev in STORE; destruct tvaddr; try discriminate. - exploit store_inv; eauto. simpl. tauto. + eapply nextblock_store; eauto. Qed. (** Correctness of the variable accessors [var_get], [var_set] @@ -1112,7 +1067,7 @@ Qed. Lemma var_get_correct: forall cenv id a f e te sp lo hi m cs tm b chunk v le, - var_get cenv id = Some a -> + var_get cenv id = OK a -> match_callstack f (mkframe cenv e te sp lo hi :: cs) m.(nextblock) tm.(nextblock) m -> mem_inject f m tm -> eval_var_ref prog e id b chunk -> @@ -1138,7 +1093,7 @@ Proof. unfold loadv. eexact H3. intros [tv [LOAD INJ]]. exists tv; split. - eapply make_load_correct; eauto. eapply make_stackaddr_correct; eauto. + econstructor; eauto. eapply make_stackaddr_correct; eauto. auto. (* var_global_scalar *) inversion H2; [congruence|subst]. @@ -1151,14 +1106,14 @@ Proof. generalize (loadv_inject _ _ _ _ _ _ _ H1 H12 H13). intros [tv [LOAD INJ]]. exists tv; split. - eapply make_load_correct; eauto. eapply make_globaladdr_correct; eauto. + econstructor; eauto. eapply make_globaladdr_correct; eauto. auto. Qed. Lemma var_addr_correct: forall cenv id a f e te sp lo hi m cs tm b le, match_callstack f (mkframe cenv e te sp lo hi :: cs) m.(nextblock) tm.(nextblock) m -> - var_addr cenv id = Some a -> + var_addr cenv id = OK a -> eval_var_addr prog e id b -> exists tv, eval_expr tge (Vptr sp Int.zero) le te tm a E0 tm tv /\ @@ -1196,7 +1151,7 @@ Qed. Lemma var_set_correct: forall cenv id rhs a f e te sp lo hi m2 cs tm2 tm1 tv b chunk v m3 t, - var_set cenv id rhs = Some a -> + var_set cenv id rhs = OK a -> match_callstack f (mkframe cenv e te sp lo hi :: cs) m2.(nextblock) tm2.(nextblock) m2 -> eval_expr tge (Vptr sp Int.zero) nil te tm1 rhs t tm2 tv -> val_inject f v tv -> @@ -1210,7 +1165,7 @@ Lemma var_set_correct: Proof. unfold var_set; intros. assert (NEXTBLOCK: nextblock m3 = nextblock m2). - exploit store_inv; eauto. simpl; tauto. + eapply nextblock_store; eauto. inversion H0. subst. assert (match_var f id e m2 te sp cenv!!id). inversion H19; auto. inversion H6; subst; rewrite <- H7 in H; inversion H; subst; clear H. @@ -1337,7 +1292,7 @@ Proof. unfold f1; rewrite <- H2; eapply match_callstack_alloc_left; eauto. rewrite <- H1. omega. intros until delta; unfold f1, extend_inject, eq_block. - rewrite (high_bound_alloc _ _ b _ _ _ H). + rewrite (high_bound_alloc _ _ _ _ _ H b). case (zeq b b1); intros. inversion H3. unfold sizeof; rewrite LV. omega. generalize (BOUND _ _ H3). omega. @@ -1350,7 +1305,7 @@ Proof. exploit IHalloc_variables; eauto. unfold f1; rewrite <- H2; eapply match_callstack_alloc_left; eauto. intros until delta; unfold f1, extend_inject, eq_block. - rewrite (high_bound_alloc _ _ b _ _ _ H). + rewrite (high_bound_alloc _ _ _ _ _ H b). case (zeq b b1); intros. discriminate. eapply BOUND; eauto. intros [f' [INCR2 [MINJ2 MATCH2]]]. @@ -1373,7 +1328,7 @@ Proof. unfold f1; rewrite <- H2; eapply match_callstack_alloc_left; eauto. rewrite <- H1. omega. intros until delta; unfold f1, extend_inject, eq_block. - rewrite (high_bound_alloc _ _ b _ _ _ H). + rewrite (high_bound_alloc _ _ _ _ _ H b). case (zeq b b1); intros. inversion H6. unfold sizeof; rewrite LV. omega. generalize (BOUND _ _ H6). omega. @@ -1439,10 +1394,9 @@ Proof. intros. assert (SP: sp = nextblock tm). injection H2; auto. unfold build_compilenv in H. - eapply match_callstack_alloc_variables_rec with (sz' := sz); eauto. - eapply valid_new_block; eauto. - rewrite (low_bound_alloc _ _ sp _ _ _ H2). apply zeq_true. - rewrite (high_bound_alloc _ _ sp _ _ _ H2). apply zeq_true. + eapply match_callstack_alloc_variables_rec with (sz' := sz); eauto with mem. + eapply low_bound_alloc_same; eauto. + eapply high_bound_alloc_same; eauto. (* match_callstack *) constructor. omega. change (valid_block tm' sp). eapply valid_new_block; eauto. constructor. @@ -1460,15 +1414,15 @@ Proof. (* me_inj *) intros until lv2. unfold Csharpminor.empty_env; rewrite PTree.gempty; congruence. (* me_inv *) - intros. exploit mi_mappedblocks; eauto. intros [A B]. + intros. exploit mi_mappedblocks; eauto. intro A. elim (fresh_block_alloc _ _ _ _ _ H2 A). (* me_incr *) - intros. exploit mi_mappedblocks; eauto. intros [A B]. + intros. exploit mi_mappedblocks; eauto. intro A. rewrite SP; auto. rewrite SP; auto. eapply alloc_right_inject; eauto. omega. - intros. exploit mi_mappedblocks; eauto. intros [A B]. + intros. exploit mi_mappedblocks; eauto. unfold valid_block; intro. unfold block in SP; omegaContradiction. (* defined *) intros. unfold te. apply set_locals_params_defined. @@ -1569,7 +1523,7 @@ Proof. inversion H18. inversion NOREPET. subst hd tl. assert (NEXT: nextblock m1 = nextblock m). - exploit store_inv; eauto. simpl; tauto. + eapply nextblock_store; eauto. generalize (me_vars0 id). intro. inversion H2; subst. (* cenv!!id = Var_local chunk *) assert (b0 = b). congruence. subst b0. @@ -1724,43 +1678,6 @@ Qed. (** * Semantic preservation for the translation *) -(** These tactics simplify hypotheses of the form [f ... = Some x]. *) - -Ltac monadSimpl1 := - match goal with - | [ |- (bind _ _ ?F ?G = Some ?X) -> _ ] => - unfold bind at 1; - generalize (refl_equal F); - pattern F at -1 in |- *; - case F; - [ (let EQ := fresh "EQ" in - (intro; intro EQ; - try monadSimpl1)) - | intros; discriminate ] - | [ |- (None = Some _) -> _ ] => - intro; discriminate - | [ |- (Some _ = Some _) -> _ ] => - let h := fresh "H" in - (intro h; injection h; intro; clear h) - end. - -Ltac monadSimpl := - match goal with - | [ |- (bind _ _ ?F ?G = Some ?X) -> _ ] => monadSimpl1 - | [ |- (None = Some _) -> _ ] => monadSimpl1 - | [ |- (Some _ = Some _) -> _ ] => monadSimpl1 - | [ |- (?F _ _ _ _ _ _ _ = Some _) -> _ ] => simpl F; monadSimpl1 - | [ |- (?F _ _ _ _ _ _ = Some _) -> _ ] => simpl F; monadSimpl1 - | [ |- (?F _ _ _ _ _ = Some _) -> _ ] => simpl F; monadSimpl1 - | [ |- (?F _ _ _ _ = Some _) -> _ ] => simpl F; monadSimpl1 - | [ |- (?F _ _ _ = Some _) -> _ ] => simpl F; monadSimpl1 - | [ |- (?F _ _ = Some _) -> _ ] => simpl F; monadSimpl1 - | [ |- (?F _ = Some _) -> _ ] => simpl F; monadSimpl1 - end. - -Ltac monadInv H := - generalize H; monadSimpl. - (** The proof of semantic preservation uses simulation diagrams of the following form: << @@ -1790,7 +1707,7 @@ Ltac monadInv H := Definition eval_expr_prop (le: Csharpminor.letenv) (e: Csharpminor.env) (m1: mem) (a: Csharpminor.expr) (t: trace) (m2: mem) (v: val) : Prop := forall cenv ta f1 tle te tm1 sp lo hi cs - (TR: transl_expr cenv a = Some ta) + (TR: transl_expr cenv a = OK ta) (LINJ: val_list_inject f1 le tle) (MINJ: mem_inject f1 m1 tm1) (MATCH: match_callstack f1 @@ -1808,7 +1725,7 @@ Definition eval_expr_prop Definition eval_exprlist_prop (le: Csharpminor.letenv) (e: Csharpminor.env) (m1: mem) (al: Csharpminor.exprlist) (t: trace) (m2: mem) (vl: list val) : Prop := forall cenv tal f1 tle te tm1 sp lo hi cs - (TR: transl_exprlist cenv al = Some tal) + (TR: transl_exprlist cenv al = OK tal) (LINJ: val_list_inject f1 le tle) (MINJ: mem_inject f1 m1 tm1) (MATCH: match_callstack f1 @@ -1826,7 +1743,7 @@ Definition eval_exprlist_prop Definition eval_funcall_prop (m1: mem) (fn: Csharpminor.fundef) (args: list val) (t: trace) (m2: mem) (res: val) : Prop := forall tfn f1 tm1 cs targs - (TR: transl_fundef gce fn = Some tfn) + (TR: transl_fundef gce fn = OK tfn) (MINJ: mem_inject f1 m1 tm1) (MATCH: match_callstack f1 cs m1.(nextblock) tm1.(nextblock) m1) (ARGSINJ: val_list_inject f1 args targs), @@ -1852,7 +1769,7 @@ Inductive outcome_inject (f: meminj) : Csharpminor.outcome -> outcome -> Prop := Definition exec_stmt_prop (e: Csharpminor.env) (m1: mem) (s: Csharpminor.stmt) (t: trace) (m2: mem) (out: Csharpminor.outcome): Prop := forall cenv ts f1 te1 tm1 sp lo hi cs - (TR: transl_stmt cenv s = Some ts) + (TR: transl_stmt cenv s = OK ts) (MINJ: mem_inject f1 m1 tm1) (MATCH: match_callstack f1 (mkframe cenv e te1 sp lo hi :: cs) @@ -1897,21 +1814,61 @@ Proof. exists f1; exists tm1; exists tv. intuition eauto. Qed. -Lemma transl_expr_Eop_correct: - forall (le : Csharpminor.letenv) (e : Csharpminor.env) (m : mem) - (op : Csharpminor.operation) (al : Csharpminor.exprlist) - (t: trace) (m1 : mem) (vl : list val) (v : val), - Csharpminor.eval_exprlist prog le e m al t m1 vl -> - eval_exprlist_prop le e m al t m1 vl -> - Csharpminor.eval_operation op vl m1 = Some v -> - eval_expr_prop le e m (Csharpminor.Eop op al) t m1 v. -Proof. - intros; red; intros. monadInv TR; intro EQ0. +Lemma transl_expr_Econst_correct: + forall (le : Csharpminor.letenv) (e : Csharpminor.env) (m : mem) + (cst : Csharpminor.constant) (v : val), + Csharpminor.eval_constant cst = Some v -> + eval_expr_prop le e m (Csharpminor.Econst cst) E0 m v. +Proof. + intros; red; intros; monadInv TR. + exploit transl_constant_correct; eauto. + intros [tv [EVAL VINJ]]. + exists f1; exists tm1; exists tv. intuition eauto. + constructor; eauto. +Qed. + +Lemma transl_expr_Eunop_correct: + forall (le : Csharpminor.letenv) (e : Csharpminor.env) (m : mem) + (op : unary_operation) (a : Csharpminor.expr) (t : trace) + (m1 : mem) (v1 v : val), + Csharpminor.eval_expr prog le e m a t m1 v1 -> + eval_expr_prop le e m a t m1 v1 -> + Csharpminor.eval_unop op v1 = Some v -> + eval_expr_prop le e m (Csharpminor.Eunop op a) t m1 v. +Proof. + intros; red; intros. monadInv TR. exploit H0; eauto. intros [f2 [tm2 [tvl [EVAL1 [VINJ1 [MINJ1 [INCR1 MATCH1]]]]]]]. - exploit make_op_correct; eauto. - intros [tv [EVAL2 VINJ2]]. - exists f2; exists tm2; exists tv. intuition. + exploit eval_unop_compat; eauto. intros [tv [EVAL VINJ]]. + exists f2; exists tm2; exists tv; intuition. + econstructor; eauto. +Qed. + +Lemma transl_expr_Ebinop_correct: + forall (le : Csharpminor.letenv) (e : Csharpminor.env) (m : mem) + (op : binary_operation) (a1 a2 : Csharpminor.expr) (t1 : trace) + (m1 : mem) (v1 : val) (t2 : trace) (m2 : mem) (v2 : val) + (t : trace) (v : val), + Csharpminor.eval_expr prog le e m a1 t1 m1 v1 -> + eval_expr_prop le e m a1 t1 m1 v1 -> + Csharpminor.eval_expr prog le e m1 a2 t2 m2 v2 -> + eval_expr_prop le e m1 a2 t2 m2 v2 -> + Csharpminor.eval_binop op v1 v2 m2 = Some v -> + t = t1 ** t2 -> + eval_expr_prop le e m (Csharpminor.Ebinop op a1 a2) t m2 v. +Proof. + intros; red; intros. monadInv TR. + exploit H0; eauto. + intros [f2 [tm2 [tvl [EVAL1 [VINJ1 [MINJ1 [INCR1 MATCH1]]]]]]]. + exploit H2. + eauto. eapply val_list_inject_incr; eauto. eauto. eauto. + intros [f3 [tm3 [tv2 [EVAL2 [VINJ2 [MINJ2 [INCR2 MATCH2]]]]]]]. + exploit eval_binop_compat. + eauto. eapply val_inject_incr; eauto. eauto. eauto. + intros [tv [EVAL VINJ]]. + exists f3; exists tm3; exists tv; intuition. + econstructor; eauto. + eapply inject_incr_trans; eauto. Qed. Lemma transl_expr_Eload_correct: @@ -1931,7 +1888,7 @@ Proof. intros [tv [TLOAD VINJ]]. exists f2; exists tm2; exists tv. intuition. - subst ta. eapply make_load_correct; eauto. + econstructor; eauto. Qed. Lemma transl_expr_Ecall_correct: @@ -1951,7 +1908,7 @@ Lemma transl_expr_Ecall_correct: t = t1 ** t2 ** t3 -> eval_expr_prop le e m (Csharpminor.Ecall sig a bl) t m3 vres. Proof. - intros;red;intros. monadInv TR. subst ta. + intros;red;intros. monadInv TR. exploit H0; eauto. intros [f2 [tm2 [tv1 [EVAL1 [VINJ1 [MINJ1 [INCR1 MATCH1]]]]]]]. exploit H2. @@ -1960,18 +1917,18 @@ Proof. assert (tv1 = vf). elim (Genv.find_funct_inv H3). intros bf VF. rewrite VF in H3. rewrite Genv.find_funct_find_funct_ptr in H3. - generalize (Genv.find_funct_ptr_inv H3). intro. + generalize (Genv.find_funct_ptr_negative H3). intro. assert (match_globalenvs f2). eapply match_callstack_match_globalenvs; eauto. - generalize (mg_functions _ H9 _ H8). intro. + generalize (mg_functions _ H7 _ H4). intro. rewrite VF in VINJ1. inversion VINJ1. subst vf. decEq. congruence. - subst ofs2. replace x with 0. reflexivity. congruence. + subst ofs2. replace x1 with 0. reflexivity. congruence. subst tv1. elim (functions_translated _ _ H3). intros tf [FIND TRF]. exploit H6; eauto. intros [f4 [tm4 [tres [EVAL3 [VINJ3 [MINJ3 [INCR3 MATCH3]]]]]]]. exists f4; exists tm4; exists tres. intuition. eapply eval_Ecall; eauto. - rewrite <- H4. apply sig_preserved; auto. + apply sig_preserved; auto. apply inject_incr_trans with f2; auto. apply inject_incr_trans with f3; auto. Qed. @@ -1996,8 +1953,8 @@ Proof. intros [f3 [tm3 [tv2 [EVAL2 [VINJ2 [MINJ2 [INCR2 MATCH2]]]]]]]. exists f3; exists tm3; exists tv2. intuition. - rewrite <- H6. subst t; eapply eval_conditionalexpr_true; eauto. - inversion VINJ1; subst v1 tv1; simpl in H1; simpl; contradiction || auto. + eapply eval_Econdition with (b1 := true); eauto. + eapply val_inject_bool_of_val; eauto. apply Val.bool_of_true_val; eauto. eapply inject_incr_trans; eauto. Qed. @@ -2021,8 +1978,8 @@ Proof. intros [f3 [tm3 [tv2 [EVAL2 [VINJ2 [MINJ2 [INCR2 MATCH2]]]]]]]. exists f3; exists tm3; exists tv2. intuition. - rewrite <- H6. subst t; eapply eval_conditionalexpr_false; eauto. - inversion VINJ1; subst v1 tv1; simpl in H1; simpl; contradiction || auto. + eapply eval_Econdition with (b1 := false); eauto. + eapply val_inject_bool_of_val; eauto. apply Val.bool_of_false_val; eauto. eapply inject_incr_trans; eauto. Qed. @@ -2047,7 +2004,7 @@ Proof. intros [f3 [tm3 [tv2 [EVAL2 [VINJ2 [MINJ2 [INCR2 MATCH2]]]]]]]. exists f3; exists tm3; exists tv2. intuition. - subst ta; eapply eval_Elet; eauto. + eapply eval_Elet; eauto. eapply inject_incr_trans; eauto. Qed. @@ -2072,7 +2029,7 @@ Proof. exploit val_list_inject_nth; eauto. intros [tv [A B]]. exists f1; exists tm1; exists tv. intuition. - subst ta. eapply eval_Eletvar; auto. + eapply eval_Eletvar; auto. Qed. Lemma transl_expr_Ealloc_correct: @@ -2095,7 +2052,7 @@ Proof. intros [MINJ3 INCR3]. exists (extend_inject b (Some (tb, 0)) f2); exists tm3; exists (Vptr tb Int.zero). - split. subst ta; econstructor; eauto. + split. econstructor; eauto. split. econstructor. unfold extend_inject, eq_block. rewrite zeq_true. reflexivity. reflexivity. split. assumption. @@ -2109,7 +2066,7 @@ Lemma transl_exprlist_Enil_correct: Proof. intros; red; intros. monadInv TR. exists f1; exists tm1; exists (@nil val). - intuition. subst tal; constructor. + intuition. constructor. Qed. Lemma transl_exprlist_Econs_correct: @@ -2131,7 +2088,7 @@ Proof. eauto. eapply val_list_inject_incr; eauto. eauto. eauto. intros [f3 [tm3 [tv2 [EVAL2 [VINJ2 [MINJ3 [INCR3 MATCH3]]]]]]]. exists f3; exists tm3; exists (tv1 :: tv2). - intuition. subst tal; econstructor; eauto. + intuition. econstructor; eauto. constructor. eapply val_inject_incr; eauto. auto. eapply inject_incr_trans; eauto. Qed. @@ -2149,15 +2106,11 @@ Lemma transl_funcall_internal_correct: eval_funcall_prop m (Internal f) vargs t (free_list m3 lb) vres. Proof. intros; red. intros tfn f1 tm; intros. - generalize TR; clear TR. - unfold transl_fundef, transf_partial_fundef. - caseEq (transl_function gce f); try congruence. - intros tf TR EQ. inversion EQ; clear EQ; subst tfn. - unfold transl_function in TR. + monadInv TR. generalize EQ. + unfold transl_function. caseEq (build_compilenv gce f); intros cenv stacksize CENV. - rewrite CENV in TR. - destruct (zle stacksize Int.max_signed); try discriminate. - monadInv TR. clear TR. + destruct (zle stacksize Int.max_signed); try congruence. + intro TR. monadInv TR. caseEq (alloc tm 0 stacksize). intros tm1 sp ALLOC. exploit function_entry_ok; eauto. intros [f2 [te2 [tm2 [STOREPARAM [MINJ2 [INCR12 [MATCH2 BLOCKS]]]]]]]. @@ -2177,9 +2130,11 @@ Proof. exists v2; split. auto. subst vres; auto. contradiction. destruct H5 as [tvres [TOUT VINJRES]]. + assert (outcome_free_mem tout tm3 sp = Mem.free tm3 sp). + inversion OUTINJ; auto. exists f3; exists (Mem.free tm3 sp); exists tvres. (* execution *) - split. rewrite <- H6; econstructor; simpl; eauto. + split. rewrite <- H5. econstructor; simpl; eauto. apply exec_Sseq_continue with E0 te2 tm2 t. exact STOREPARAM. eexact EXECBODY. @@ -2195,7 +2150,7 @@ Proof. (* match_callstack *) assert (forall bl mm, nextblock (free_list mm bl) = nextblock mm). induction bl; intros. reflexivity. simpl. auto. - unfold free; simpl nextblock. rewrite H5. + unfold free; simpl nextblock. rewrite H6. eapply match_callstack_freelist; eauto. intros. elim (BLOCKS b); intros B1 B2. generalize (B2 H7). omega. Qed. @@ -2206,8 +2161,7 @@ Lemma transl_funcall_external_correct: event_match ef vargs t vres -> eval_funcall_prop m (External ef) vargs t m vres. Proof. - intros; red; intros. - simpl in TR. inversion TR; clear TR; subst tfn. + intros; red; intros. monadInv TR. exploit event_match_inject; eauto. intros [A B]. exists f1; exists tm1; exists vres; intuition. constructor; auto. @@ -2219,7 +2173,7 @@ Lemma transl_stmt_Sskip_correct: Proof. intros; red; intros. monadInv TR. exists f1; exists te1; exists tm1; exists Out_normal. - intuition. subst ts; constructor. constructor. + intuition. constructor. constructor. Qed. Lemma transl_stmt_Sexpr_correct: @@ -2233,7 +2187,7 @@ Proof. exploit H0; eauto. intros [f2 [tm2 [tv1 [EVAL1 [VINJ1 [MINJ2 [INCR2 MATCH2]]]]]]]. exists f2; exists te1; exists tm2; exists Out_normal. - intuition. subst ts. econstructor; eauto. + intuition. econstructor; eauto. constructor. Qed. @@ -2247,7 +2201,7 @@ Lemma transl_stmt_Sassign_correct: store chunk m1 b 0 v = Some m2 -> exec_stmt_prop e m (Csharpminor.Sassign id a) t m2 Csharpminor.Out_normal. Proof. - intros; red; intros. monadInv TR; intro EQ0. + intros; red; intros. monadInv TR. exploit H0; eauto. intros [f2 [tm2 [tv1 [EVAL1 [VINJ1 [MINJ1 [INCR12 MATCH1]]]]]]]. exploit var_set_correct; eauto. @@ -2282,15 +2236,15 @@ Proof. eapply val_inject_incr; eauto. eauto. intros [tm4 [EVAL [MINJ4 NEXTBLOCK]]]. exists f3; exists te1; exists tm4; exists Out_normal. - rewrite <- H6. subst t3. intuition. + intuition. constructor. eapply inject_incr_trans; eauto. assert (val_inject f3 v1 tv1). eapply val_inject_incr; eauto. unfold storev in H3; destruct v1; try discriminate. inversion H4. rewrite NEXTBLOCK. replace (nextblock m3) with (nextblock m2). - eapply match_callstack_mapped; eauto. congruence. - exploit store_inv; eauto. simpl; symmetry; tauto. + eapply match_callstack_mapped; eauto. congruence. + symmetry. eapply nextblock_store; eauto. Qed. Lemma transl_stmt_Sseq_continue_correct: @@ -2309,7 +2263,7 @@ Proof. exploit H2; eauto. intros [f3 [te3 [tm3 [tout2 [EXEC2 [OINJ2 [MINJ3 [INCR3 MATCH3]]]]]]]]. exists f3; exists te3; exists tm3; exists tout2. - intuition. subst ts; eapply exec_Sseq_continue; eauto. + intuition. eapply exec_Sseq_continue; eauto. inversion OINJ1. subst tout1. auto. eapply inject_incr_trans; eauto. Qed. @@ -2326,7 +2280,7 @@ Proof. exploit H0; eauto. intros [f2 [te2 [tm2 [tout1 [EXEC1 [OINJ1 [MINJ2 [INCR2 MATCH2]]]]]]]]. exists f2; exists te2; exists tm2; exists tout1. - intuition. subst ts; eapply exec_Sseq_stop; eauto. + intuition. eapply exec_Sseq_stop; eauto. inversion OINJ1; subst out tout1; congruence. Qed. @@ -2350,8 +2304,8 @@ Proof. intros [f3 [te3 [tm3 [tout [EVAL2 [OINJ [MINJ3 [INCR3 MATCH3]]]]]]]]. exists f3; exists te3; exists tm3; exists tout. intuition. - subst ts t. eapply exec_ifthenelse_true; eauto. - inversion VINJ1; subst v1 tv1; simpl in H1; simpl; contradiction || auto. + eapply exec_Sifthenelse with (b1 := true); eauto. + eapply val_inject_bool_of_val; eauto. apply Val.bool_of_true_val; auto. eapply inject_incr_trans; eauto. Qed. @@ -2375,8 +2329,8 @@ Proof. intros [f3 [te3 [tm3 [tout [EVAL2 [OINJ [MINJ3 [INCR3 MATCH3]]]]]]]]. exists f3; exists te3; exists tm3; exists tout. intuition. - subst ts t. eapply exec_ifthenelse_false; eauto. - inversion VINJ1; subst v1 tv1; simpl in H1; simpl; contradiction || auto. + eapply exec_Sifthenelse with (b1 := false); eauto. + eapply val_inject_bool_of_val; eauto. apply Val.bool_of_false_val; auto. eapply inject_incr_trans; eauto. Qed. @@ -2391,14 +2345,14 @@ Lemma transl_stmt_Sloop_loop_correct: t = t1 ** t2 -> exec_stmt_prop e m (Csharpminor.Sloop sl) t m2 out. Proof. - intros; red; intros. monadInv TR. + intros; red; intros. generalize TR; intro TR'; monadInv TR'. exploit H0; eauto. intros [f2 [te2 [tm2 [tout1 [EVAL1 [OINJ1 [MINJ2 [INCR2 MATCH2]]]]]]]]. exploit H2; eauto. intros [f3 [te3 [tm3 [tout2 [EVAL2 [OINJ2 [MINJ3 [INCR3 MATCH3]]]]]]]]. exists f3; exists te3; exists tm3; exists tout2. intuition. - subst ts. eapply exec_Sloop_loop; eauto. + eapply exec_Sloop_loop; eauto. inversion OINJ1; subst tout1; eauto. eapply inject_incr_trans; eauto. Qed. @@ -2415,7 +2369,7 @@ Proof. exploit H0; eauto. intros [f2 [te2 [tm2 [tout1 [EVAL1 [OINJ1 [MINJ2 [INCR2 MATCH2]]]]]]]]. exists f2; exists te2; exists tm2; exists tout1. - intuition. subst ts; eapply exec_Sloop_stop; eauto. + intuition. eapply exec_Sloop_stop; eauto. inversion OINJ1; subst out tout1; congruence. Qed. @@ -2431,7 +2385,7 @@ Proof. exploit H0; eauto. intros [f2 [te2 [tm2 [tout1 [EVAL1 [OINJ1 [MINJ2 [INCR2 MATCH2]]]]]]]]. exists f2; exists te2; exists tm2; exists (outcome_block tout1). - intuition. subst ts; eapply exec_Sblock; eauto. + intuition. eapply exec_Sblock; eauto. inversion OINJ1; subst out tout1; simpl. constructor. destruct n; constructor. @@ -2445,7 +2399,7 @@ Lemma transl_stmt_Sexit_correct: Proof. intros; red; intros. monadInv TR. exists f1; exists te1; exists tm1; exists (Out_exit n). - intuition. subst ts; constructor. constructor. + intuition. constructor. constructor. Qed. Lemma transl_stmt_Sswitch_correct: @@ -2462,7 +2416,7 @@ Proof. intros [f2 [tm2 [tv1 [EVAL [VINJ1 [MINJ2 [INCR MATCH2]]]]]]]. exists f2; exists te1; exists tm2; exists (Out_exit (switch_target n default cases)). intuition. - subst ts. constructor. inversion VINJ1. subst tv1. assumption. + constructor. inversion VINJ1. subst tv1. assumption. constructor. Qed. @@ -2473,7 +2427,7 @@ Lemma transl_stmt_Sreturn_none_correct: Proof. intros; red; intros. monadInv TR. exists f1; exists te1; exists tm1; exists (Out_return None). - intuition. subst ts; constructor. constructor. + intuition. constructor. constructor. Qed. Lemma transl_stmt_Sreturn_some_correct: @@ -2488,7 +2442,7 @@ Proof. exploit H0; eauto. intros [f2 [tm2 [tv1 [EVAL [VINJ1 [MINJ2 [INCR MATCH2]]]]]]]. exists f2; exists te1; exists tm2; exists (Out_return (Some tv1)). - intuition. subst ts; econstructor; eauto. constructor; auto. + intuition. econstructor; eauto. constructor; auto. Qed. (** We conclude by an induction over the structure of the Csharpminor @@ -2499,7 +2453,7 @@ Lemma transl_function_correct: Csharpminor.eval_funcall prog m1 f vargs t m2 vres -> eval_funcall_prop m1 f vargs t m2 vres. Proof - (eval_funcall_ind4 prog + (Csharpminor.eval_funcall_ind4 prog eval_expr_prop eval_exprlist_prop eval_funcall_prop @@ -2507,7 +2461,9 @@ Proof transl_expr_Evar_correct transl_expr_Eaddrof_correct - transl_expr_Eop_correct + transl_expr_Econst_correct + transl_expr_Eunop_correct + transl_expr_Ebinop_correct transl_expr_Eload_correct transl_expr_Ecall_correct transl_expr_Econdition_true_correct @@ -2545,11 +2501,9 @@ Lemma match_globalenvs_init: match_globalenvs f. Proof. intros. constructor. - (* globalvars *) - (* symbols *) intros. split. unfold f. rewrite zlt_true. auto. unfold m. - eapply Genv.find_symbol_inv; eauto. + eapply Genv.find_symbol_not_fresh; eauto. rewrite <- H. apply symbols_preserved. intros. unfold f. rewrite zlt_true. auto. generalize (nextblock_pos m). omega. @@ -2566,20 +2520,10 @@ Proof. intros t n [b [fn [m [FINDS [FINDF [SIG EVAL]]]]]]. elim (function_ptr_translated _ _ FINDF). intros tfn [TFIND TR]. set (m0 := Genv.init_mem prog) in *. - set (f := fun b => if zlt b m0.(nextblock) then Some(b, 0) else None). + set (f := meminj_init m0). assert (MINJ0: mem_inject f m0 m0). - unfold f; constructor; intros. - apply zlt_false; auto. - destruct (zlt b0 (nextblock m0)); try discriminate. - inversion H; subst b' delta. - split. auto. - constructor. compute. split; congruence. left; auto. - intros; omega. - generalize (Genv.initmem_block_init prog b0). fold m0. intros [idata EQ]. - rewrite EQ. simpl. apply Mem.contents_init_data_inject. - destruct (zlt b1 (nextblock m0)); try discriminate. - destruct (zlt b2 (nextblock m0)); try discriminate. - left; congruence. + unfold f; apply init_inject. + unfold m0; apply Genv.initmem_inject_neutral. assert (MATCH0: match_callstack f nil m0.(nextblock) m0.(nextblock) m0). constructor. unfold f; apply match_globalenvs_init. fold ge in EVAL. diff --git a/cfrontend/Csem.v b/cfrontend/Csem.v index 4cc85559..e24430cc 100644 --- a/cfrontend/Csem.v +++ b/cfrontend/Csem.v @@ -1,6 +1,7 @@ (** * Dynamic semantics for the Clight language *) Require Import Coqlib. +Require Import Errors. Require Import Maps. Require Import Integers. Require Import Floats. @@ -559,7 +560,7 @@ with eval_lvalue: env -> mem -> expr -> trace -> mem -> block -> int -> Prop := | eval_Efield_struct: forall e m a t m1 l ofs id fList i ty delta, eval_lvalue e m a t m1 l ofs -> typeof a = Tstruct id fList -> - field_offset i fList = Some delta -> + field_offset i fList = OK delta -> eval_lvalue e m (Expr (Efield a i) ty) t m1 l (Int.add ofs (Int.repr delta)) | eval_Efield_union: forall e m a t m1 l ofs id fList i ty, diff --git a/cfrontend/Csharpminor.v b/cfrontend/Csharpminor.v index f1d22d7e..729814ee 100644 --- a/cfrontend/Csharpminor.v +++ b/cfrontend/Csharpminor.v @@ -9,6 +9,7 @@ Require Import Values. Require Import Mem. Require Import Events. Require Import Globalenvs. +Require Cminor. (** Abstract syntax *) @@ -24,52 +25,21 @@ Require Import Globalenvs. Unlike in Cminor (the next intermediate language of the back-end), Csharpminor local variables reside in memory, and their address can be taken using [Eaddrof] expressions. +*) + +Inductive constant : Set := + | Ointconst: int -> constant (**r integer constant *) + | Ofloatconst: float -> constant. (**r floating-point constant *) - Another difference with Cminor is that Csharpminor is entirely - processor-neutral. In particular, Csharpminor uses a standard set of - operations: it does not reflect processor-specific operations nor - addressing modes. *) - -Inductive operation : Set := - | Ointconst: int -> operation (**r integer constant *) - | Ofloatconst: float -> operation (**r floating-point constant *) - | Ocast8unsigned: operation (**r 8-bit zero extension *) - | Ocast8signed: operation (**r 8-bit sign extension *) - | Ocast16unsigned: operation (**r 16-bit zero extension *) - | Ocast16signed: operation (**r 16-bit sign extension *) - | Onotbool: operation (**r boolean negation *) - | Onotint: operation (**r bitwise complement *) - | Oadd: operation (**r integer addition *) - | Osub: operation (**r integer subtraction *) - | Omul: operation (**r integer multiplication *) - | Odiv: operation (**r integer signed division *) - | Odivu: operation (**r integer unsigned division *) - | Omod: operation (**r integer signed modulus *) - | Omodu: operation (**r integer unsigned modulus *) - | Oand: operation (**r bitwise ``and'' *) - | Oor: operation (**r bitwise ``or'' *) - | Oxor: operation (**r bitwise ``xor'' *) - | Oshl: operation (**r left shift *) - | Oshr: operation (**r right signed shift *) - | Oshru: operation (**r right unsigned shift *) - | Onegf: operation (**r float opposite *) - | Oabsf: operation (**r float absolute value *) - | Oaddf: operation (**r float addition *) - | Osubf: operation (**r float subtraction *) - | Omulf: operation (**r float multiplication *) - | Odivf: operation (**r float division *) - | Osingleoffloat: operation (**r float truncation *) - | Ointoffloat: operation (**r integer to float *) - | Ofloatofint: operation (**r float to signed integer *) - | Ofloatofintu: operation (**r float to unsigned integer *) - | Ocmp: comparison -> operation (**r integer signed comparison *) - | Ocmpu: comparison -> operation (**r integer unsigned comparison *) - | Ocmpf: comparison -> operation. (**r float comparison *) +Definition unary_operation : Set := Cminor.unary_operation. +Definition binary_operation : Set := Cminor.binary_operation. Inductive expr : Set := | Evar : ident -> expr (**r reading a scalar variable *) | Eaddrof : ident -> expr (**r taking the address of a variable *) - | Eop : operation -> exprlist -> expr (**r arithmetic operation *) + | Econst : constant -> expr + | Eunop : unary_operation -> expr -> expr + | Ebinop : binary_operation -> expr -> expr -> expr | Eload : memory_chunk -> expr -> expr (**r memory read *) | Ecall : signature -> expr -> exprlist -> expr (**r function call *) | Econdition : expr -> expr -> expr -> expr (**r conditional expression *) @@ -202,78 +172,15 @@ Definition global_var_env (p: program): gvarenv := (** Evaluation of operator applications. *) -Definition eval_compare_null (c: comparison) (n: int) : option val := - if Int.eq n Int.zero - then match c with Ceq => Some Vfalse | Cne => Some Vtrue | _ => None end - else None. - -Definition eval_operation (op: operation) (vl: list val) (m: mem): option val := - match op, vl with - | Ointconst n, nil => Some (Vint n) - | Ofloatconst n, nil => Some (Vfloat n) - | Ocast8unsigned, Vint n1 :: nil => Some (Vint (Int.cast8unsigned n1)) - | Ocast8signed, Vint n1 :: nil => Some (Vint (Int.cast8signed n1)) - | Ocast16unsigned, Vint n1 :: nil => Some (Vint (Int.cast16unsigned n1)) - | Ocast16signed, Vint n1 :: nil => Some (Vint (Int.cast16signed n1)) - | Onotbool, Vint n1 :: nil => Some (Val.of_bool (Int.eq n1 Int.zero)) - | Onotbool, Vptr b1 n1 :: nil => Some (Vfalse) - | Onotint, Vint n1 :: nil => Some (Vint (Int.not n1)) - | Oadd, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.add n1 n2)) - | Oadd, Vint n1 :: Vptr b2 n2 :: nil => Some (Vptr b2 (Int.add n2 n1)) - | Oadd, Vptr b1 n1 :: Vint n2 :: nil => Some (Vptr b1 (Int.add n1 n2)) - | Osub, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.sub n1 n2)) - | Osub, Vptr b1 n1 :: Vint n2 :: nil => Some (Vptr b1 (Int.sub n1 n2)) - | Osub, Vptr b1 n1 :: Vptr b2 n2 :: nil => - if eq_block b1 b2 then Some (Vint (Int.sub n1 n2)) else None - | Omul, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.mul n1 n2)) - | Odiv, Vint n1 :: Vint n2 :: nil => - if Int.eq n2 Int.zero then None else Some (Vint (Int.divs n1 n2)) - | Odivu, Vint n1 :: Vint n2 :: nil => - if Int.eq n2 Int.zero then None else Some (Vint (Int.divu n1 n2)) - | Omod, Vint n1 :: Vint n2 :: nil => - if Int.eq n2 Int.zero then None else Some (Vint (Int.mods n1 n2)) - | Omodu, Vint n1 :: Vint n2 :: nil => - if Int.eq n2 Int.zero then None else Some (Vint (Int.modu n1 n2)) - | Oand, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.and n1 n2)) - | Oor, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.or n1 n2)) - | Oxor, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.xor n1 n2)) - | Oshl, Vint n1 :: Vint n2 :: nil => - if Int.ltu n2 (Int.repr 32) then Some (Vint (Int.shl n1 n2)) else None - | Oshr, Vint n1 :: Vint n2 :: nil => - if Int.ltu n2 (Int.repr 32) then Some (Vint (Int.shr n1 n2)) else None - | Oshru, Vint n1 :: Vint n2 :: nil => - if Int.ltu n2 (Int.repr 32) then Some (Vint (Int.shru n1 n2)) else None - | Onegf, Vfloat f1 :: nil => Some (Vfloat (Float.neg f1)) - | Oabsf, Vfloat f1 :: nil => Some (Vfloat (Float.abs f1)) - | Oaddf, Vfloat f1 :: Vfloat f2 :: nil => Some (Vfloat (Float.add f1 f2)) - | Osubf, Vfloat f1 :: Vfloat f2 :: nil => Some (Vfloat (Float.sub f1 f2)) - | Omulf, Vfloat f1 :: Vfloat f2 :: nil => Some (Vfloat (Float.mul f1 f2)) - | Odivf, Vfloat f1 :: Vfloat f2 :: nil => Some (Vfloat (Float.div f1 f2)) - | Osingleoffloat, Vfloat f1 :: nil => - Some (Vfloat (Float.singleoffloat f1)) - | Ointoffloat, Vfloat f1 :: nil => - Some (Vint (Float.intoffloat f1)) - | Ofloatofint, Vint n1 :: nil => - Some (Vfloat (Float.floatofint n1)) - | Ofloatofintu, Vint n1 :: nil => - Some (Vfloat (Float.floatofintu n1)) - | Ocmp c, Vint n1 :: Vint n2 :: nil => - Some (Val.of_bool(Int.cmp c n1 n2)) - | Ocmp c, Vptr b1 n1 :: Vptr b2 n2 :: nil => - if valid_pointer m b1 (Int.signed n1) - && valid_pointer m b2 (Int.signed n2) then - if eq_block b1 b2 then Some(Val.of_bool(Int.cmp c n1 n2)) else None - else - None - | Ocmp c, Vptr b1 n1 :: Vint n2 :: nil => eval_compare_null c n2 - | Ocmp c, Vint n1 :: Vptr b2 n2 :: nil => eval_compare_null c n1 - | Ocmpu c, Vint n1 :: Vint n2 :: nil => - Some (Val.of_bool(Int.cmpu c n1 n2)) - | Ocmpf c, Vfloat f1 :: Vfloat f2 :: nil => - Some (Val.of_bool (Float.cmp c f1 f2)) - | _, _ => None +Definition eval_constant (cst: constant) : option val := + match cst with + | Ointconst n => Some (Vint n) + | Ofloatconst n => Some (Vfloat n) end. +Definition eval_unop := Cminor.eval_unop. +Definition eval_binop := Cminor.eval_binop. + (** Allocation of local variables at function entry. Each variable is bound to the reference to a fresh block of the appropriate size. *) @@ -361,11 +268,22 @@ Inductive eval_expr: forall le e m id b, eval_var_addr e id b -> eval_expr le e m (Eaddrof id) E0 m (Vptr b Int.zero) - | eval_Eop: - forall le e m op al t m1 vl v, - eval_exprlist le e m al t m1 vl -> - eval_operation op vl m1 = Some v -> - eval_expr le e m (Eop op al) t m1 v + | eval_Econst: + forall le e m cst v, + eval_constant cst = Some v -> + eval_expr le e m (Econst cst) E0 m v + | eval_Eunop: + forall le e m op a t m1 v1 v, + eval_expr le e m a t m1 v1 -> + eval_unop op v1 = Some v -> + eval_expr le e m (Eunop op a) t m1 v + | eval_Ebinop: + forall le e m op a1 a2 t1 m1 v1 t2 m2 v2 t v, + eval_expr le e m a1 t1 m1 v1 -> + eval_expr le e m1 a2 t2 m2 v2 -> + eval_binop op v1 v2 m2 = Some v -> + t = t1 ** t2 -> + eval_expr le e m (Ebinop op a1 a2) t m2 v | eval_Eload: forall le e m chunk a t m1 v1 v, eval_expr le e m a t m1 v1 -> diff --git a/cfrontend/Cshmgen.v b/cfrontend/Cshmgen.v index 664c6fc4..5ab685db 100644 --- a/cfrontend/Cshmgen.v +++ b/cfrontend/Cshmgen.v @@ -1,19 +1,14 @@ Require Import Coqlib. +Require Import Errors. Require Import Integers. Require Import Floats. Require Import AST. Require Import Csyntax. +Require Import Cminor. Require Import Csharpminor. -(** The error monad *) - -Definition bind (A B: Set) (f: option A) (g: A -> option B) := - match f with None => None | Some x => g x end. - -Implicit Arguments bind [A B]. - -Notation "'do' X <- A ; B" := (bind A (fun X => B)) - (at level 200, X ident, A at level 100, B at level 200). +Open Local Scope string_scope. +Open Local Scope error_monad_scope. (** ** Operations on C types *) @@ -22,28 +17,28 @@ Definition signature_of_function (f: Csyntax.function) : signature := (typlist_of_typelist (type_of_params (Csyntax.fn_params f))) (opttyp_of_type (Csyntax.fn_return f)). -Definition chunk_of_type (ty: type): option memory_chunk := +Definition chunk_of_type (ty: type): res memory_chunk := match access_mode ty with - | By_value chunk => Some chunk - | _ => None + | By_value chunk => OK chunk + | _ => Error (msg "Cshmgen.chunk_of_type") end. -Definition var_kind_of_type (ty: type): option var_kind := +Definition var_kind_of_type (ty: type): res var_kind := match ty with - | Tint I8 Signed => Some(Vscalar Mint8signed) - | Tint I8 Unsigned => Some(Vscalar Mint8unsigned) - | Tint I16 Signed => Some(Vscalar Mint16signed) - | Tint I16 Unsigned => Some(Vscalar Mint16unsigned) - | Tint I32 _ => Some(Vscalar Mint32) - | Tfloat F32 => Some(Vscalar Mfloat32) - | Tfloat F64 => Some(Vscalar Mfloat64) - | Tvoid => None - | Tpointer _ => Some(Vscalar Mint32) - | Tarray _ _ => Some(Varray (Csyntax.sizeof ty)) - | Tfunction _ _ => None - | Tstruct _ fList => Some(Varray (Csyntax.sizeof ty)) - | Tunion _ fList => Some(Varray (Csyntax.sizeof ty)) - | Tcomp_ptr _ => Some(Vscalar Mint32) + | Tint I8 Signed => OK(Vscalar Mint8signed) + | Tint I8 Unsigned => OK(Vscalar Mint8unsigned) + | Tint I16 Signed => OK(Vscalar Mint16signed) + | Tint I16 Unsigned => OK(Vscalar Mint16unsigned) + | Tint I32 _ => OK(Vscalar Mint32) + | Tfloat F32 => OK(Vscalar Mfloat32) + | Tfloat F64 => OK(Vscalar Mfloat64) + | Tvoid => Error (msg "Cshmgen.var_kind_of_type(void)") + | Tpointer _ => OK(Vscalar Mint32) + | Tarray _ _ => OK(Varray (Csyntax.sizeof ty)) + | Tfunction _ _ => Error (msg "Cshmgen.var_kind_of_type(function)") + | Tstruct _ fList => OK(Varray (Csyntax.sizeof ty)) + | Tunion _ fList => OK(Varray (Csyntax.sizeof ty)) + | Tcomp_ptr _ => OK(Vscalar Mint32) end. (** ** Csharpminor constructors *) @@ -60,19 +55,14 @@ end. denoting a case where the operation is not defined at the given types. *) -Definition make_intconst (n: int) := Eop (Ointconst n) Enil. - -Definition make_floatconst (f: float) := Eop (Ofloatconst f) Enil. - -Definition make_unop (op: operation) (e: expr) := Eop op (Econs e Enil). +Definition make_intconst (n: int) := Econst (Ointconst n). -Definition make_binop (op: operation) (e1 e2: expr) := - Eop op (Econs e1 (Econs e2 Enil)). +Definition make_floatconst (f: float) := Econst (Ofloatconst f). Definition make_floatofint (e: expr) (sg: signedness) := match sg with - | Signed => make_unop Ofloatofint e - | Unsigned => make_unop Ofloatofintu e + | Signed => Eunop Ofloatofint e + | Unsigned => Eunop Ofloatofintu e end. (* [make_boolean e ty] returns a Csharpminor expression that evaluates @@ -84,98 +74,98 @@ Definition make_floatofint (e: expr) (sg: signedness) := *) Definition make_boolean (e: expr) (ty: type) := match ty with - | Tfloat _ => make_binop (Ocmpf Cne) e (make_floatconst Float.zero) + | Tfloat _ => Ebinop (Ocmpf Cne) e (make_floatconst Float.zero) | _ => e end. Definition make_neg (e: expr) (ty: type) := match ty with - | Tint _ _ => Some (make_binop Osub (make_intconst Int.zero) e) - | Tfloat _ => Some (make_unop Onegf e) - | _ => None + | Tint _ _ => OK (Eunop Onegint e) + | Tfloat _ => OK (Eunop Onegf e) + | _ => Error (msg "Cshmgen.make_neg") end. Definition make_notbool (e: expr) (ty: type) := match ty with - | Tfloat _ => make_binop (Ocmpf Ceq) e (make_floatconst Float.zero) - | _ => make_unop Onotbool e + | Tfloat _ => Ebinop (Ocmpf Ceq) e (make_floatconst Float.zero) + | _ => Eunop Onotbool e end. Definition make_notint (e: expr) (ty: type) := - make_unop Onotint e. + Eunop Onotint e. Definition make_add (e1: expr) (ty1: type) (e2: expr) (ty2: type) := match classify_add ty1 ty2 with - | add_case_ii => Some (make_binop Oadd e1 e2) - | add_case_ff => Some (make_binop Oaddf e1 e2) + | add_case_ii => OK (Ebinop Oadd e1 e2) + | add_case_ff => OK (Ebinop Oaddf e1 e2) | add_case_pi ty => let n := make_intconst (Int.repr (Csyntax.sizeof ty)) in - Some (make_binop Oadd e1 (make_binop Omul n e2)) - | add_default => None + OK (Ebinop Oadd e1 (Ebinop Omul n e2)) + | add_default => Error (msg "Cshmgen.make_add") end. Definition make_sub (e1: expr) (ty1: type) (e2: expr) (ty2: type) := match classify_sub ty1 ty2 with - | sub_case_ii => Some (make_binop Osub e1 e2) - | sub_case_ff => Some (make_binop Osubf e1 e2) + | sub_case_ii => OK (Ebinop Osub e1 e2) + | sub_case_ff => OK (Ebinop Osubf e1 e2) | sub_case_pi ty => let n := make_intconst (Int.repr (Csyntax.sizeof ty)) in - Some (make_binop Osub e1 (make_binop Omul n e2)) + OK (Ebinop Osub e1 (Ebinop Omul n e2)) | sub_case_pp ty => let n := make_intconst (Int.repr (Csyntax.sizeof ty)) in - Some (make_binop Odivu (make_binop Osub e1 e2) n) - | sub_default => None + OK (Ebinop Odivu (Ebinop Osub e1 e2) n) + | sub_default => Error (msg "Cshmgen.make_sub") end. Definition make_mul (e1: expr) (ty1: type) (e2: expr) (ty2: type) := match classify_mul ty1 ty2 with - | mul_case_ii => Some (make_binop Omul e1 e2) - | mul_case_ff => Some (make_binop Omulf e1 e2) - | mul_default => None + | mul_case_ii => OK (Ebinop Omul e1 e2) + | mul_case_ff => OK (Ebinop Omulf e1 e2) + | mul_default => Error (msg "Cshmgen.make_mul") end. Definition make_div (e1: expr) (ty1: type) (e2: expr) (ty2: type) := match classify_div ty1 ty2 with - | div_case_I32unsi => Some (make_binop Odivu e1 e2) - | div_case_ii => Some (make_binop Odiv e1 e2) - | div_case_ff => Some (make_binop Odivf e1 e2) - | div_default => None + | div_case_I32unsi => OK (Ebinop Odivu e1 e2) + | div_case_ii => OK (Ebinop Odiv e1 e2) + | div_case_ff => OK (Ebinop Odivf e1 e2) + | div_default => Error (msg "Cshmgen.make_div") end. Definition make_mod (e1: expr) (ty1: type) (e2: expr) (ty2: type) := match classify_mod ty1 ty2 with - | mod_case_I32unsi => Some (make_binop Omodu e1 e2) - | mod_case_ii=> Some (make_binop Omod e1 e2) - | mod_default => None + | mod_case_I32unsi => OK (Ebinop Omodu e1 e2) + | mod_case_ii=> OK (Ebinop Omod e1 e2) + | mod_default => Error (msg "Cshmgen.make_mod") end. Definition make_and (e1: expr) (ty1: type) (e2: expr) (ty2: type) := - Some(make_binop Oand e1 e2). + OK(Ebinop Oand e1 e2). Definition make_or (e1: expr) (ty1: type) (e2: expr) (ty2: type) := - Some(make_binop Oor e1 e2). + OK(Ebinop Oor e1 e2). Definition make_xor (e1: expr) (ty1: type) (e2: expr) (ty2: type) := - Some(make_binop Oxor e1 e2). + OK(Ebinop Oxor e1 e2). Definition make_shl (e1: expr) (ty1: type) (e2: expr) (ty2: type) := - Some(make_binop Oshl e1 e2). + OK(Ebinop Oshl e1 e2). Definition make_shr (e1: expr) (ty1: type) (e2: expr) (ty2: type) := match classify_shr ty1 ty2 with - | shr_case_I32unsi => Some (make_binop Oshru e1 e2) - | shr_case_ii=> Some (make_binop Oshr e1 e2) - | shr_default => None + | shr_case_I32unsi => OK (Ebinop Oshru e1 e2) + | shr_case_ii=> OK (Ebinop Oshr e1 e2) + | shr_default => Error (msg "Cshmgen.make_shr") end. Definition make_cmp (c: comparison) (e1: expr) (ty1: type) (e2: expr) (ty2: type) := match classify_cmp ty1 ty2 with - | cmp_case_I32unsi => Some (make_binop (Ocmpu c) e1 e2) - | cmp_case_ii => Some (make_binop (Ocmp c) e1 e2) - | cmp_case_ff => Some (make_binop (Ocmpf c) e1 e2) - | cmp_case_pi => Some (make_binop (Ocmp c) e1 e2) - | cmp_case_pp => Some (make_binop (Ocmp c) e1 e2) - | cmp_default => None + | cmp_case_I32unsi => OK (Ebinop (Ocmpu c) e1 e2) + | cmp_case_ii => OK (Ebinop (Ocmp c) e1 e2) + | cmp_case_ff => OK (Ebinop (Ocmpf c) e1 e2) + | cmp_case_pi => OK (Ebinop (Ocmp c) e1 e2) + | cmp_case_pp => OK (Ebinop (Ocmp c) e1 e2) + | cmp_default => Error (msg "Cshmgen.make_shr") end. Definition make_andbool (e1: expr) (ty1: type) (e2: expr) (ty2: type) := @@ -206,17 +196,17 @@ Definition make_orbool (e1: expr) (ty1: type) (e2: expr) (ty2: type) := Definition make_cast1 (from to: type) (e: expr) := match from, to with | Tint _ uns, Tfloat _ => make_floatofint e uns - | Tfloat _, Tint _ _ => make_unop Ointoffloat e + | Tfloat _, Tint _ _ => Eunop Ointoffloat e | _, _ => e end. Definition make_cast2 (from to: type) (e: expr) := match to with - | Tint I8 Signed => make_unop Ocast8signed e - | Tint I8 Unsigned => make_unop Ocast8unsigned e - | Tint I16 Signed => make_unop Ocast16signed e - | Tint I16 Unsigned => make_unop Ocast16unsigned e - | Tfloat F32 => make_unop Osingleoffloat e + | Tint I8 Signed => Eunop Ocast8signed e + | Tint I8 Unsigned => Eunop Ocast8unsigned e + | Tint I16 Signed => Eunop Ocast16signed e + | Tint I16 Unsigned => Eunop Ocast16unsigned e + | Tfloat F32 => Eunop Osingleoffloat e | _ => e end. @@ -231,9 +221,9 @@ Definition make_cast (from to: type) (e: expr) := Definition make_load (addr: expr) (ty_res: type) := match (access_mode ty_res) with - | By_value chunk => Some (Eload chunk addr) - | By_reference => Some addr - | By_nothing => None + | By_value chunk => OK (Eload chunk addr) + | By_reference => OK addr + | By_nothing => Error (msg "Cshmgen.make_load") end. (* [make_store addr ty_res rhs ty_rhs] stores the value of the @@ -243,8 +233,8 @@ Definition make_load (addr: expr) (ty_res: type) := Definition make_store (addr: expr) (ty: type) (rhs: expr) := match access_mode ty with - | By_value chunk => Some (Sstore chunk addr rhs) - | _ => None + | By_value chunk => OK (Sstore chunk addr rhs) + | _ => Error (msg "Cshmgen.make_store") end. (** ** Reading and writing variables *) @@ -258,9 +248,9 @@ Definition make_store (addr: expr) (ty: type) (rhs: expr) := Definition var_get (id: ident) (ty: type) := match access_mode ty with - | By_value chunk => Some (Evar id) - | By_reference => Some (Eaddrof id) - | _ => None + | By_value chunk => OK (Evar id) + | By_reference => OK (Eaddrof id) + | _ => Error (MSG "Cshmgen.var_get " :: CTX id :: nil) end. (* [var_set id ty rhs] stores the value of the Csharpminor @@ -269,21 +259,22 @@ Definition var_get (id: ident) (ty: type) := Definition var_set (id: ident) (ty: type) (rhs: expr) := match access_mode ty with - | By_value chunk => Some (Sassign id rhs) - | _ => None + | By_value chunk => OK (Sassign id rhs) + | _ => Error (MSG "Cshmgen.var_set " :: CTX id :: nil) end. (** ** Translation of operators *) -Definition transl_unop (op: unary_operation) (a: expr) (ta: type) : option expr := +Definition transl_unop (op: Csyntax.unary_operation) (a: expr) (ta: type) : res expr := match op with - | Csyntax.Onotbool => Some(make_notbool a ta) - | Csyntax.Onotint => Some(make_notint a ta) + | Csyntax.Onotbool => OK(make_notbool a ta) + | Csyntax.Onotint => OK(make_notint a ta) | Csyntax.Oneg => make_neg a ta end. -Definition transl_binop (op: binary_operation) (a: expr) (ta: type) - (b: expr) (tb: type) : option expr := +Definition transl_binop (op: Csyntax.binary_operation) + (a: expr) (ta: type) + (b: expr) (tb: type) : res expr := match op with | Csyntax.Oadd => make_add a ta b tb | Csyntax.Osub => make_sub a ta b tb @@ -315,12 +306,12 @@ Definition transl_binop (op: binary_operation) (a: expr) (ta: type) a || b ---> a ? 1 : (b ? 1 : 0) *) -Fixpoint transl_expr (a: Csyntax.expr) {struct a} : option expr := +Fixpoint transl_expr (a: Csyntax.expr) {struct a} : res expr := match a with | Expr (Csyntax.Econst_int n) _ => - Some(make_intconst n) + OK(make_intconst n) | Expr (Csyntax.Econst_float n) _ => - Some(make_floatconst n) + OK(make_floatconst n) | Expr (Csyntax.Evar id) ty => var_get id ty | Expr (Csyntax.Ederef b) _ => @@ -337,7 +328,7 @@ Fixpoint transl_expr (a: Csyntax.expr) {struct a} : option expr := transl_binop op tb (typeof b) tc (typeof c) | Expr (Csyntax.Ecast ty b) _ => do tb <- transl_expr b; - Some (make_cast (typeof b) ty tb) + OK (make_cast (typeof b) ty tb) | Expr (Csyntax.Eindex b c) ty => do tb <- transl_expr b; do tc <- transl_expr c; @@ -348,31 +339,33 @@ Fixpoint transl_expr (a: Csyntax.expr) {struct a} : option expr := | fun_case_f args res => do tb <- transl_expr b; do tcl <- transl_exprlist cl; - Some(Ecall (signature_of_type args res) tb tcl) - | _ => None + OK(Ecall (signature_of_type args res) tb tcl) + | _ => + Error(msg "Cshmgen.transl_expr(call)") end | Expr (Csyntax.Eandbool b c) _ => do tb <- transl_expr b; do tc <- transl_expr c; - Some(make_andbool tb (typeof b) tc (typeof c)) + OK(make_andbool tb (typeof b) tc (typeof c)) | Expr (Csyntax.Eorbool b c) _ => do tb <- transl_expr b; do tc <- transl_expr c; - Some(make_orbool tb (typeof b) tc (typeof c)) + OK(make_orbool tb (typeof b) tc (typeof c)) | Expr (Csyntax.Esizeof ty) _ => - Some(make_intconst (Int.repr (Csyntax.sizeof ty))) + OK(make_intconst (Int.repr (Csyntax.sizeof ty))) | Expr (Csyntax.Efield b i) ty => match typeof b with | Tstruct _ fld => do tb <- transl_lvalue b; do ofs <- field_offset i fld; make_load - (make_binop Oadd tb (make_intconst (Int.repr ofs))) + (Ebinop Oadd tb (make_intconst (Int.repr ofs))) ty | Tunion _ fld => do tb <- transl_lvalue b; make_load tb ty - | _ => None + | _ => + Error(msg "Cshmgen.transl_expr(field)") end end @@ -381,10 +374,10 @@ Fixpoint transl_expr (a: Csyntax.expr) {struct a} : option expr := where the value of [a] is stored. *) -with transl_lvalue (a: Csyntax.expr) {struct a} : option expr := +with transl_lvalue (a: Csyntax.expr) {struct a} : res expr := match a with | Expr (Csyntax.Evar id) _ => - Some (Eaddrof id) + OK (Eaddrof id) | Expr (Csyntax.Ederef b) _ => transl_expr b | Expr (Csyntax.Eindex b c) _ => @@ -396,25 +389,27 @@ with transl_lvalue (a: Csyntax.expr) {struct a} : option expr := | Tstruct _ fld => do tb <- transl_lvalue b; do ofs <- field_offset i fld; - Some (make_binop Oadd tb (make_intconst (Int.repr ofs))) + OK (Ebinop Oadd tb (make_intconst (Int.repr ofs))) | Tunion _ fld => transl_lvalue b - | _ => None + | _ => + Error(msg "Cshmgen.transl_lvalue(field)") end - | _ => None + | _ => + Error(msg "Cshmgen.transl_lvalue") end (* [transl_exprlist al] returns a list of Csharpminor expressions that compute the values of the list [al] of Csyntax expressions. Used for function applications. *) -with transl_exprlist (al: Csyntax.exprlist): option exprlist := +with transl_exprlist (al: Csyntax.exprlist): res exprlist := match al with - | Csyntax.Enil => Some Enil + | Csyntax.Enil => OK Enil | Csyntax.Econs a1 a2 => do ta1 <- transl_expr a1; do ta2 <- transl_exprlist a2; - Some (Econs ta1 ta2) + OK (Econs ta1 ta2) end. (** ** Translation of statements *) @@ -431,9 +426,9 @@ Definition is_variable (e: Csyntax.expr) : option ident := value of the CabsCoq expression [e] and performs an [exit 0] if [e] evaluates to false. *) -Definition exit_if_false (e: Csyntax.expr) : option stmt := +Definition exit_if_false (e: Csyntax.expr) : res stmt := do te <- transl_expr e; - Some(Sifthenelse + OK(Sifthenelse (make_boolean te (typeof e)) Sskip (Sexit 0%nat)). @@ -497,13 +492,13 @@ Fixpoint switch_table (sl: labeled_statements) (k: nat) {struct sl} : list (int | LScase ni _ rem => (ni, k) :: switch_table rem (k+1) end. -Fixpoint transl_statement (nbrk ncnt: nat) (s: Csyntax.statement) {struct s} : option stmt := +Fixpoint transl_statement (nbrk ncnt: nat) (s: Csyntax.statement) {struct s} : res stmt := match s with | Csyntax.Sskip => - Some Sskip + OK Sskip | Csyntax.Sexpr e => do te <- transl_expr e; - Some (Sexpr te) + OK (Sexpr te) | Csyntax.Sassign b c => match (is_variable b) with | Some id => @@ -517,35 +512,35 @@ Fixpoint transl_statement (nbrk ncnt: nat) (s: Csyntax.statement) {struct s} : o | Csyntax.Ssequence s1 s2 => do ts1 <- transl_statement nbrk ncnt s1; do ts2 <- transl_statement nbrk ncnt s2; - Some (Sseq ts1 ts2) + OK (Sseq ts1 ts2) | Csyntax.Sifthenelse e s1 s2 => do te <- transl_expr e; do ts1 <- transl_statement nbrk ncnt s1; do ts2 <- transl_statement nbrk ncnt s2; - Some (Sifthenelse (make_boolean te (typeof e)) ts1 ts2) + OK (Sifthenelse (make_boolean te (typeof e)) ts1 ts2) | Csyntax.Swhile e s1 => do te <- exit_if_false e; do ts1 <- transl_statement 1%nat 0%nat s1; - Some (Sblock (Sloop (Sseq te (Sblock ts1)))) + OK (Sblock (Sloop (Sseq te (Sblock ts1)))) | Csyntax.Sdowhile e s1 => do te <- exit_if_false e; do ts1 <- transl_statement 1%nat 0%nat s1; - Some (Sblock (Sloop (Sseq (Sblock ts1) te))) + OK (Sblock (Sloop (Sseq (Sblock ts1) te))) | Csyntax.Sfor e1 e2 e3 s1 => do te1 <- transl_statement nbrk ncnt e1; do te2 <- exit_if_false e2; do te3 <- transl_statement nbrk ncnt e3; do ts1 <- transl_statement 1%nat 0%nat s1; - Some (Sseq te1 (Sblock (Sloop (Sseq te2 (Sseq (Sblock ts1) te3))))) + OK (Sseq te1 (Sblock (Sloop (Sseq te2 (Sseq (Sblock ts1) te3))))) | Csyntax.Sbreak => - Some (Sexit nbrk) + OK (Sexit nbrk) | Csyntax.Scontinue => - Some (Sexit ncnt) + OK (Sexit ncnt) | Csyntax.Sreturn (Some e) => do te <- transl_expr e; - Some (Sreturn (Some te)) + OK (Sreturn (Some te)) | Csyntax.Sreturn None => - Some (Sreturn None) + OK (Sreturn None) | Csyntax.Sswitch e sl => let cases := switch_table sl 0 in let ncases := List.length cases in @@ -554,11 +549,11 @@ Fixpoint transl_statement (nbrk ncnt: nat) (s: Csyntax.statement) {struct s} : o end with transl_lblstmts (nbrk ncnt: nat) (sl: labeled_statements) (body: stmt) - {struct sl}: option stmt := + {struct sl}: res stmt := match sl with | LSdefault s => do ts <- transl_statement nbrk ncnt s; - Some (Sblock (Sseq body ts)) + OK (Sblock (Sseq body ts)) | LScase _ s rem => do ts <- transl_statement nbrk ncnt s; transl_lblstmts (pred nbrk) (pred ncnt) rem (Sblock (Sseq body ts)) @@ -566,28 +561,31 @@ with transl_lblstmts (nbrk ncnt: nat) (sl: labeled_statements) (body: stmt) (*** Translation of functions *) +Definition prefix_var_name (id: ident) : errmsg := + MSG "In local variable " :: CTX id :: MSG ":\n" :: nil. + Definition transl_params (l: list (ident * type)) := - AST.map_partial chunk_of_type l. + AST.map_partial prefix_var_name chunk_of_type l. Definition transl_vars (l: list (ident * type)) := - AST.map_partial var_kind_of_type l. + AST.map_partial prefix_var_name var_kind_of_type l. -Definition transl_function (f: Csyntax.function) : option function := +Definition transl_function (f: Csyntax.function) : res function := do tparams <- transl_params (Csyntax.fn_params f); do tvars <- transl_vars (Csyntax.fn_vars f); do tbody <- transl_statement 1%nat 0%nat (Csyntax.fn_body f); - Some (mkfunction (signature_of_function f) tparams tvars tbody). + OK (mkfunction (signature_of_function f) tparams tvars tbody). -Definition transl_fundef (f: Csyntax.fundef) : option fundef := +Definition transl_fundef (f: Csyntax.fundef) : res fundef := match f with | Csyntax.Internal g => - do tg <- transl_function g; Some(AST.Internal tg) + do tg <- transl_function g; OK(AST.Internal tg) | Csyntax.External id args res => - Some(AST.External (external_function id args res)) + OK(AST.External (external_function id args res)) end. (** ** Translation of programs *) Definition transl_globvar (ty: type) := var_kind_of_type ty. -Definition transl_program (p: Csyntax.program) : option program := +Definition transl_program (p: Csyntax.program) : res program := transform_partial_program2 transl_fundef transl_globvar p. diff --git a/cfrontend/Cshmgenproof1.v b/cfrontend/Cshmgenproof1.v index bee07824..7ffd156c 100644 --- a/cfrontend/Cshmgenproof1.v +++ b/cfrontend/Cshmgenproof1.v @@ -1,6 +1,7 @@ (** * Correctness of the C front end, part 1: syntactic properties *) Require Import Coqlib. +Require Import Errors. Require Import Maps. Require Import Integers. Require Import Floats. @@ -12,64 +13,28 @@ Require Import Globalenvs. Require Import Csyntax. Require Import Csem. Require Import Ctyping. +Require Import Cminor. Require Import Csharpminor. Require Import Cshmgen. -(** Monadic simplification *) - -Ltac monadSimpl1 := - match goal with - | [ |- (bind ?F ?G = Some ?X) -> _ ] => - unfold bind at 1; - generalize (refl_equal F); - pattern F at -1 in |- *; - case F; - [ (let EQ := fresh "EQ" in - (intro; intro EQ; try monadSimpl1)) - | intro; intro; discriminate ] - | [ |- (None = Some _) -> _ ] => - intro; discriminate - | [ |- (Some _ = Some _) -> _ ] => - let h := fresh "H" in - (intro h; injection h; intro; clear h) - | [ |- (_ = Some _) -> _ ] => - let EQ := fresh "EQ" in intro EQ - end. - -Ltac monadSimpl := - match goal with - | [ |- (bind ?F ?G = Some ?X) -> _ ] => monadSimpl1 - | [ |- (None = Some _) -> _ ] => monadSimpl1 - | [ |- (Some _ = Some _) -> _ ] => monadSimpl1 - | [ |- (?F _ _ _ _ _ _ = Some _) -> _ ] => unfold F; fold F; monadSimpl1 - | [ |- (?F _ _ _ _ _ = Some _) -> _ ] => unfold F; fold F; monadSimpl1 - | [ |- (?F _ _ _ _ = Some _) -> _ ] => unfold F; fold F; monadSimpl1 - | [ |- (?F _ _ _ = Some _) -> _ ] => unfold F; fold F; monadSimpl1 - | [ |- (?F _ _ = Some _) -> _ ] => unfold F; fold F; monadSimpl1 - | [ |- (?F _ = Some _) -> _ ] => unfold F; fold F; monadSimpl1 - end. - -Ltac monadInv H := - generalize H; monadSimpl. - (** Operations on types *) Lemma transl_fundef_sig1: forall f tf args res, - transl_fundef f = Some tf -> + transl_fundef f = OK tf -> classify_fun (type_of_fundef f) = fun_case_f args res -> funsig tf = signature_of_type args res. Proof. intros. destruct f; monadInv H. - monadInv EQ. rewrite <- H2. rewrite <- H3. simpl. + monadInv EQ. simpl. simpl in H0. inversion H0. reflexivity. - rewrite <- H2. simpl. + simpl. simpl in H0. congruence. Qed. Lemma transl_fundef_sig2: forall f tf args res, - transl_fundef f = Some tf -> + transl_fundef f = OK tf -> type_of_fundef f = Tfunction args res -> funsig tf = signature_of_type args res. Proof. @@ -80,7 +45,7 @@ Qed. Lemma var_kind_by_value: forall ty chunk, access_mode ty = By_value chunk -> - var_kind_of_type ty = Some(Vscalar chunk). + var_kind_of_type ty = OK(Vscalar chunk). Proof. intros ty chunk; destruct ty; simpl; try congruence. destruct i; try congruence; destruct s; congruence. @@ -89,7 +54,7 @@ Qed. Lemma sizeof_var_kind_of_type: forall ty vk, - var_kind_of_type ty = Some vk -> + var_kind_of_type ty = OK vk -> Csharpminor.sizeof vk = Csyntax.sizeof ty. Proof. intros ty vk. @@ -103,35 +68,35 @@ Qed. (** ** Some properties of the translation functions *) Lemma map_partial_names: - forall (A B: Set) (f: A -> option B) + forall (A B: Set) (f: A -> res B) (l: list (ident * A)) (tl: list (ident * B)), - map_partial f l = Some tl -> + map_partial prefix_var_name f l = OK tl -> List.map (@fst ident B) tl = List.map (@fst ident A) l. Proof. induction l; simpl. intros. inversion H. reflexivity. intro tl. destruct a as [id x]. destruct (f x); try congruence. - caseEq (map_partial f l); intros; try congruence. - inversion H0; subst tl. simpl. decEq. auto. + caseEq (map_partial prefix_var_name f l); simpl; intros; try congruence. + inv H0. simpl. decEq. auto. Qed. Lemma map_partial_append: - forall (A B: Set) (f: A -> option B) + forall (A B: Set) (f: A -> res B) (l1 l2: list (ident * A)) (tl1 tl2: list (ident * B)), - map_partial f l1 = Some tl1 -> - map_partial f l2 = Some tl2 -> - map_partial f (l1 ++ l2) = Some (tl1 ++ tl2). + map_partial prefix_var_name f l1 = OK tl1 -> + map_partial prefix_var_name f l2 = OK tl2 -> + map_partial prefix_var_name f (l1 ++ l2) = OK (tl1 ++ tl2). Proof. induction l1; intros until tl2; simpl. intros. inversion H. simpl; auto. destruct a as [id x]. destruct (f x); try congruence. - caseEq (map_partial f l1); intros; try congruence. - inversion H0. rewrite (IHl1 _ _ _ H H1). auto. + caseEq (map_partial prefix_var_name f l1); simpl; intros; try congruence. + inv H0. rewrite (IHl1 _ _ _ H H1). auto. Qed. Lemma transl_params_names: forall vars tvars, - transl_params vars = Some tvars -> + transl_params vars = OK tvars -> List.map (@fst ident memory_chunk) tvars = Ctyping.var_names vars. Proof. exact (map_partial_names _ _ chunk_of_type). @@ -139,7 +104,7 @@ Qed. Lemma transl_vars_names: forall vars tvars, - transl_vars vars = Some tvars -> + transl_vars vars = OK tvars -> List.map (@fst ident var_kind) tvars = Ctyping.var_names vars. Proof. exact (map_partial_names _ _ var_kind_of_type). @@ -148,8 +113,8 @@ Qed. Lemma transl_names_norepet: forall params vars sg tparams tvars body, list_norepet (var_names params ++ var_names vars) -> - transl_params params = Some tparams -> - transl_vars vars = Some tvars -> + transl_params params = OK tparams -> + transl_vars vars = OK tvars -> let f := Csharpminor.mkfunction sg tparams tvars body in list_norepet (fn_params_names f ++ fn_vars_names f). Proof. @@ -161,35 +126,35 @@ Qed. Lemma transl_vars_append: forall l1 l2 tl1 tl2, - transl_vars l1 = Some tl1 -> transl_vars l2 = Some tl2 -> - transl_vars (l1 ++ l2) = Some (tl1 ++ tl2). + transl_vars l1 = OK tl1 -> transl_vars l2 = OK tl2 -> + transl_vars (l1 ++ l2) = OK (tl1 ++ tl2). Proof. exact (map_partial_append _ _ var_kind_of_type). Qed. Lemma transl_params_vars: forall params tparams, - transl_params params = Some tparams -> + transl_params params = OK tparams -> transl_vars params = - Some (List.map (fun id_chunk => (fst id_chunk, Vscalar (snd id_chunk))) tparams). + OK (List.map (fun id_chunk => (fst id_chunk, Vscalar (snd id_chunk))) tparams). Proof. induction params; intro tparams; simpl. intros. inversion H. reflexivity. destruct a as [id x]. unfold chunk_of_type. caseEq (access_mode x); try congruence. intros chunk AM. - caseEq (transl_params params); intros; try congruence. - inversion H0. + caseEq (transl_params params); simpl; intros; try congruence. + inv H0. rewrite (var_kind_by_value _ _ AM). rewrite (IHparams _ H). reflexivity. Qed. Lemma transl_fn_variables: forall params vars sg tparams tvars body, - transl_params params = Some tparams -> - transl_vars vars = Some tvars -> + transl_params params = OK tparams -> + transl_vars vars = OK tvars -> let f := Csharpminor.mkfunction sg tparams tvars body in - transl_vars (params ++ vars) = Some (fn_variables f). + transl_vars (params ++ vars) = OK (fn_variables f). Proof. intros. generalize (transl_params_vars _ _ H); intro. @@ -212,35 +177,36 @@ Qed. Lemma transl_expr_lvalue: forall ge e m1 a ty t m2 loc ofs ta, Csem.eval_lvalue ge e m1 (Expr a ty) t m2 loc ofs -> - transl_expr (Expr a ty) = Some ta -> - (exists id, a = Csyntax.Evar id /\ var_get id ty = Some ta) \/ - (exists tb, transl_lvalue (Expr a ty) = Some tb /\ - make_load tb ty = Some ta). + transl_expr (Expr a ty) = OK ta -> + (exists id, a = Csyntax.Evar id /\ var_get id ty = OK ta) \/ + (exists tb, transl_lvalue (Expr a ty) = OK tb /\ + make_load tb ty = OK ta). Proof. intros. inversion H; subst; clear H; simpl in H0. left; exists id; auto. left; exists id; auto. - monadInv H0. right. exists e0; split; auto. - simpl. monadInv H0. right. exists e2; split; auto. - simpl. rewrite H6 in H0. rewrite H6. - monadInv H0. right. - exists (make_binop Oadd e0 (make_intconst (Int.repr z))). split; auto. - simpl. rewrite H10 in H0. rewrite H10. - monadInv H0. right. - exists e0; auto. + monadInv H0. right. exists x; split; auto. + simpl. monadInv H0. right. exists x1; split; auto. + simpl. rewrite EQ; rewrite EQ1. simpl. auto. + rewrite H6 in H0. monadInv H0. right. + exists (Ebinop Oadd x (make_intconst (Int.repr x0))). split; auto. + simpl. rewrite H6. rewrite EQ. rewrite EQ1. auto. + rewrite H10 in H0. monadInv H0. right. + exists x; split; auto. + simpl. rewrite H10. auto. Qed. Lemma transl_stmt_Sfor_start: forall nbrk ncnt s1 e2 s3 s4 ts, - transl_statement nbrk ncnt (Sfor s1 e2 s3 s4) = Some ts -> + transl_statement nbrk ncnt (Sfor s1 e2 s3 s4) = OK ts -> exists ts1, exists ts2, ts = Sseq ts1 ts2 - /\ transl_statement nbrk ncnt s1 = Some ts1 - /\ transl_statement nbrk ncnt (Sfor Csyntax.Sskip e2 s3 s4) = Some (Sseq Sskip ts2). + /\ transl_statement nbrk ncnt s1 = OK ts1 + /\ transl_statement nbrk ncnt (Sfor Csyntax.Sskip e2 s3 s4) = OK (Sseq Sskip ts2). Proof. - intros. monadInv H. simpl. - exists s; exists (Sblock (Sloop (Sseq s0 (Sseq (Sblock s5) s2)))). - intuition. + intros. monadInv H. econstructor; econstructor. + split. reflexivity. split. auto. simpl. + rewrite EQ1; rewrite EQ0; rewrite EQ2; auto. Qed. (** Properties related to switch constructs *) diff --git a/cfrontend/Cshmgenproof2.v b/cfrontend/Cshmgenproof2.v index 0458bd56..8e2ce303 100644 --- a/cfrontend/Cshmgenproof2.v +++ b/cfrontend/Cshmgenproof2.v @@ -1,6 +1,7 @@ (** * Correctness of the C front end, part 2: Csharpminor construction functions *) Require Import Coqlib. +Require Import Errors. Require Import Maps. Require Import Integers. Require Import Floats. @@ -12,6 +13,7 @@ Require Import Globalenvs. Require Import Csyntax. Require Import Csem. Require Import Ctyping. +Require Import Cminor. Require Import Csharpminor. Require Import Cshmgen. Require Import Cshmgenproof1. @@ -25,14 +27,14 @@ Variable tprog: Csharpminor.program. Lemma transl_lblstmts_exit: forall e m1 t m2 sl body n tsl nbrk ncnt, exec_stmt tprog e m1 body t m2 (Out_exit (lblstmts_length sl + n)) -> - transl_lblstmts nbrk ncnt sl body = Some tsl -> + transl_lblstmts nbrk ncnt sl body = OK tsl -> exec_stmt tprog e m1 tsl t m2 (outcome_block (Out_exit n)). Proof. induction sl; intros. simpl in H; simpl in H0; monadInv H0. - rewrite <- H2. constructor. apply exec_Sseq_stop. auto. congruence. + constructor. apply exec_Sseq_stop. auto. congruence. simpl in H; simpl in H0; monadInv H0. - eapply IHsl with (body := Sblock (Sseq body s0)); eauto. + eapply IHsl with (body := Sblock (Sseq body x)); eauto. change (Out_exit (lblstmts_length sl + n)) with (outcome_block (Out_exit (S (lblstmts_length sl + n)))). constructor. apply exec_Sseq_stop. auto. congruence. @@ -41,15 +43,15 @@ Qed. Lemma transl_lblstmts_return: forall e m1 t m2 sl body optv tsl nbrk ncnt, exec_stmt tprog e m1 body t m2 (Out_return optv) -> - transl_lblstmts nbrk ncnt sl body = Some tsl -> + transl_lblstmts nbrk ncnt sl body = OK tsl -> exec_stmt tprog e m1 tsl t m2 (Out_return optv). Proof. induction sl; intros. simpl in H; simpl in H0; monadInv H0. - rewrite <- H2. change (Out_return optv) with (outcome_block (Out_return optv)). + change (Out_return optv) with (outcome_block (Out_return optv)). constructor. apply exec_Sseq_stop. auto. congruence. simpl in H; simpl in H0; monadInv H0. - eapply IHsl with (body := Sblock (Sseq body s0)); eauto. + eapply IHsl with (body := Sblock (Sseq body x)); eauto. change (Out_return optv) with (outcome_block (Out_return optv)). constructor. apply exec_Sseq_stop. auto. congruence. Qed. @@ -61,41 +63,18 @@ Lemma make_intconst_correct: forall n le e m1, Csharpminor.eval_expr tprog le e m1 (make_intconst n) E0 m1 (Vint n). Proof. - intros. unfold make_intconst. econstructor. constructor. reflexivity. + intros. unfold make_intconst. econstructor. constructor. Qed. Lemma make_floatconst_correct: forall n le e m1, Csharpminor.eval_expr tprog le e m1 (make_floatconst n) E0 m1 (Vfloat n). Proof. - intros. unfold make_floatconst. econstructor. constructor. reflexivity. -Qed. - -Lemma make_unop_correct: - forall op le e m1 a ta m2 va v, - Csharpminor.eval_expr tprog le e m1 a ta m2 va -> - eval_operation op (va :: nil) m2 = Some v -> - Csharpminor.eval_expr tprog le e m1 (make_unop op a) ta m2 v. -Proof. - intros. unfold make_unop. econstructor. econstructor. eauto. constructor. - traceEq. auto. -Qed. - -Lemma make_binop_correct: - forall op le e m1 a ta m2 va b tb m3 vb t v, - Csharpminor.eval_expr tprog le e m1 a ta m2 va -> - Csharpminor.eval_expr tprog le e m2 b tb m3 vb -> - eval_operation op (va :: vb :: nil) m3 = Some v -> - t = ta ** tb -> - Csharpminor.eval_expr tprog le e m1 (make_binop op a b) t m3 v. -Proof. - intros. unfold make_binop. - econstructor. econstructor. eauto. econstructor. eauto. constructor. - reflexivity. traceEq. auto. + intros. unfold make_floatconst. econstructor. constructor. Qed. Hint Resolve make_intconst_correct make_floatconst_correct - make_unop_correct make_binop_correct: cshm. + eval_Eunop eval_Ebinop: cshm. Hint Extern 2 (@eq trace _ _) => traceEq: cshm. Remark Vtrue_is_true: Val.is_true Vtrue. @@ -120,7 +99,7 @@ Proof. destruct ty; simpl; try (exists v; intuition; inversion VTRUE; simpl; auto; fail). exists Vtrue; split. - eapply make_binop_correct; eauto with cshm. + econstructor; eauto with cshm. inversion VTRUE; simpl. replace (Float.cmp Cne f0 Float.zero) with (negb (Float.cmp Ceq f0 Float.zero)). rewrite Float.eq_zero_false. reflexivity. auto. @@ -140,7 +119,7 @@ Proof. destruct ty; simpl; try (exists v; intuition; inversion VFALSE; simpl; auto; fail). exists Vfalse; split. - eapply make_binop_correct; eauto with cshm. + econstructor; eauto with cshm. inversion VFALSE; simpl. replace (Float.cmp Cne Float.zero Float.zero) with (negb (Float.cmp Ceq Float.zero Float.zero)). rewrite Float.eq_zero_true. reflexivity. @@ -151,13 +130,13 @@ Qed. Lemma make_neg_correct: forall a tya c ta va v le e m1 m2, sem_neg va tya = Some v -> - make_neg a tya = Some c -> + make_neg a tya = OK c -> eval_expr tprog le e m1 a ta m2 va -> eval_expr tprog le e m1 c ta m2 v. Proof. intros until m2; intro SEM. unfold make_neg. functional inversion SEM; intros. - inversion H4. eapply make_binop_correct; eauto with cshm. + inversion H4. econstructor; eauto with cshm. inversion H4. eauto with cshm. Qed. @@ -186,21 +165,21 @@ Proof. Qed. Definition binary_constructor_correct - (make: expr -> type -> expr -> type -> option expr) + (make: expr -> type -> expr -> type -> res expr) (sem: val -> type -> val -> type -> option val): Prop := forall a tya b tyb c ta va tb vb v le e m1 m2 m3, sem va tya vb tyb = Some v -> - make a tya b tyb = Some c -> + make a tya b tyb = OK c -> eval_expr tprog le e m1 a ta m2 va -> eval_expr tprog le e m2 b tb m3 vb -> eval_expr tprog le e m1 c (ta ** tb) m3 v. Definition binary_constructor_correct' - (make: expr -> type -> expr -> type -> option expr) + (make: expr -> type -> expr -> type -> res expr) (sem: val -> val -> option val): Prop := forall a tya b tyb c ta va tb vb v le e m1 m2 m3, sem va vb = Some v -> - make a tya b tyb = Some c -> + make a tya b tyb = OK c -> eval_expr tprog le e m1 a ta m2 va -> eval_expr tprog le e m2 b tb m3 vb -> eval_expr tprog le e m1 c (ta ** tb) m3 v. @@ -212,8 +191,8 @@ Proof. inversion H7. eauto with cshm. inversion H7. eauto with cshm. inversion H7. - eapply make_binop_correct. eauto. - eapply make_binop_correct. eauto with cshm. eauto. + econstructor. eauto. + econstructor. eauto with cshm. eauto. simpl. reflexivity. reflexivity. simpl. reflexivity. traceEq. Qed. @@ -223,12 +202,12 @@ Proof. red; intros until m3. intro SEM. unfold make_sub. functional inversion SEM; rewrite H0; intros; inversion H7; eauto with cshm. - eapply make_binop_correct. eauto. - eapply make_binop_correct. eauto with cshm. eauto. + econstructor. eauto. + econstructor. eauto with cshm. eauto. simpl. reflexivity. reflexivity. simpl. reflexivity. traceEq. - inversion H9. eapply make_binop_correct. - eapply make_binop_correct; eauto. + inversion H9. econstructor. + econstructor; eauto. simpl. unfold eq_block; rewrite H3. reflexivity. eauto with cshm. simpl. rewrite H8. reflexivity. traceEq. Qed. @@ -244,9 +223,9 @@ Lemma make_div_correct: binary_constructor_correct make_div sem_div. Proof. red; intros until m3. intro SEM. unfold make_div. functional inversion SEM; rewrite H0; intros. - inversion H8. eapply make_binop_correct; eauto with cshm. + inversion H8. econstructor; eauto with cshm. simpl. rewrite H7; auto. - inversion H8. eapply make_binop_correct; eauto with cshm. + inversion H8. econstructor; eauto with cshm. simpl. rewrite H7; auto. inversion H7; eauto with cshm. Qed. @@ -254,9 +233,9 @@ Qed. Lemma make_mod_correct: binary_constructor_correct make_mod sem_mod. red; intros until m3. intro SEM. unfold make_mod. functional inversion SEM; rewrite H0; intros. - inversion H8. eapply make_binop_correct; eauto with cshm. + inversion H8. econstructor; eauto with cshm. simpl. rewrite H7; auto. - inversion H8. eapply make_binop_correct; eauto with cshm. + inversion H8. econstructor; eauto with cshm. simpl. rewrite H7; auto. Qed. @@ -285,7 +264,7 @@ Lemma make_shl_correct: binary_constructor_correct' make_shl sem_shl. Proof. red; intros until m3. intro SEM. unfold make_shl. functional inversion SEM. intros. inversion H5. - eapply make_binop_correct; eauto with cshm. + econstructor; eauto with cshm. simpl. rewrite H4. auto. Qed. @@ -293,16 +272,16 @@ Lemma make_shr_correct: binary_constructor_correct make_shr sem_shr. Proof. red; intros until m3. intro SEM. unfold make_shr. functional inversion SEM; intros; rewrite H0 in H8; inversion H8. - eapply make_binop_correct; eauto with cshm. + econstructor; eauto with cshm. simpl; rewrite H7; auto. - eapply make_binop_correct; eauto with cshm. + econstructor; eauto with cshm. simpl; rewrite H7; auto. Qed. Lemma make_cmp_correct: forall cmp a tya b tyb c ta va tb vb v le e m1 m2 m3, sem_cmp cmp va tya vb tyb m3 = Some v -> - make_cmp cmp a tya b tyb = Some c -> + make_cmp cmp a tya b tyb = OK c -> eval_expr tprog le e m1 a ta m2 va -> eval_expr tprog le e m2 b tb m3 vb -> eval_expr tprog le e m1 c (ta ** tb) m3 v. @@ -312,16 +291,16 @@ Proof. inversion H8. eauto with cshm. inversion H8. eauto with cshm. inversion H8. eauto with cshm. - inversion H9. eapply make_binop_correct; eauto with cshm. + inversion H9. econstructor; eauto with cshm. simpl. functional inversion H; subst; unfold eval_compare_null; rewrite H8; auto. - inversion H10. eapply make_binop_correct; eauto with cshm. + inversion H10. econstructor; eauto with cshm. simpl. rewrite H3. unfold eq_block; rewrite H9. auto. Qed. Lemma transl_unop_correct: forall op a tya c ta va v le e m1 m2, - transl_unop op a tya = Some c -> + transl_unop op a tya = OK c -> sem_unary_operation op va tya = Some v -> eval_expr tprog le e m1 a ta m2 va -> eval_expr tprog le e m1 c ta m2 v. @@ -334,7 +313,7 @@ Qed. Lemma transl_binop_correct: forall op a tya b tyb c ta va tb vb v le e m1 m2 m3, - transl_binop op a tya b tyb = Some c -> + transl_binop op a tya b tyb = OK c -> sem_binary_operation op va tya vb tyb m3 = Some v -> eval_expr tprog le e m1 a ta m2 va -> eval_expr tprog le e m2 b tb m3 vb -> @@ -365,7 +344,7 @@ Lemma make_cast_correct: cast v ty1 ty2 v' -> eval_expr tprog le e m1 (make_cast ty1 ty2 a) t m2 v'. Proof. - unfold make_cast, make_cast1, make_cast2, make_unop. + unfold make_cast, make_cast1, make_cast2. intros until v'; intros EVAL CAST. inversion CAST; clear CAST; subst. (* cast_int_int *) @@ -373,7 +352,7 @@ Proof. (* cast_float_int *) destruct sz2; destruct si2; repeat econstructor; eauto with cshm; simpl; auto. (* cast_int_float *) - destruct sz2; destruct si1; unfold make_floatofint, make_unop; repeat econstructor; eauto with cshm; simpl; auto. + destruct sz2; destruct si1; unfold make_floatofint; repeat econstructor; eauto with cshm; simpl; auto. (* cast_float_float *) destruct sz2; repeat econstructor; eauto with cshm. (* neutral, ptr *) @@ -384,7 +363,7 @@ Qed. Lemma make_load_correct: forall addr ty code b ofs v le e m1 t m2, - make_load addr ty = Some code -> + make_load addr ty = OK code -> eval_expr tprog le e m1 addr t m2 (Vptr b ofs) -> load_value_of_type ty m2 b ofs = Some v -> eval_expr tprog le e m1 code t m2 v. @@ -400,7 +379,7 @@ Qed. Lemma make_store_correct: forall addr ty rhs code e m1 t1 m2 b ofs t2 m3 v m4, - make_store addr ty rhs = Some code -> + make_store addr ty rhs = OK code -> eval_expr tprog nil e m1 addr t1 m2 (Vptr b ofs) -> eval_expr tprog nil e m2 rhs t2 m3 v -> store_value_of_type ty m3 b ofs v = Some m4 -> diff --git a/cfrontend/Cshmgenproof3.v b/cfrontend/Cshmgenproof3.v index 497286b3..c8b9caf0 100644 --- a/cfrontend/Cshmgenproof3.v +++ b/cfrontend/Cshmgenproof3.v @@ -1,6 +1,7 @@ (** * Correctness of the C front end, part 3: semantic preservation *) Require Import Coqlib. +Require Import Errors. Require Import Maps. Require Import Integers. Require Import Floats. @@ -12,6 +13,7 @@ Require Import Globalenvs. Require Import Csyntax. Require Import Csem. Require Import Ctyping. +Require Import Cminor. Require Import Csharpminor. Require Import Cshmgen. Require Import Cshmgenproof1. @@ -22,40 +24,26 @@ Section CORRECTNESS. Variable prog: Csyntax.program. Variable tprog: Csharpminor.program. Hypothesis WTPROG: wt_program prog. -Hypothesis TRANSL: transl_program prog = Some tprog. +Hypothesis TRANSL: transl_program prog = OK tprog. Let ge := Genv.globalenv prog. Let tge := Genv.globalenv tprog. Lemma symbols_preserved: forall s, Genv.find_symbol tge s = Genv.find_symbol ge s. -Proof. - intros. unfold ge, tge. - apply Genv.find_symbol_transf_partial2 with transl_fundef transl_globvar. - auto. -Qed. +Proof (Genv.find_symbol_transf_partial2 transl_fundef transl_globvar _ 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 f = Some tf. -Proof. - intros. - generalize (Genv.find_funct_transf_partial2 transl_fundef transl_globvar TRANSL H). - intros [A B]. - destruct (transl_fundef f). exists f0; split. assumption. auto. congruence. -Qed. + exists tf, Genv.find_funct tge v = Some tf /\ transl_fundef f = OK tf. +Proof (Genv.find_funct_transf_partial2 transl_fundef transl_globvar TRANSL). Lemma function_ptr_translated: forall b f, Genv.find_funct_ptr ge b = Some f -> - exists tf, Genv.find_funct_ptr tge b = Some tf /\ transl_fundef f = Some tf. -Proof. - intros. - generalize (Genv.find_funct_ptr_transf_partial2 transl_fundef transl_globvar TRANSL H). - intros [A B]. - destruct (transl_fundef f). exists f0; split. assumption. auto. congruence. -Qed. + exists tf, Genv.find_funct_ptr tge b = Some tf /\ transl_fundef f = OK tf. +Proof (Genv.find_funct_ptr_transf_partial2 transl_fundef transl_globvar TRANSL). Lemma functions_well_typed: forall v f, @@ -119,7 +107,7 @@ Proof. Qed. Lemma match_var_kind_of_type: - forall ty vk, var_kind_of_type ty = Some vk -> match_var_kind ty vk. + forall ty vk, var_kind_of_type ty = OK vk -> match_var_kind ty vk. Proof. intros; red. caseEq (access_mode ty); auto. @@ -131,7 +119,7 @@ Lemma match_env_alloc_variables: Csem.alloc_variables e1 m1 vars e2 m2 lb -> forall tyenv te1 tvars, match_env tyenv e1 te1 -> - transl_vars vars = Some tvars -> + transl_vars vars = OK tvars -> exists te2, Csharpminor.alloc_variables te1 m1 tvars te2 m2 lb /\ match_env (Ctyping.add_vars tyenv vars) e2 te2. @@ -140,8 +128,8 @@ Proof. simpl in H0. inversion H0; subst; clear H0. exists te1; split. constructor. simpl. auto. generalize H2. simpl. - caseEq (var_kind_of_type ty); [intros vk VK | congruence]. - caseEq (transl_vars vars); [intros tvrs TVARS | congruence]. + caseEq (var_kind_of_type ty); simpl; [intros vk VK | congruence]. + caseEq (transl_vars vars); simpl; [intros tvrs TVARS | congruence]. intro EQ; inversion EQ; subst tvars; clear EQ. set (te2 := PTree.set id (b1, vk) te1). assert (match_env (add_var tyenv (id, ty)) (PTree.set id b1 e) te2). @@ -168,14 +156,14 @@ Lemma bind_parameters_match_rec: forall tyenv te tvars, (forall id ty, In (id, ty) vars -> tyenv!id = Some ty) -> match_env tyenv e te -> - transl_params vars = Some tvars -> + transl_params vars = OK tvars -> Csharpminor.bind_parameters te m1 tvars vals m2. Proof. induction 1; intros. simpl in H1. inversion H1. constructor. generalize H4; clear H4; simpl. - caseEq (chunk_of_type ty); [intros chunk CHK | congruence]. - caseEq (transl_params params); [intros tparams TPARAMS | congruence]. + caseEq (chunk_of_type ty); simpl; [intros chunk CHK | congruence]. + caseEq (transl_params params); simpl; [intros tparams TPARAMS | congruence]. intro EQ; inversion EQ; clear EQ; subst tvars. generalize CHK. unfold chunk_of_type. caseEq (access_mode ty); intros; try discriminate. @@ -215,7 +203,7 @@ Lemma bind_parameters_match: Csem.bind_parameters e m1 params vals m2 -> list_norepet (var_names params ++ var_names vars) -> match_env (Ctyping.add_vars tyenv (params ++ vars)) e te -> - transl_params params = Some tvars -> + transl_params params = OK tvars -> Csharpminor.bind_parameters te m1 tvars vals m2. Proof. intros. @@ -273,14 +261,14 @@ Qed. Lemma add_global_var_match_globalenv: forall vars tenv gv tvars, match_globalenv tenv gv -> - map_partial transl_globvar vars = Some tvars -> + map_partial AST.prefix_var_name transl_globvar vars = OK tvars -> match_globalenv (add_global_vars tenv vars) (globvarenv gv tvars). Proof. induction vars; simpl. intros. inversion H0. assumption. destruct a as [[id init] ty]. intros until tvars; intro. - caseEq (transl_globvar ty); try congruence. intros vk VK. - caseEq (map_partial transl_globvar vars); try congruence. intros tvars' EQ1 EQ2. + caseEq (transl_globvar ty); simpl; try congruence. intros vk VK. + caseEq (map_partial AST.prefix_var_name transl_globvar vars); simpl; try congruence. intros tvars' EQ1 EQ2. inversion EQ2; clear EQ2. simpl. apply IHvars; auto. red. intros until chunk. repeat rewrite PTree.gsspec. @@ -299,7 +287,7 @@ Proof. unfold global_typenv. apply add_global_var_match_globalenv. apply add_global_funs_match_global_env. - unfold transl_program in TRANSL. functional inversion TRANSL. auto. + unfold transl_program in TRANSL. monadInv TRANSL. auto. Qed. (** ** Variable accessors *) @@ -309,7 +297,7 @@ Lemma var_get_correct: Csem.eval_lvalue ge e m (Expr (Csyntax.Evar id) ty) E0 m loc ofs -> load_value_of_type ty m loc ofs = Some v -> wt_expr tyenv (Expr (Csyntax.Evar id) ty) -> - var_get id ty = Some code -> + var_get id ty = OK code -> match_env tyenv e te -> eval_expr tprog le te m code E0 m v. Proof. @@ -356,7 +344,7 @@ Lemma var_set_correct: Csem.eval_lvalue ge e m (Expr (Csyntax.Evar id) ty) t1 m1 loc ofs -> store_value_of_type ty m2 loc ofs v = Some m3 -> wt_expr tyenv (Expr (Csyntax.Evar id) ty) -> - var_set id ty rhs = Some code -> + var_set id ty rhs = OK code -> match_env tyenv e te -> eval_expr tprog nil te m1 rhs t2 m2 v -> exec_stmt tprog te m code (t1 ** t2) m3 Out_normal. @@ -394,7 +382,7 @@ Definition eval_expr_prop (e: Csem.env) (m1: mem) (a: Csyntax.expr) (t: trace) (m2: mem) (v: val) : Prop := forall tyenv ta te tle (WT: wt_expr tyenv a) - (TR: transl_expr a = Some ta) + (TR: transl_expr a = OK ta) (MENV: match_env tyenv e te), Csharpminor.eval_expr tprog tle te m1 ta t m2 v. @@ -403,7 +391,7 @@ Definition eval_lvalue_prop (m2: mem) (b: block) (ofs: int) : Prop := forall tyenv ta te tle (WT: wt_expr tyenv a) - (TR: transl_lvalue a = Some ta) + (TR: transl_lvalue a = OK ta) (MENV: match_env tyenv e te), Csharpminor.eval_expr tprog tle te m1 ta t m2 (Vptr b ofs). @@ -412,7 +400,7 @@ Definition eval_exprlist_prop (m2: mem) (vl: list val) : Prop := forall tyenv tal te tle (WT: wt_exprlist tyenv al) - (TR: transl_exprlist al = Some tal) + (TR: transl_exprlist al = OK tal) (MENV: match_env tyenv e te), Csharpminor.eval_exprlist tprog tle te m1 tal t m2 vl. @@ -429,7 +417,7 @@ Definition exec_stmt_prop (m2: mem) (out: Csem.outcome) : Prop := forall tyenv nbrk ncnt ts te (WT: wt_stmt tyenv s) - (TR: transl_statement nbrk ncnt s = Some ts) + (TR: transl_statement nbrk ncnt s = OK ts) (MENV: match_env tyenv e te), Csharpminor.exec_stmt tprog te m1 ts t m2 (transl_outcome nbrk ncnt out). @@ -440,7 +428,7 @@ Definition exec_lblstmts_prop (WT: wt_lblstmts tyenv s) (TR: transl_lblstmts (lblstmts_length s) (1 + lblstmts_length s + ncnt) - s body = Some ts) + s body = OK ts) (MENV: match_env tyenv e te) (BODY: Csharpminor.exec_stmt tprog te m0 body t0 m1 Out_normal), Csharpminor.exec_stmt tprog te m0 ts (t0 ** t) m2 @@ -451,7 +439,7 @@ Definition eval_funcall_prop (t: trace) (m2: mem) (res: val) : Prop := forall tf (WT: wt_fundef (global_typenv prog) f) - (TR: transl_fundef f = Some tf), + (TR: transl_fundef f = OK tf), Csharpminor.eval_funcall tprog m1 tf params t m2 res. (* @@ -465,7 +453,7 @@ Lemma transl_Econst_int_correct: eval_expr_prop e m (Expr (Econst_int i) ty) E0 m (Vint i)). Proof. intros; red; intros. - monadInv TR. subst ta. apply make_intconst_correct. + monadInv TR. apply make_intconst_correct. Qed. Lemma transl_Econst_float_correct: @@ -473,7 +461,7 @@ Lemma transl_Econst_float_correct: eval_expr_prop e m (Expr (Econst_float f0) ty) E0 m (Vfloat f0)). Proof. intros; red; intros. - monadInv TR. subst ta. apply make_floatconst_correct. + monadInv TR. apply make_floatconst_correct. Qed. Lemma transl_Elvalue_correct: @@ -512,16 +500,16 @@ Lemma transl_Esizeof_correct: eval_expr_prop e m (Expr (Esizeof ty') ty) E0 m (Vint (Int.repr (Csyntax.sizeof ty')))). Proof. - intros; red; intros. monadInv TR. subst ta. apply make_intconst_correct. + intros; red; intros. monadInv TR. apply make_intconst_correct. Qed. Lemma transl_Eunop_correct: - (forall (e : Csem.env) (m : mem) (op : unary_operation) + (forall (e : Csem.env) (m : mem) (op : Csyntax.unary_operation) (a : Csyntax.expr) (ty : type) (t : trace) (m1 : mem) (v1 v : val), Csem.eval_expr ge e m a t m1 v1 -> eval_expr_prop e m a t m1 v1 -> sem_unary_operation op v1 (typeof a) = Some v -> - eval_expr_prop e m (Expr (Eunop op a) ty) t m1 v). + eval_expr_prop e m (Expr (Csyntax.Eunop op a) ty) t m1 v). Proof. intros; red; intros. inversion WT; clear WT; subst. @@ -530,7 +518,7 @@ Proof. Qed. Lemma transl_Ebinop_correct: - (forall (e : Csem.env) (m : mem) (op : binary_operation) + (forall (e : Csem.env) (m : mem) (op : Csyntax.binary_operation) (a1 a2 : Csyntax.expr) (ty : type) (t1 : trace) (m1 : mem) (v1 : val) (t2 : trace) (m2 : mem) (v2 v : val), Csem.eval_expr ge e m a1 t1 m1 v1 -> @@ -538,7 +526,7 @@ Lemma transl_Ebinop_correct: Csem.eval_expr ge e m1 a2 t2 m2 v2 -> eval_expr_prop e m1 a2 t2 m2 v2 -> sem_binary_operation op v1 (typeof a1) v2 (typeof a2) m2 = Some v -> - eval_expr_prop e m (Expr (Ebinop op a1 a2) ty) (t1 ** t2) m2 v). + eval_expr_prop e m (Expr (Csyntax.Ebinop op a1 a2) ty) (t1 ** t2) m2 v). Proof. intros; red; intros. inversion WT; clear WT; subst. @@ -555,7 +543,7 @@ Lemma transl_Eorbool_1_correct: eval_expr_prop e m (Expr (Eorbool a1 a2) ty) t m1 Vtrue). Proof. intros; red; intros. inversion WT; clear WT; subst. monadInv TR. - rewrite <- H3; unfold make_orbool. + unfold make_orbool. exploit make_boolean_correct_true; eauto. intros [vb [EVAL ISTRUE]]. eapply eval_Econdition_true; eauto. unfold Vtrue; apply make_intconst_correct. traceEq. @@ -574,7 +562,7 @@ Lemma transl_Eorbool_2_correct: eval_expr_prop e m (Expr (Eorbool a1 a2) ty) (t1 ** t2) m2 v). Proof. intros; red; intros. inversion WT; clear WT; subst. monadInv TR. - rewrite <- H6; unfold make_orbool. + unfold make_orbool. exploit make_boolean_correct_false. eapply H0; eauto. eauto. intros [vb [EVAL ISFALSE]]. eapply eval_Econdition_false; eauto. inversion H4; subst. @@ -595,7 +583,7 @@ Lemma transl_Eandbool_1_correct: eval_expr_prop e m (Expr (Eandbool a1 a2) ty) t m1 Vfalse). Proof. intros; red; intros. inversion WT; clear WT; subst. monadInv TR. - rewrite <- H3; unfold make_andbool. + unfold make_andbool. exploit make_boolean_correct_false; eauto. intros [vb [EVAL ISFALSE]]. eapply eval_Econdition_false; eauto. unfold Vfalse; apply make_intconst_correct. traceEq. @@ -614,7 +602,7 @@ Lemma transl_Eandbool_2_correct: eval_expr_prop e m (Expr (Eandbool a1 a2) ty) (t1 ** t2) m2 v). Proof. intros; red; intros. inversion WT; clear WT; subst. monadInv TR. - rewrite <- H6; unfold make_andbool. + unfold make_andbool. exploit make_boolean_correct_true. eapply H0; eauto. eauto. intros [vb [EVAL ISTRUE]]. eapply eval_Econdition_true; eauto. inversion H4; subst. @@ -634,7 +622,7 @@ Lemma transl_Ecast_correct: cast v1 (typeof a) ty v -> eval_expr_prop e m (Expr (Ecast ty a) ty) t m1 v). Proof. - intros; red; intros. inversion WT; clear WT; subst. monadInv TR. subst ta. + intros; red; intros. inversion WT; clear WT; subst. monadInv TR. eapply make_cast_correct; eauto. Qed. @@ -660,7 +648,7 @@ Proof. caseEq (classify_fun (typeof a)). 2: intros; rewrite H7 in TR; discriminate. intros targs tres EQ. rewrite EQ in TR. - monadInv TR. clear TR. subst ta. + monadInv TR. rewrite <- H4 in EQ. exploit functions_translated; eauto. intros [tf [FIND TRL]]. econstructor. @@ -679,7 +667,7 @@ Lemma transl_Evar_local_correct: e ! id = Some l -> eval_lvalue_prop e m (Expr (Csyntax.Evar id) ty) E0 m l Int.zero). Proof. - intros; red; intros. inversion WT; clear WT; subst. monadInv TR. subst ta. + intros; red; intros. inversion WT; clear WT; subst. monadInv TR. exploit (me_local _ _ _ MENV); eauto. intros [vk [A B]]. econstructor. eapply eval_var_addr_local. eauto. Qed. @@ -691,7 +679,7 @@ Lemma transl_Evar_global_correct: Genv.find_symbol ge id = Some l -> eval_lvalue_prop e m (Expr (Csyntax.Evar id) ty) E0 m l Int.zero). Proof. - intros; red; intros. inversion WT; clear WT; subst. monadInv TR. subst ta. + intros; red; intros. inversion WT; clear WT; subst. monadInv TR. exploit (me_global _ _ _ MENV); eauto. intros [A B]. econstructor. eapply eval_var_addr_global. eauto. rewrite symbols_preserved. auto. @@ -730,13 +718,13 @@ Lemma transl_Efield_struct_correct: eval_lvalue ge e m a t m1 l ofs -> eval_lvalue_prop e m a t m1 l ofs -> typeof a = Tstruct id fList -> - field_offset i fList = Some delta -> + field_offset i fList = OK delta -> eval_lvalue_prop e m (Expr (Efield a i) ty) t m1 l (Int.add ofs (Int.repr delta))). Proof. intros; red; intros. inversion WT; clear WT; subst. simpl in TR. rewrite H1 in TR. monadInv TR. - rewrite <- H5. eapply make_binop_correct; eauto. + econstructor; eauto. apply make_intconst_correct. simpl. congruence. traceEq. Qed. @@ -758,7 +746,7 @@ Lemma transl_Enil_correct: (forall (e : Csem.env) (m : mem), eval_exprlist_prop e m Csyntax.Enil E0 m nil). Proof. - intros; red; intros. monadInv TR. subst tal. constructor. + intros; red; intros. monadInv TR. constructor. Qed. Lemma transl_Econs_correct: @@ -772,14 +760,14 @@ Lemma transl_Econs_correct: eval_exprlist_prop e m (Csyntax.Econs a bl) (t1 ** t2) m2 (v :: vl)). Proof. intros; red; intros. inversion WT; clear WT; subst. simpl in TR; monadInv TR. - subst tal. econstructor; eauto. + econstructor; eauto. Qed. Lemma transl_Sskip_correct: (forall (e : Csem.env) (m : mem), exec_stmt_prop e m Csyntax.Sskip E0 m Csem.Out_normal). Proof. - intros; red; intros. monadInv TR. subst ts. simpl. constructor. + intros; red; intros. monadInv TR. simpl. constructor. Qed. Lemma transl_Sexpr_correct: @@ -790,8 +778,7 @@ Lemma transl_Sexpr_correct: exec_stmt_prop e m (Csyntax.Sexpr a) t m1 Csem.Out_normal). Proof. intros; red; intros; simpl. inversion WT; clear WT; subst. - monadInv TR. subst ts. - econstructor; eauto. + monadInv TR. econstructor; eauto. Qed. Lemma transl_Sassign_correct: @@ -831,7 +818,7 @@ Lemma transl_Ssequence_1_correct: exec_stmt_prop e m (Ssequence s1 s2) (t1 ** t2) m2 out). Proof. intros; red; intros. inversion WT; clear WT; subst. simpl in TR; monadInv TR. - subst ts. red in H0; simpl in H0. eapply exec_Sseq_continue; eauto. + red in H0; simpl in H0. eapply exec_Sseq_continue; eauto. Qed. Lemma transl_Ssequence_2_correct: @@ -843,7 +830,7 @@ Lemma transl_Ssequence_2_correct: exec_stmt_prop e m (Ssequence s1 s2) t1 m1 out). Proof. intros; red; intros. inversion WT; clear WT; subst. simpl in TR; monadInv TR. - subst ts. eapply exec_Sseq_stop; eauto. + eapply exec_Sseq_stop; eauto. destruct out; simpl; congruence. Qed. @@ -860,7 +847,7 @@ Lemma transl_Sifthenelse_true_correct: Proof. intros; red; intros. inversion WT; clear WT; subst. simpl in TR; monadInv TR. exploit make_boolean_correct_true. eapply H0; eauto. eauto. intros [vb [EVAL ISTRUE]]. - subst ts. eapply exec_Sifthenelse_true; eauto. + eapply exec_Sifthenelse_true; eauto. Qed. Lemma transl_Sifthenelse_false_correct: @@ -876,7 +863,7 @@ Lemma transl_Sifthenelse_false_correct: Proof. intros; red; intros. inversion WT; clear WT; subst. simpl in TR; monadInv TR. exploit make_boolean_correct_false. eapply H0; eauto. eauto. intros [vb [EVAL ISFALSE]]. - subst ts. eapply exec_Sifthenelse_false; eauto. + eapply exec_Sifthenelse_false; eauto. Qed. Lemma transl_Sreturn_none_correct: @@ -884,7 +871,7 @@ Lemma transl_Sreturn_none_correct: exec_stmt_prop e m (Csyntax.Sreturn None) E0 m (Csem.Out_return None)). Proof. intros; red; intros. inversion WT; clear WT; subst. simpl in TR; monadInv TR. - subst ts. simpl. apply exec_Sreturn_none. + simpl. apply exec_Sreturn_none. Qed. Lemma transl_Sreturn_some_correct: @@ -896,7 +883,7 @@ Lemma transl_Sreturn_some_correct: (Csem.Out_return (Some v))). Proof. intros; red; intros. inversion WT; clear WT; subst. simpl in TR; monadInv TR. - subst ts. simpl. eapply exec_Sreturn_some; eauto. + simpl. eapply exec_Sreturn_some; eauto. Qed. Lemma transl_Sbreak_correct: @@ -904,7 +891,7 @@ Lemma transl_Sbreak_correct: exec_stmt_prop e m Sbreak E0 m Out_break). Proof. intros; red; intros. inversion WT; clear WT; subst. simpl in TR; monadInv TR. - subst ts. simpl. apply exec_Sexit. + simpl. apply exec_Sexit. Qed. Lemma transl_Scontinue_correct: @@ -912,19 +899,19 @@ Lemma transl_Scontinue_correct: exec_stmt_prop e m Scontinue E0 m Out_continue). Proof. intros; red; intros. inversion WT; clear WT; subst. simpl in TR; monadInv TR. - subst ts. simpl. apply exec_Sexit. + simpl. apply exec_Sexit. Qed. Lemma exit_if_false_true: forall a ts e m1 t m2 v tyenv te, - exit_if_false a = Some ts -> + exit_if_false a = OK ts -> eval_expr_prop e m1 a t m2 v -> match_env tyenv e te -> wt_expr tyenv a -> is_true v (typeof a) -> exec_stmt tprog te m1 ts t m2 Out_normal. Proof. - intros. monadInv H. rewrite <- H5. + intros. monadInv H. exploit make_boolean_correct_true. eapply H0; eauto. eauto. intros [vb [EVAL ISTRUE]]. eapply exec_Sifthenelse_true with (v1 := vb); eauto. @@ -933,14 +920,14 @@ Qed. Lemma exit_if_false_false: forall a ts e m1 t m2 v tyenv te, - exit_if_false a = Some ts -> + exit_if_false a = OK ts -> eval_expr_prop e m1 a t m2 v -> match_env tyenv e te -> wt_expr tyenv a -> is_false v (typeof a) -> exec_stmt tprog te m1 ts t m2 (Out_exit 0). Proof. - intros. monadInv H. rewrite <- H5. + intros. monadInv H. exploit make_boolean_correct_false. eapply H0; eauto. eauto. intros [vb [EVAL ISFALSE]]. eapply exec_Sifthenelse_false with (v1 := vb); eauto. @@ -956,7 +943,7 @@ Lemma transl_Swhile_false_correct: exec_stmt_prop e m (Swhile a s) t m1 Csem.Out_normal). Proof. intros; red; intros. inversion WT; clear WT; subst. simpl in TR; monadInv TR. - subst ts. simpl. + simpl. change Out_normal with (outcome_block (Out_exit 0)). apply exec_Sblock. apply exec_Sloop_stop. apply exec_Sseq_stop. eapply exit_if_false_false; eauto. congruence. congruence. @@ -992,7 +979,7 @@ Lemma transl_Swhile_stop_correct: exec_stmt_prop e m (Swhile a s) (t1 ** t2) m2 out). Proof. intros; red; intros. inversion WT; clear WT; subst. simpl in TR; monadInv TR. - subst ts. rewrite (transl_out_break_or_return _ _ nbrk ncnt H4). + rewrite (transl_out_break_or_return _ _ nbrk ncnt H4). apply exec_Sblock. apply exec_Sloop_stop. eapply exec_Sseq_continue. eapply exit_if_false_true; eauto. @@ -1017,7 +1004,6 @@ Proof. intros; red; intros. exploit H6; eauto. intro NEXTITER. inversion WT; clear WT; subst. simpl in TR; monadInv TR. - subst ts. inversion NEXTITER; subst. apply exec_Sblock. eapply exec_Sloop_loop. eapply exec_Sseq_continue. @@ -1041,7 +1027,7 @@ Lemma transl_Sdowhile_false_correct: exec_stmt_prop e m (Sdowhile a s) (t1 ** t2) m2 Csem.Out_normal). Proof. intros; red; intros. inversion WT; clear WT; subst. simpl in TR; monadInv TR. - subst ts. simpl. + simpl. change Out_normal with (outcome_block (Out_exit 0)). apply exec_Sblock. apply exec_Sloop_stop. eapply exec_Sseq_continue. rewrite (transl_out_normal_or_continue out1 H1). @@ -1058,7 +1044,7 @@ Lemma transl_Sdowhile_stop_correct: exec_stmt_prop e m (Sdowhile a s) t m1 out). Proof. intros; red; intros. inversion WT; clear WT; subst. simpl in TR; monadInv TR. - subst ts. simpl. + simpl. assert (outcome_block (transl_outcome 1 0 out1) <> Out_normal). inversion H1; simpl; congruence. rewrite (transl_out_break_or_return _ _ nbrk ncnt H1). @@ -1084,7 +1070,6 @@ Proof. intros; red; intros. exploit H6; eauto. intro NEXTITER. inversion WT; clear WT; subst. simpl in TR; monadInv TR. - subst ts. inversion NEXTITER; subst. apply exec_Sblock. eapply exec_Sloop_loop. eapply exec_Sseq_continue. @@ -1129,7 +1114,7 @@ Lemma transl_Sfor_false_correct: exec_stmt_prop e m (Sfor Csyntax.Sskip a2 a3 s) t m1 Csem.Out_normal). Proof. intros; red; intros. inversion WT; clear WT; subst. simpl in TR; monadInv TR. - subst ts. simpl. + simpl. eapply exec_Sseq_continue. apply exec_Sskip. change Out_normal with (outcome_block (Out_exit 0)). apply exec_Sblock. apply exec_Sloop_stop. @@ -1150,7 +1135,7 @@ Lemma transl_Sfor_stop_correct: exec_stmt_prop e m (Sfor Csyntax.Sskip a2 a3 s) (t1 ** t2) m2 out). Proof. intros; red; intros. inversion WT; clear WT; subst. simpl in TR; monadInv TR. - subst ts. simpl. + simpl. assert (outcome_block (transl_outcome 1 0 out2) <> Out_normal). inversion H4; simpl; congruence. rewrite (transl_out_break_or_return _ _ nbrk ncnt H4). @@ -1181,7 +1166,6 @@ Proof. intros; red; intros. exploit H8; eauto. intro NEXTITER. inversion WT; clear WT; subst. simpl in TR; monadInv TR. - subst ts. inversion NEXTITER; subst. inversion H11; subst. inversion H18; subst. @@ -1205,7 +1189,7 @@ Lemma transl_lblstmts_switch: transl_lblstmts (lblstmts_length sl) (S (lblstmts_length sl + ncnt)) - sl (Sblock body) = Some ts -> + sl (Sblock body) = OK ts -> wt_lblstmts tyenv sl -> match_env tyenv e te -> exec_lblstmts_prop e m1 (select_switch n sl) t2 m2 out -> @@ -1226,7 +1210,7 @@ Proof. (* next case selected *) inversion H1; clear H1; subst. simpl in H0; monadInv H0. - eapply IHsl with (body := Sseq (Sblock body) s0); eauto. + eapply IHsl with (body := Sseq (Sblock body) x); eauto. apply exec_Sseq_stop. change (Out_exit (switch_target n (lblstmts_length sl) (switch_table sl 0))) with (outcome_block (Out_exit (S (switch_target n (lblstmts_length sl) (switch_table sl 0))))). @@ -1247,7 +1231,7 @@ Lemma transl_Sswitch_correct: Proof. intros; red; intros. inversion WT; clear WT; subst. - simpl in TR. monadInv TR; clear TR. + simpl in TR. monadInv TR. rewrite length_switch_table in EQ0. replace (ncnt + lblstmts_length sl + 1)%nat with (S (lblstmts_length sl + ncnt))%nat in EQ0 by omega. @@ -1265,7 +1249,6 @@ Proof. intros; red; intros. inversion WT; subst. simpl in TR. monadInv TR. - rewrite <- H3. replace (transl_outcome nbrk ncnt (outcome_switch out)) with (outcome_block (transl_outcome 0 (S ncnt) out)). constructor. @@ -1286,8 +1269,8 @@ Lemma transl_LScase_fallthrough_correct: Proof. intros; red; intros. inversion WT; subst. - simpl in TR. monadInv TR; clear TR. - assert (exec_stmt tprog te m0 (Sblock (Sseq body s0)) + monadInv TR. + assert (exec_stmt tprog te m0 (Sblock (Sseq body x)) (t0 ** t1) m1 Out_normal). change Out_normal with (outcome_block (transl_outcome (S (lblstmts_length ls)) @@ -1311,19 +1294,19 @@ Lemma transl_LScase_stop_correct: Proof. intros; red; intros. inversion WT; subst. - simpl in TR. monadInv TR; clear TR. + monadInv TR. exploit H0; eauto. intro EXEC. destruct out; simpl; simpl in EXEC. (* out = Out_break *) change Out_normal with (outcome_block (Out_exit 0)). - eapply transl_lblstmts_exit with (body := Sblock (Sseq body s0)); eauto. + eapply transl_lblstmts_exit with (body := Sblock (Sseq body x)); eauto. rewrite plus_0_r. change (Out_exit (lblstmts_length ls)) with (outcome_block (Out_exit (S (lblstmts_length ls)))). constructor. eapply exec_Sseq_continue; eauto. (* out = Out_continue *) change (Out_exit ncnt) with (outcome_block (Out_exit (S ncnt))). - eapply transl_lblstmts_exit with (body := Sblock (Sseq body s0)); eauto. + eapply transl_lblstmts_exit with (body := Sblock (Sseq body x)); eauto. replace (Out_exit (lblstmts_length ls + S ncnt)) with (outcome_block (Out_exit (S (S (lblstmts_length ls + ncnt))))). constructor. eapply exec_Sseq_continue; eauto. @@ -1331,7 +1314,7 @@ Proof. (* out = Out_normal *) congruence. (* out = Out_return *) - eapply transl_lblstmts_return with (body := Sblock (Sseq body s0)); eauto. + eapply transl_lblstmts_return with (body := Sblock (Sseq body x)); eauto. change (Out_return o) with (outcome_block (Out_return o)). constructor. eapply exec_Sseq_continue; eauto. @@ -1366,13 +1349,13 @@ Proof. inversion WT; clear WT; subst. inversion H6; clear H6; subst. (* Exploitation of translation hypothesis *) - monadInv TR. subst tf. clear TR. - monadInv EQ. clear EQ. subst f0. + monadInv TR. + monadInv EQ. (* Allocation of variables *) exploit match_env_alloc_variables; eauto. apply match_globalenv_match_env_empty. apply match_global_typenv. - eexact (transl_fn_variables _ _ (signature_of_function f) _ _ s EQ0 EQ1). + eexact (transl_fn_variables _ _ (signature_of_function f) _ _ x2 EQ0 EQ). intros [te [ALLOCVARS MATCHENV]]. (* Execution *) econstructor; simpl. @@ -1395,7 +1378,7 @@ Lemma transl_funcall_external_correct: eval_funcall_prop m (External id targs tres) vargs t m vres). Proof. intros; red; intros. - monadInv TR. subst tf. constructor. auto. + monadInv TR. constructor. auto. Qed. Theorem transl_funcall_correct: @@ -1467,7 +1450,7 @@ End CORRECTNESS. Theorem transl_program_correct: forall prog tprog t r, - transl_program prog = Some tprog -> + transl_program prog = OK tprog -> Ctyping.wt_program prog -> Csem.exec_program prog t r -> Csharpminor.exec_program tprog t r. diff --git a/cfrontend/Csyntax.v b/cfrontend/Csyntax.v index f9463e65..6a5fcf34 100644 --- a/cfrontend/Csyntax.v +++ b/cfrontend/Csyntax.v @@ -1,6 +1,7 @@ (** * Abstract syntax for the Clight language *) Require Import Coqlib. +Require Import Errors. Require Import Integers. Require Import Floats. Require Import AST. @@ -251,17 +252,19 @@ Qed. (** Byte offset for a field in a struct. *) +Open Local Scope string_scope. + Fixpoint field_offset_rec (id: ident) (fld: fieldlist) (pos: Z) - {struct fld} : option Z := + {struct fld} : res Z := match fld with - | Fnil => None + | Fnil => Error (MSG "Unknown field " :: CTX id :: nil) | Fcons id' t fld' => if ident_eq id id' - then Some (align pos (alignof t)) + then OK (align pos (alignof t)) else field_offset_rec id fld' (align pos (alignof t) + sizeof t) end. -Definition field_offset (id: ident) (fld: fieldlist) : option Z := +Definition field_offset (id: ident) (fld: fieldlist) : res Z := field_offset_rec id fld 0. (* Describe how a variable of the given type must be accessed: diff --git a/common/AST.v b/common/AST.v index 5b8c997a..403861de 100644 --- a/common/AST.v +++ b/common/AST.v @@ -2,11 +2,14 @@ the abstract syntax trees of many of the intermediate languages. *) Require Import Coqlib. +Require Import Errors. Require Import Integers. Require Import Floats. Set Implicit Arguments. +(** * Syntactic elements *) + (** Identifiers (names of local variables, of global symbols and functions, etc) are represented by the type [positive] of positive integers. *) @@ -14,8 +17,9 @@ Definition ident := positive. Definition ident_eq := peq. -(** The languages are weakly typed, using only two types: [Tint] for - integers and pointers, and [Tfloat] for floating-point numbers. *) +(** The intermediate languages are weakly typed, using only two types: + [Tint] for integers and pointers, and [Tfloat] for floating-point + numbers. *) Inductive typ : Set := | Tint : typ @@ -24,6 +28,9 @@ Inductive typ : Set := Definition typesize (ty: typ) : Z := match ty with Tint => 4 | Tfloat => 8 end. +Lemma typesize_pos: forall ty, typesize ty > 0. +Proof. destruct ty; simpl; omega. Qed. + (** Additionally, function definitions and function calls are annotated by function signatures indicating the number and types of arguments, as well as the type of the returned value if any. These signatures @@ -82,6 +89,14 @@ Record program (F V: Set) : Set := mkprogram { prog_vars: list (ident * list init_data * V) }. +Definition prog_funct_names (F V: Set) (p: program F V) : list ident := + map (@fst ident F) p.(prog_funct). + +Definition prog_var_names (F V: Set) (p: program F V) : list ident := + map (fun x: ident * list init_data * V => fst(fst x)) p.(prog_vars). + +(** * Generic transformations over programs *) + (** We now define a general iterator over programs that applies a given code transformation function to all function descriptions and leaves the other parts of the program unchanged. *) @@ -117,48 +132,63 @@ End TRANSF_PROGRAM. code transformation function can fail and therefore returns an option type. *) +Open Local Scope error_monad_scope. +Open Local Scope string_scope. + Section MAP_PARTIAL. Variable A B C: Set. -Variable f: B -> option C. +Variable prefix_errmsg: A -> errmsg. +Variable f: B -> res C. -Fixpoint map_partial (l: list (A * B)) : option (list (A * C)) := +Fixpoint map_partial (l: list (A * B)) : res (list (A * C)) := match l with - | nil => Some nil + | nil => OK nil | (a, b) :: rem => match f b with - | None => None - | Some c => - match map_partial rem with - | None => None - | Some res => Some ((a, c) :: res) - end + | Error msg => Error (prefix_errmsg a ++ msg)%list + | OK c => + do rem' <- map_partial rem; + OK ((a, c) :: rem') end end. Remark In_map_partial: forall l l' a c, - map_partial l = Some l' -> + map_partial l = OK l' -> In (a, c) l' -> - exists b, In (a, b) l /\ f b = Some c. + exists b, In (a, b) l /\ f b = OK c. Proof. induction l; simpl. - intros. inversion H; subst. elim H0. - destruct a as [a1 b1]. intros until c. + intros. inv H. elim H0. + intros until c. destruct a as [a1 b1]. caseEq (f b1); try congruence. - intros c1 EQ1. caseEq (map_partial l); try congruence. - intros res EQ2 EQ3 IN. inversion EQ3; clear EQ3; subst l'. - elim IN; intro. inversion H; subst. - exists b1; auto. + intro c1; intros. monadInv H0. + elim H1; intro. inv H0. exists b1; auto. exploit IHl; eauto. intros [b [P Q]]. exists b; auto. Qed. +Remark map_partial_forall2: + forall l l', + map_partial l = OK l' -> + list_forall2 + (fun (a_b: A * B) (a_c: A * C) => + fst a_b = fst a_c /\ f (snd a_b) = OK (snd a_c)) + l l'. +Proof. + induction l; simpl. + intros. inv H. constructor. + intro l'. destruct a as [a b]. + caseEq (f b). 2: congruence. intro c; intros. monadInv H0. + constructor. simpl. auto. auto. +Qed. + End MAP_PARTIAL. Remark map_partial_total: - forall (A B C: Set) (f: B -> C) (l: list (A * B)), - map_partial (fun b => Some (f b)) l = - Some (List.map (fun a_b => (fst a_b, f (snd a_b))) l). + forall (A B C: Set) (prefix: A -> errmsg) (f: B -> C) (l: list (A * B)), + map_partial prefix (fun b => OK (f b)) l = + OK (List.map (fun a_b => (fst a_b, f (snd a_b))) l). Proof. induction l; simpl. auto. @@ -166,8 +196,8 @@ Proof. Qed. Remark map_partial_identity: - forall (A B: Set) (l: list (A * B)), - map_partial (fun b => Some b) l = Some l. + forall (A B: Set) (prefix: A -> errmsg) (l: list (A * B)), + map_partial prefix (fun b => OK b) l = OK l. Proof. induction l; simpl. auto. @@ -177,39 +207,39 @@ Qed. Section TRANSF_PARTIAL_PROGRAM. Variable A B V: Set. -Variable transf_partial: A -> option B. +Variable transf_partial: A -> res B. -Function transform_partial_program (p: program A V) : option (program B V) := - match map_partial transf_partial p.(prog_funct) with - | None => None - | Some fl => Some (mkprogram fl p.(prog_main) p.(prog_vars)) - end. +Definition prefix_funct_name (id: ident) : errmsg := + MSG "In function " :: CTX id :: MSG ":\n" :: nil. + +Definition transform_partial_program (p: program A V) : res (program B V) := + do fl <- map_partial prefix_funct_name transf_partial p.(prog_funct); + OK (mkprogram fl p.(prog_main) p.(prog_vars)). Lemma transform_partial_program_function: forall p tp i tf, - transform_partial_program p = Some tp -> + transform_partial_program p = OK tp -> In (i, tf) tp.(prog_funct) -> - exists f, In (i, f) p.(prog_funct) /\ transf_partial f = Some tf. + exists f, In (i, f) p.(prog_funct) /\ transf_partial f = OK tf. Proof. - intros. functional inversion H. - apply In_map_partial with fl; auto. - inversion H; subst tp; assumption. + intros. monadInv H. simpl in H0. + eapply In_map_partial; eauto. Qed. Lemma transform_partial_program_main: forall p tp, - transform_partial_program p = Some tp -> + transform_partial_program p = OK tp -> tp.(prog_main) = p.(prog_main). Proof. - intros. functional inversion H. reflexivity. + intros. monadInv H. reflexivity. Qed. Lemma transform_partial_program_vars: forall p tp, - transform_partial_program p = Some tp -> + transform_partial_program p = OK tp -> tp.(prog_vars) = p.(prog_vars). Proof. - intros. functional inversion H. reflexivity. + intros. monadInv H. reflexivity. Qed. End TRANSF_PARTIAL_PROGRAM. @@ -221,49 +251,104 @@ End TRANSF_PARTIAL_PROGRAM. Section TRANSF_PARTIAL_PROGRAM2. Variable A B V W: Set. -Variable transf_partial_function: A -> option B. -Variable transf_partial_variable: V -> option W. - -Function transform_partial_program2 (p: program A V) : option (program B W) := - match map_partial transf_partial_function p.(prog_funct) with - | None => None - | Some fl => - match map_partial transf_partial_variable p.(prog_vars) with - | None => None - | Some vl => Some (mkprogram fl p.(prog_main) vl) - end - end. +Variable transf_partial_function: A -> res B. +Variable transf_partial_variable: V -> res W. + +Definition prefix_var_name (id_init: ident * list init_data) : errmsg := + MSG "In global variable " :: CTX (fst id_init) :: MSG ":\n" :: nil. + +Definition transform_partial_program2 (p: program A V) : res (program B W) := + do fl <- map_partial prefix_funct_name transf_partial_function p.(prog_funct); + do vl <- map_partial prefix_var_name transf_partial_variable p.(prog_vars); + OK (mkprogram fl p.(prog_main) vl). Lemma transform_partial_program2_function: forall p tp i tf, - transform_partial_program2 p = Some tp -> + transform_partial_program2 p = OK tp -> In (i, tf) tp.(prog_funct) -> - exists f, In (i, f) p.(prog_funct) /\ transf_partial_function f = Some tf. + exists f, In (i, f) p.(prog_funct) /\ transf_partial_function f = OK tf. Proof. - intros. functional inversion H. - apply In_map_partial with fl. auto. subst tp; assumption. + intros. monadInv H. + eapply In_map_partial; eauto. Qed. Lemma transform_partial_program2_variable: forall p tp i tv, - transform_partial_program2 p = Some tp -> + transform_partial_program2 p = OK tp -> In (i, tv) tp.(prog_vars) -> - exists v, In (i, v) p.(prog_vars) /\ transf_partial_variable v = Some tv. + exists v, In (i, v) p.(prog_vars) /\ transf_partial_variable v = OK tv. Proof. - intros. functional inversion H. - apply In_map_partial with vl. auto. subst tp; assumption. + intros. monadInv H. + eapply In_map_partial; eauto. Qed. Lemma transform_partial_program2_main: forall p tp, - transform_partial_program2 p = Some tp -> + transform_partial_program2 p = OK tp -> tp.(prog_main) = p.(prog_main). Proof. - intros. functional inversion H. reflexivity. + intros. monadInv H. reflexivity. Qed. End TRANSF_PARTIAL_PROGRAM2. +(** The following is a relational presentation of + [transform_program_partial2]. Given relations between function + definitions and between variable information, it defines a relation + between programs stating that the two programs have the same shape + (same global names, etc) and that identically-named function definitions + are variable information are related. *) + +Section MATCH_PROGRAM. + +Variable A B V W: Set. +Variable match_fundef: A -> B -> Prop. +Variable match_varinfo: V -> W -> Prop. + +Definition match_funct_entry (x1: ident * A) (x2: ident * B) := + match x1, x2 with + | (id1, fn1), (id2, fn2) => id1 = id2 /\ match_fundef fn1 fn2 + end. + +Definition match_var_entry (x1: ident * list init_data * V) (x2: ident * list init_data * W) := + match x1, x2 with + | (id1, init1, info1), (id2, init2, info2) => id1 = id2 /\ init1 = init2 /\ match_varinfo info1 info2 + end. + +Definition match_program (p1: program A V) (p2: program B W) : Prop := + list_forall2 match_funct_entry p1.(prog_funct) p2.(prog_funct) + /\ p1.(prog_main) = p2.(prog_main) + /\ list_forall2 match_var_entry p1.(prog_vars) p2.(prog_vars). + +End MATCH_PROGRAM. + +Remark transform_partial_program2_match: + forall (A B V W: Set) + (transf_partial_function: A -> res B) + (transf_partial_variable: V -> res W) + (p: program A V) (tp: program B W), + transform_partial_program2 transf_partial_function transf_partial_variable p = OK tp -> + match_program + (fun fd tfd => transf_partial_function fd = OK tfd) + (fun info tinfo => transf_partial_variable info = OK tinfo) + p tp. +Proof. + intros. monadInv H. split. + apply list_forall2_imply with + (fun (ab: ident * A) (ac: ident * B) => + fst ab = fst ac /\ transf_partial_function (snd ab) = OK (snd ac)). + eapply map_partial_forall2. eauto. + intros. destruct v1; destruct v2; simpl in *. auto. + split. auto. + apply list_forall2_imply with + (fun (ab: ident * list init_data * V) (ac: ident * list init_data * W) => + fst ab = fst ac /\ transf_partial_variable (snd ab) = OK (snd ac)). + eapply map_partial_forall2. eauto. + intros. destruct v1; destruct v2; simpl in *. destruct p0; destruct p1. intuition congruence. +Qed. + +(** * External functions *) + (** For most languages, the functions composing the program are either internal functions, defined within the language, or external functions (a.k.a. system calls) that emit an event when applied. We define @@ -296,16 +381,12 @@ End TRANSF_FUNDEF. Section TRANSF_PARTIAL_FUNDEF. Variable A B: Set. -Variable transf_partial: A -> option B. +Variable transf_partial: A -> res B. -Definition transf_partial_fundef (fd: fundef A): option (fundef B) := +Definition transf_partial_fundef (fd: fundef A): res (fundef B) := match fd with - | Internal f => - match transf_partial f with - | None => None - | Some f' => Some (Internal f') - end - | External ef => Some (External ef) + | Internal f => do f' <- transf_partial f; OK (Internal f') + | External ef => OK (External ef) end. End TRANSF_PARTIAL_FUNDEF. diff --git a/common/Errors.v b/common/Errors.v new file mode 100644 index 00000000..2c1d752a --- /dev/null +++ b/common/Errors.v @@ -0,0 +1,167 @@ +(** Error reporting and the error monad. *) + +Require Import String. +Require Import Coqlib. + +Close Scope string_scope. + +Set Implicit Arguments. + +(** * Representation of error messages. *) + +(** Compile-time errors produce an error message, represented in Coq + as a list of either substrings or positive numbers encoding + a source-level identifier (see module AST). *) + +Inductive errcode: Set := + | MSG: string -> errcode + | CTX: positive -> errcode. + +Definition errmsg: Set := list errcode. + +Definition msg (s: string) : errmsg := MSG s :: nil. + +(** * The error monad *) + +(** Compilation functions that can fail have return type [res A]. + The return value is either [OK res] to indicate success, + or [Error msg] to indicate failure. *) + +Inductive res (A: Set) : Set := +| OK: A -> res A +| Error: errmsg -> res A. + +Implicit Arguments Error [A]. + +(** To automate the propagation of errors, we use a monadic style + with the following [bind] operation. *) + +Definition bind (A B: Set) (f: res A) (g: A -> res B) : res B := + match f with + | OK x => g x + | Error msg => Error msg + end. + +Definition bind2 (A B C: Set) (f: res (A * B)) (g: A -> B -> res C) : res C := + match f with + | OK (x, y) => g x y + | Error msg => Error msg + end. + +(** The [do] notation, inspired by Haskell's, keeps the code readable. *) + +Notation "'do' X <- A ; B" := (bind A (fun X => B)) + (at level 200, X ident, A at level 100, B at level 200) + : error_monad_scope. + +Notation "'do' ( X , Y ) <- A ; B" := (bind2 A (fun X Y => B)) + (at level 200, X ident, Y ident, A at level 100, B at level 200) + : error_monad_scope. + +Remark bind_inversion: + forall (A B: Set) (f: res A) (g: A -> res B) (y: B), + bind f g = OK y -> + exists x, f = OK x /\ g x = OK y. +Proof. + intros until y. destruct f; simpl; intros. + exists a; auto. + discriminate. +Qed. + +Remark bind2_inversion: + forall (A B C: Set) (f: res (A*B)) (g: A -> B -> res C) (z: C), + bind2 f g = OK z -> + exists x, exists y, f = OK (x, y) /\ g x y = OK z. +Proof. + intros until z. destruct f; simpl. + destruct p; simpl; intros. exists a; exists b; auto. + intros; discriminate. +Qed. + +Open Local Scope error_monad_scope. + +(** This is the familiar monadic map iterator. *) + +Fixpoint mmap (A B: Set) (f: A -> res B) (l: list A) {struct l} : res (list B) := + match l with + | nil => OK nil + | hd :: tl => do hd' <- f hd; do tl' <- mmap f tl; OK (hd' :: tl') + end. + +Remark mmap_inversion: + forall (A B: Set) (f: A -> res B) (l: list A) (l': list B), + mmap f l = OK l' -> + list_forall2 (fun x y => f x = OK y) l l'. +Proof. + induction l; simpl; intros. + inversion_clear H. constructor. + destruct (bind_inversion _ _ H) as [hd' [P Q]]. + destruct (bind_inversion _ _ Q) as [tl' [R S]]. + inversion_clear S. + constructor. auto. auto. +Qed. + +(** * Reasoning over monadic computations *) + +(** The [monadInv H] tactic below simplifies hypotheses of the form +<< + H: (do x <- a; b) = OK res +>> + By definition of the bind operation, both computations [a] and + [b] must succeed for their composition to succeed. The tactic + therefore generates the following hypotheses: + + x: ... + H1: a = OK x + H2: b x = OK res +*) + +Ltac monadInv1 H := + match type of H with + | (OK _ = OK _) => + inversion H; clear H; try subst + | (Error _ = OK _) => + discriminate + | (bind ?F ?G = OK ?X) => + let x := fresh "x" in ( + let EQ1 := fresh "EQ" in ( + let EQ2 := fresh "EQ" in ( + destruct (bind_inversion F G H) as [x [EQ1 EQ2]]; + clear H; + try (monadInv1 EQ2)))) + | (bind2 ?F ?G = OK ?X) => + let x1 := fresh "x" in ( + let x2 := fresh "x" in ( + let EQ1 := fresh "EQ" in ( + let EQ2 := fresh "EQ" in ( + destruct (bind2_inversion F G H) as [x1 [x2 [EQ1 EQ2]]]; + clear H; + try (monadInv1 EQ2))))) + | (mmap ?F ?L = OK ?M) => + generalize (mmap_inversion F L H); intro + end. + +Ltac monadInv H := + match type of H with + | (OK _ = OK _) => monadInv1 H + | (Error _ = OK _) => monadInv1 H + | (bind ?F ?G = OK ?X) => monadInv1 H + | (bind2 ?F ?G = OK ?X) => monadInv1 H + | (?F _ _ _ _ _ _ _ _ = OK _) => + ((progress simpl in H) || unfold F in H); monadInv1 H + | (?F _ _ _ _ _ _ _ = OK _) => + ((progress simpl in H) || unfold F in H); monadInv1 H + | (?F _ _ _ _ _ _ = OK _) => + ((progress simpl in H) || unfold F in H); monadInv1 H + | (?F _ _ _ _ _ = OK _) => + ((progress simpl in H) || unfold F in H); monadInv1 H + | (?F _ _ _ _ = OK _) => + ((progress simpl in H) || unfold F in H); monadInv1 H + | (?F _ _ _ = OK _) => + ((progress simpl in H) || unfold F in H); monadInv1 H + | (?F _ _ = OK _) => + ((progress simpl in H) || unfold F in H); monadInv1 H + | (?F _ = OK _) => + ((progress simpl in H) || unfold F in H); monadInv1 H + end. + diff --git a/common/Events.v b/common/Events.v index a0559fd0..e1a4729a 100644 --- a/common/Events.v +++ b/common/Events.v @@ -1,4 +1,4 @@ -(** Representation of (traces of) observable events. *) +(** Representation of observable events and execution traces. *) Require Import Coqlib. Require Import AST. @@ -6,23 +6,77 @@ Require Import Integers. Require Import Floats. Require Import Values. +(** The observable behaviour of programs is stated in terms of + input/output events, which can also be thought of as system calls + to the operating system. An event is generated each time an + external function (see module AST) is invoked. The event records + the name of the external function, the arguments to the function + invocation provided by the program, and the return value provided by + the outside world (e.g. the operating system). Arguments and values + are either integers or floating-point numbers. We currently do not + allow pointers to be exchanged between the program and the outside + world. *) + Inductive eventval: Set := | EVint: int -> eventval | EVfloat: float -> eventval. -Parameter trace: Set. -Parameter E0: trace. -Parameter Eextcall: ident -> list eventval -> eventval -> trace. -Parameter Eapp: trace -> trace -> trace. +Record event : Set := mkevent { + ev_name: ident; + ev_args: list eventval; + ev_res: eventval +}. + +(** The dynamic semantics for programs collect traces of events. + Traces are of two kinds: finite (type [trace]) + or infinite (type [traceinf]). *) + +Definition trace := list event. + +Definition E0 : trace := nil. + +Definition Eextcall + (name: ident) (args: list eventval) (res: eventval) : trace := + mkevent name args res :: nil. + +Definition Eapp (t1 t2: trace) : trace := t1 ++ t2. + +CoInductive traceinf : Set := + | Econsinf: event -> traceinf -> traceinf. + +Fixpoint Eappinf (t: trace) (T: traceinf) {struct t} : traceinf := + match t with + | nil => T + | ev :: t' => Econsinf ev (Eappinf t' T) + end. + +(** Concatenation of traces is written [**] in the finite case + or [***] in the infinite case. *) Infix "**" := Eapp (at level 60, right associativity). +Infix "***" := Eappinf (at level 60, right associativity). -Axiom E0_left: forall t, E0 ** t = t. -Axiom E0_right: forall t, t ** E0 = t. -Axiom Eapp_assoc: forall t1 t2 t3, (t1 ** t2) ** t3 = t1 ** (t2 ** t3). +Lemma E0_left: forall t, E0 ** t = t. +Proof. auto. Qed. + +Lemma E0_right: forall t, t ** E0 = t. +Proof. intros. unfold E0, Eapp. rewrite <- app_nil_end. auto. Qed. + +Lemma Eapp_assoc: forall t1 t2 t3, (t1 ** t2) ** t3 = t1 ** (t2 ** t3). +Proof. intros. unfold Eapp, trace. apply app_ass. Qed. + +Lemma Eappinf_assoc: forall t1 t2 T, (t1 ** t2) *** T = t1 *** (t2 *** T). +Proof. + induction t1; intros; simpl. auto. decEq; auto. +Qed. Hint Rewrite E0_left E0_right Eapp_assoc: trace_rewrite. +Opaque trace E0 Eextcall Eapp. + +(** The following [traceEq] tactic proves equalities between traces + or infinite traces. *) + Ltac substTraceHyp := match goal with | [ H: (@eq trace ?x ?y) |- _ ] => @@ -40,6 +94,11 @@ Ltac decomposeTraceEq := Ltac traceEq := repeat substTraceHyp; autorewrite with trace_rewrite; decomposeTraceEq. +(** The predicate [event_match ef vargs t vres] expresses that + the event [t] is generated when invoking external function [ef] + with arguments [vargs], and obtaining [vres] as a return value + from the operating system. *) + Inductive eventval_match: eventval -> typ -> val -> Prop := | ev_match_int: forall i, eventval_match (EVint i) Tint (Vint i) @@ -63,6 +122,10 @@ Inductive event_match: eventval_match eres (proj_sig_res ef.(ef_sig)) vres -> event_match ef vargs (Eextcall ef.(ef_id) eargs eres) vres. +(** The following section shows that [event_match] is stable under + relocation of pointer values, as performed by memory injections + (see module [Mem]). *) + Require Import Mem. Section EVENT_MATCH_INJECT. @@ -101,3 +164,41 @@ Proof. Qed. End EVENT_MATCH_INJECT. + +(** The following section shows that [event_match] is stable under + replacement of [Vundef] values by more defined values. *) + +Section EVENT_MATCH_LESSDEF. + +Remark eventval_match_lessdef: + forall ev ty v1, eventval_match ev ty v1 -> + forall v2, Val.lessdef v1 v2 -> + eventval_match ev ty v2. +Proof. + induction 1; intros; inv H; constructor. +Qed. + +Remark eventval_list_match_moredef: + forall evl tyl vl1, eventval_list_match evl tyl vl1 -> + forall vl2, Val.lessdef_list vl1 vl2 -> + eventval_list_match evl tyl vl2. +Proof. + induction 1; intros. + inversion H; constructor. + inversion H1; constructor. + eapply eventval_match_lessdef; eauto. + eauto. +Qed. + +Lemma event_match_lessdef: + forall ef args1 t res1 args2, + event_match ef args1 t res1 -> + Val.lessdef_list args1 args2 -> + exists res2, event_match ef args2 t res2 /\ Val.lessdef res1 res2. +Proof. + intros. inversion H; subst. exists res1; split. + constructor. eapply eventval_list_match_moredef; eauto. auto. + auto. +Qed. + +End EVENT_MATCH_LESSDEF. diff --git a/common/Globalenvs.v b/common/Globalenvs.v index ccb7b03e..623200fe 100644 --- a/common/Globalenvs.v +++ b/common/Globalenvs.v @@ -19,6 +19,7 @@ system. *) Require Import Coqlib. +Require Import Errors. Require Import Maps. Require Import AST. Require Import Integers. @@ -60,6 +61,34 @@ Module Type GENV. Hypothesis find_funct_find_funct_ptr: forall (F: Set) (ge: t F) (b: block), find_funct ge (Vptr b Int.zero) = find_funct_ptr ge b. + + Hypothesis find_symbol_exists: + forall (F V: Set) (p: program F V) + (id: ident) (init: list init_data) (v: V), + In (id, init, v) (prog_vars p) -> + exists b, find_symbol (globalenv p) id = Some b. + Hypothesis find_funct_ptr_exists: + forall (F V: Set) (p: program F V) (id: ident) (f: F), + list_norepet (prog_funct_names p) -> + list_disjoint (prog_funct_names p) (prog_var_names p) -> + In (id, f) (prog_funct p) -> + exists b, find_symbol (globalenv p) id = Some b + /\ find_funct_ptr (globalenv p) b = Some f. + + Hypothesis find_funct_ptr_inversion: + forall (F V: Set) (P: F -> Prop) (p: program F V) (b: block) (f: F), + find_funct_ptr (globalenv p) b = Some f -> + exists id, In (id, f) (prog_funct p). + Hypothesis find_funct_inversion: + forall (F V: Set) (P: F -> Prop) (p: program F V) (v: val) (f: F), + find_funct (globalenv p) v = Some f -> + exists id, In (id, f) (prog_funct p). + Hypothesis find_funct_ptr_symbol_inversion: + forall (F V: Set) (p: program F V) (id: ident) (b: block) (f: F), + find_symbol (globalenv p) id = Some b -> + find_funct_ptr (globalenv p) b = Some f -> + In (id, f) p.(prog_funct). + Hypothesis find_funct_ptr_prop: forall (F V: Set) (P: F -> Prop) (p: program F V) (b: block) (f: F), (forall id f, In (id, f) (prog_funct p) -> P f) -> @@ -70,24 +99,19 @@ Module Type GENV. (forall id f, In (id, f) (prog_funct p) -> P f) -> find_funct (globalenv p) v = Some f -> P f. - Hypothesis find_funct_ptr_symbol_inversion: - forall (F V: Set) (p: program F V) (id: ident) (b: block) (f: F), - find_symbol (globalenv p) id = Some b -> - find_funct_ptr (globalenv p) b = Some f -> - In (id, f) p.(prog_funct). Hypothesis initmem_nullptr: forall (F V: Set) (p: program F V), let m := init_mem p in valid_block m nullptr /\ m.(blocks) nullptr = empty_block 0 0. - Hypothesis initmem_block_init: - forall (F V: Set) (p: program F V) (b: block), - exists id, (init_mem p).(blocks) b = block_init_data id. - Hypothesis find_funct_ptr_inv: + Hypothesis initmem_inject_neutral: + forall (F V: Set) (p: program F V), + mem_inject_neutral (init_mem p). + Hypothesis find_funct_ptr_negative: forall (F V: Set) (p: program F V) (b: block) (f: F), find_funct_ptr (globalenv p) b = Some f -> b < 0. - Hypothesis find_symbol_inv: + Hypothesis find_symbol_not_fresh: forall (F V: Set) (p: program F V) (id: ident) (b: block), find_symbol (globalenv p) id = Some b -> b < nextblock (init_mem p). @@ -95,74 +119,162 @@ Module Type GENV. and operations over global environments. *) Hypothesis find_funct_ptr_transf: - forall (A B V: Set) (transf: A -> B) (p: program A V) (b: block) (f: A), + forall (A B V: Set) (transf: A -> B) (p: program A V), + forall (b: block) (f: A), find_funct_ptr (globalenv p) b = Some f -> find_funct_ptr (globalenv (transform_program transf p)) b = Some (transf f). Hypothesis find_funct_transf: - forall (A B V: Set) (transf: A -> B) (p: program A V) (v: val) (f: A), + forall (A B V: Set) (transf: A -> B) (p: program A V), + forall (v: val) (f: A), find_funct (globalenv p) v = Some f -> find_funct (globalenv (transform_program transf p)) v = Some (transf f). Hypothesis find_symbol_transf: - forall (A B V: Set) (transf: A -> B) (p: program A V) (s: ident), + forall (A B V: Set) (transf: A -> B) (p: program A V), + forall (s: ident), find_symbol (globalenv (transform_program transf p)) s = find_symbol (globalenv p) s. Hypothesis init_mem_transf: forall (A B V: Set) (transf: A -> B) (p: program A V), init_mem (transform_program transf p) = init_mem p. + Hypothesis find_funct_ptr_rev_transf: + forall (A B V: Set) (transf: A -> B) (p: program A V), + forall (b : block) (tf : B), + find_funct_ptr (globalenv (transform_program transf p)) b = Some tf -> + exists f : A, find_funct_ptr (globalenv p) b = Some f /\ transf f = tf. + Hypothesis find_funct_rev_transf: + forall (A B V: Set) (transf: A -> B) (p: program A V), + forall (v : val) (tf : B), + find_funct (globalenv (transform_program transf p)) v = Some tf -> + exists f : A, find_funct (globalenv p) v = Some f /\ transf f = tf. (** Commutation properties between partial program transformations and operations over global environments. *) Hypothesis find_funct_ptr_transf_partial: - forall (A B V: Set) (transf: A -> option B) - (p: program A V) (p': program B V), - transform_partial_program transf p = Some p' -> + forall (A B V: Set) (transf: A -> res B) (p: program A V) (p': program B V), + transform_partial_program transf p = OK p' -> forall (b: block) (f: A), find_funct_ptr (globalenv p) b = Some f -> - find_funct_ptr (globalenv p') b = transf f /\ transf f <> None. + exists f', + find_funct_ptr (globalenv p') b = Some f' /\ transf f = OK f'. Hypothesis find_funct_transf_partial: - forall (A B V: Set) (transf: A -> option B) - (p: program A V) (p': program B V), - transform_partial_program transf p = Some p' -> + forall (A B V: Set) (transf: A -> res B) (p: program A V) (p': program B V), + transform_partial_program transf p = OK p' -> forall (v: val) (f: A), find_funct (globalenv p) v = Some f -> - find_funct (globalenv p') v = transf f /\ transf f <> None. + exists f', + find_funct (globalenv p') v = Some f' /\ transf f = OK f'. Hypothesis find_symbol_transf_partial: - forall (A B V: Set) (transf: A -> option B) - (p: program A V) (p': program B V), - transform_partial_program transf p = Some p' -> + forall (A B V: Set) (transf: A -> res B) (p: program A V) (p': program B V), + transform_partial_program transf p = OK p' -> forall (s: ident), find_symbol (globalenv p') s = find_symbol (globalenv p) s. Hypothesis init_mem_transf_partial: - forall (A B V: Set) (transf: A -> option B) - (p: program A V) (p': program B V), - transform_partial_program transf p = Some p' -> + forall (A B V: Set) (transf: A -> res B) (p: program A V) (p': program B V), + transform_partial_program transf p = OK p' -> init_mem p' = init_mem p. + Hypothesis find_funct_ptr_rev_transf_partial: + forall (A B V: Set) (transf: A -> res B) (p: program A V) (p': program B V), + transform_partial_program transf p = OK p' -> + forall (b : block) (tf : B), + find_funct_ptr (globalenv p') b = Some tf -> + exists f : A, + find_funct_ptr (globalenv p) b = Some f /\ transf f = OK tf. + Hypothesis find_funct_rev_transf_partial: + forall (A B V: Set) (transf: A -> res B) (p: program A V) (p': program B V), + transform_partial_program transf p = OK p' -> + forall (v : val) (tf : B), + find_funct (globalenv p') v = Some tf -> + exists f : A, + find_funct (globalenv p) v = Some f /\ transf f = OK tf. Hypothesis find_funct_ptr_transf_partial2: - forall (A B V W: Set) (transf_fun: A -> option B) (transf_var: V -> option W) + forall (A B V W: Set) (transf_fun: A -> res B) (transf_var: V -> res W) (p: program A V) (p': program B W), - transform_partial_program2 transf_fun transf_var p = Some p' -> + transform_partial_program2 transf_fun transf_var p = OK p' -> forall (b: block) (f: A), find_funct_ptr (globalenv p) b = Some f -> - find_funct_ptr (globalenv p') b = transf_fun f /\ transf_fun f <> None. + exists f', + find_funct_ptr (globalenv p') b = Some f' /\ transf_fun f = OK f'. Hypothesis find_funct_transf_partial2: - forall (A B V W: Set) (transf_fun: A -> option B) (transf_var: V -> option W) + forall (A B V W: Set) (transf_fun: A -> res B) (transf_var: V -> res W) (p: program A V) (p': program B W), - transform_partial_program2 transf_fun transf_var p = Some p' -> + transform_partial_program2 transf_fun transf_var p = OK p' -> forall (v: val) (f: A), find_funct (globalenv p) v = Some f -> - find_funct (globalenv p') v = transf_fun f /\ transf_fun f <> None. + exists f', + find_funct (globalenv p') v = Some f' /\ transf_fun f = OK f'. Hypothesis find_symbol_transf_partial2: - forall (A B V W: Set) (transf_fun: A -> option B) (transf_var: V -> option W) + forall (A B V W: Set) (transf_fun: A -> res B) (transf_var: V -> res W) (p: program A V) (p': program B W), - transform_partial_program2 transf_fun transf_var p = Some p' -> + transform_partial_program2 transf_fun transf_var p = OK p' -> forall (s: ident), find_symbol (globalenv p') s = find_symbol (globalenv p) s. Hypothesis init_mem_transf_partial2: - forall (A B V W: Set) (transf_fun: A -> option B) (transf_var: V -> option W) + forall (A B V W: Set) (transf_fun: A -> res B) (transf_var: V -> res W) + (p: program A V) (p': program B W), + transform_partial_program2 transf_fun transf_var p = OK p' -> + init_mem p' = init_mem p. + Hypothesis find_funct_ptr_rev_transf_partial2: + forall (A B V W: Set) (transf_fun: A -> res B) (transf_var: V -> res W) + (p: program A V) (p': program B W), + transform_partial_program2 transf_fun transf_var p = OK p' -> + forall (b : block) (tf : B), + find_funct_ptr (globalenv p') b = Some tf -> + exists f : A, + find_funct_ptr (globalenv p) b = Some f /\ transf_fun f = OK tf. + Hypothesis find_funct_rev_transf_partial2: + forall (A B V W: Set) (transf_fun: A -> res B) (transf_var: V -> res W) (p: program A V) (p': program B W), - transform_partial_program2 transf_fun transf_var p = Some p' -> + transform_partial_program2 transf_fun transf_var p = OK p' -> + forall (v : val) (tf : B), + find_funct (globalenv p') v = Some tf -> + exists f : A, + find_funct (globalenv p) v = Some f /\ transf_fun f = OK tf. + +(** Commutation properties between matching between programs + and operations over global environments. *) + + Hypothesis find_funct_ptr_match: + forall (A B V W: Set) (match_fun: A -> B -> Prop) + (match_var: V -> W -> Prop) (p: program A V) (p': program B W), + match_program match_fun match_var p p' -> + forall (b : block) (f : A), + find_funct_ptr (globalenv p) b = Some f -> + exists tf : B, + find_funct_ptr (globalenv p') b = Some tf /\ match_fun f tf. + Hypothesis find_funct_ptr_rev_match: + forall (A B V W: Set) (match_fun: A -> B -> Prop) + (match_var: V -> W -> Prop) (p: program A V) (p': program B W), + match_program match_fun match_var p p' -> + forall (b : block) (tf : B), + find_funct_ptr (globalenv p') b = Some tf -> + exists f : A, + find_funct_ptr (globalenv p) b = Some f /\ match_fun f tf. + Hypothesis find_funct_match: + forall (A B V W: Set) (match_fun: A -> B -> Prop) + (match_var: V -> W -> Prop) (p: program A V) (p': program B W), + match_program match_fun match_var p p' -> + forall (v : val) (f : A), + find_funct (globalenv p) v = Some f -> + exists tf : B, find_funct (globalenv p') v = Some tf /\ match_fun f tf. + Hypothesis find_funct_rev_match: + forall (A B V W: Set) (match_fun: A -> B -> Prop) + (match_var: V -> W -> Prop) (p: program A V) (p': program B W), + match_program match_fun match_var p p' -> + forall (v : val) (tf : B), + find_funct (globalenv p') v = Some tf -> + exists f : A, find_funct (globalenv p) v = Some f /\ match_fun f tf. + Hypothesis find_symbol_match: + forall (A B V W: Set) (match_fun: A -> B -> Prop) + (match_var: V -> W -> Prop) (p: program A V) (p': program B W), + match_program match_fun match_var p p' -> + forall (s : ident), + find_symbol (globalenv p') s = find_symbol (globalenv p) s. + Hypothesis init_mem_match: + forall (A B V W: Set) (match_fun: A -> B -> Prop) + (match_var: V -> W -> Prop) (p: program A V) (p': program B W), + match_program match_fun match_var p p' -> init_mem p' = init_mem p. End GENV. @@ -280,10 +392,10 @@ Lemma initmem_nullptr: forall (p: program F V), let m := init_mem p in valid_block m nullptr /\ - m.(blocks) nullptr = mkblock 0 0 (fun y => Undef) (undef_undef_outside 0 0). + m.(blocks) nullptr = mkblock 0 0 (fun y => Undef). Proof. pose (P := fun m => valid_block m nullptr /\ - m.(blocks) nullptr = mkblock 0 0 (fun y => Undef) (undef_undef_outside 0 0)). + m.(blocks) nullptr = mkblock 0 0 (fun y => Undef)). assert (forall init, P (snd init) -> forall vars, P (snd (add_globals init vars))). induction vars; simpl; intros. auto. @@ -297,25 +409,25 @@ Proof. red; simpl. split. compute. auto. reflexivity. Qed. -Lemma initmem_block_init: - forall (p: program F V) (b: block), - exists id, (init_mem p).(blocks) b = block_init_data id. +Lemma initmem_inject_neutral: + forall (p: program F V), + mem_inject_neutral (init_mem p). Proof. - assert (forall g0 vars g1 m b, + assert (forall g0 vars g1 m, add_globals (g0, Mem.empty) vars = (g1, m) -> - exists id, m.(blocks) b = block_init_data id). - induction vars; simpl. - intros. inversion H. unfold Mem.empty; simpl. - exists (@nil init_data). symmetry. apply Mem.block_init_data_empty. + mem_inject_neutral m). + Opaque alloc_init_data. + induction vars; simpl. + intros. inv H. red; intros. destruct (load_inv _ _ _ _ _ H). + simpl in H1. rewrite Mem.getN_init in H1. + replace v with Vundef. auto. destruct chunk; simpl in H1; auto. destruct a as [[id1 init1] info1]. - caseEq (add_globals (g0, Mem.empty) vars). intros g1 m1 EQ. - intros g m b EQ1. injection EQ1; intros EQ2 EQ3; clear EQ1. - rewrite <- EQ2; simpl. unfold update. - case (zeq b (nextblock m1)); intro. - exists init1; auto. - eauto. - intros. caseEq (globalenv_initmem p). - intros g m EQ. unfold init_mem; rewrite EQ; simpl. + caseEq (add_globals (g0, Mem.empty) vars). intros g1 m1 EQ. + caseEq (alloc_init_data m1 init1). intros m2 b ALLOC. + intros. inv H. + eapply Mem.alloc_init_data_neutral; eauto. + intros. caseEq (globalenv_initmem p). intros g m EQ. + unfold init_mem; rewrite EQ; simpl. unfold globalenv_initmem in EQ. eauto. Qed. @@ -325,7 +437,7 @@ Proof. induction fns; simpl; intros. omega. unfold Zpred. omega. Qed. -Theorem find_funct_ptr_inv: +Theorem find_funct_ptr_negative: forall (p: program F V) (b: block) (f: F), find_funct_ptr (globalenv p) b = Some f -> b < 0. Proof. @@ -340,7 +452,7 @@ Proof. intros. eauto. Qed. -Theorem find_symbol_inv: +Theorem find_symbol_not_fresh: forall (p: program F V) (id: ident) (b: block), find_symbol (globalenv p) id = Some b -> b < nextblock (init_mem p). Proof. @@ -358,6 +470,7 @@ Proof. induction vars; simpl; intros until b. intros. inversion H0. subst g m. simpl. generalize (H fns s b H1). omega. + Transparent alloc_init_data. destruct a as [[id1 init1] info1]. caseEq (add_globals (add_functs empty fns, Mem.empty) vars). intros g1 m1 ADG EQ. inversion EQ; subst g m; clear EQ. @@ -373,20 +486,125 @@ Qed. End GENV. (* Invariants on functions *) + +Lemma find_symbol_exists: + forall (F V: Set) (p: program F V) + (id: ident) (init: list init_data) (v: V), + In (id, init, v) (prog_vars p) -> + exists b, find_symbol (globalenv p) id = Some b. +Proof. + intros until v. + assert (forall initm vl, In (id, init, v) vl -> + exists b, PTree.get id (@symbols F (fst (add_globals initm vl))) = Some b). + induction vl; simpl; intros. + elim H. + destruct a as [[id0 init0] v0]. + caseEq (add_globals initm vl). intros g1 m1 EQ. simpl. + rewrite PTree.gsspec. destruct (peq id id0). econstructor; eauto. + elim H; intro. congruence. generalize (IHvl H0). rewrite EQ. auto. + intros. unfold globalenv, find_symbol, globalenv_initmem. auto. +Qed. + +Remark find_symbol_above_nextfunction: + forall (F: Set) (id: ident) (b: block) (fns: list (ident * F)), + let g := add_functs (empty F) fns in + PTree.get id g.(symbols) = Some b -> + b > g.(nextfunction). +Proof. + induction fns; simpl. + rewrite PTree.gempty. congruence. + rewrite PTree.gsspec. case (peq id (fst a)); intro. + intro EQ. inversion EQ. unfold Zpred. omega. + intros. generalize (IHfns H). unfold Zpred; omega. +Qed. + +Remark find_symbol_add_globals: + forall (F V: Set) (id: ident) (ge_m: t F * mem) (vars: list (ident * list init_data * V)), + ~In id (map (fun x: ident * list init_data * V => fst(fst x)) vars) -> + find_symbol (fst (add_globals ge_m vars)) id = + find_symbol (fst ge_m) id. +Proof. + unfold find_symbol; induction vars; simpl; intros. + auto. + destruct a as [[id0 init0] var0]. simpl in *. + caseEq (add_globals ge_m vars); intros ge' m' EQ. + simpl. rewrite PTree.gso. rewrite EQ in IHvars. simpl in IHvars. + apply IHvars. tauto. intuition congruence. +Qed. + +Lemma find_funct_ptr_exists: + forall (F V: Set) (p: program F V) (id: ident) (f: F), + list_norepet (prog_funct_names p) -> + list_disjoint (prog_funct_names p) (prog_var_names p) -> + In (id, f) (prog_funct p) -> + exists b, find_symbol (globalenv p) id = Some b + /\ find_funct_ptr (globalenv p) b = Some f. +Proof. + intros until f. + assert (forall (fns: list (ident * F)), + list_norepet (map (@fst ident F) fns) -> + In (id, f) fns -> + exists b, find_symbol (add_functs (empty F) fns) id = Some b + /\ find_funct_ptr (add_functs (empty F) fns) b = Some f). + unfold find_symbol, find_funct_ptr. induction fns; intros. + elim H0. + destruct a as [id0 f0]; simpl in *. inv H. + unfold add_funct; simpl. + rewrite PTree.gsspec. destruct (peq id id0). + subst id0. econstructor; split. eauto. + replace f0 with f. apply ZMap.gss. + elim H0; intro. congruence. elim H3. + change id with (@fst ident F (id, f)). apply List.in_map. auto. + exploit IHfns; eauto. elim H0; intro. congruence. auto. + intros [b [X Y]]. exists b; split. auto. rewrite ZMap.gso. auto. + generalize (find_symbol_above_nextfunction _ _ X). + unfold block; unfold ZIndexed.t; intro; omega. + + intros. exploit H; eauto. assumption. intros [b [X Y]]. + exists b; split. + unfold globalenv, globalenv_initmem. rewrite find_symbol_add_globals. + assumption. apply list_disjoint_notin with (prog_funct_names p). assumption. + unfold prog_funct_names. change id with (fst (id, f)). + apply List.in_map; auto. + unfold find_funct_ptr. rewrite functions_globalenv. + assumption. +Qed. + +Lemma find_funct_ptr_inversion: + forall (F V: Set) (P: F -> Prop) (p: program F V) (b: block) (f: F), + find_funct_ptr (globalenv p) b = Some f -> + exists id, In (id, f) (prog_funct p). +Proof. + intros until f. + assert (forall fns: list (ident * F), + find_funct_ptr (add_functs (empty F) fns) b = Some f -> + exists id, In (id, f) fns). + unfold find_funct_ptr. induction fns; simpl. + rewrite ZMap.gi. congruence. + destruct a as [id0 f0]; simpl. + rewrite ZMap.gsspec. destruct (ZIndexed.eq b (nextfunction (add_functs (empty F) fns))). + intro. inv H. exists id0; auto. + intro. exploit IHfns; eauto. intros [id A]. exists id; auto. + unfold find_funct_ptr; rewrite functions_globalenv. intros; apply H; auto. +Qed. + Lemma find_funct_ptr_prop: forall (F V: Set) (P: F -> Prop) (p: program F V) (b: block) (f: F), (forall id f, In (id, f) (prog_funct p) -> P f) -> find_funct_ptr (globalenv p) b = Some f -> P f. Proof. - intros until f. - unfold find_funct_ptr. rewrite functions_globalenv. - generalize (prog_funct p). induction l; simpl. - rewrite ZMap.gi. intros; discriminate. - rewrite ZMap.gsspec. - case (ZIndexed.eq b (nextfunction (add_functs (empty F) l))); intros. - apply H with (fst a). left. destruct a. simpl in *. congruence. - apply IHl. intros. apply H with id. right. auto. auto. + intros. exploit find_funct_ptr_inversion; eauto. intros [id A]. eauto. +Qed. + +Lemma find_funct_inversion: + forall (F V: Set) (P: F -> Prop) (p: program F V) (v: val) (f: F), + find_funct (globalenv p) v = Some f -> + exists id, In (id, f) (prog_funct p). +Proof. + intros. exploit find_funct_inv; eauto. intros [b EQ]. rewrite EQ in H. + rewrite find_funct_find_funct_ptr in H. + eapply find_funct_ptr_inversion; eauto. Qed. Lemma find_funct_prop: @@ -395,10 +613,7 @@ Lemma find_funct_prop: find_funct (globalenv p) v = Some f -> P f. Proof. - intros until f. unfold find_funct. - destruct v; try (intros; discriminate). - case (Int.eq i Int.zero); [idtac | intros; discriminate]. - intros. eapply find_funct_ptr_prop; eauto. + intros. exploit find_funct_inversion; eauto. intros [id A]. eauto. Qed. Lemma find_funct_ptr_symbol_inversion: @@ -408,15 +623,6 @@ Lemma find_funct_ptr_symbol_inversion: In (id, f) p.(prog_funct). Proof. intros until f. - assert (forall fns, - let g := add_functs (empty F) fns in - PTree.get id g.(symbols) = Some b -> - b > g.(nextfunction)). - induction fns; simpl. - rewrite PTree.gempty. congruence. - rewrite PTree.gsspec. case (peq id (fst a)); intro. - intro EQ. inversion EQ. unfold Zpred. omega. - intros. generalize (IHfns H). unfold Zpred; omega. assert (forall fns, let g := add_functs (empty F) fns in PTree.get id g.(symbols) = Some b -> @@ -430,216 +636,336 @@ Proof. intro EQ. inversion EQ. unfold ZIndexed.eq. rewrite zeq_true. intro EQ2. left. destruct a. simpl in *. congruence. intro. unfold ZIndexed.eq. rewrite zeq_false. intro. eauto. - generalize (H _ H0). fold g. unfold block. omega. + generalize (find_symbol_above_nextfunction _ _ H). fold g. unfold block. omega. assert (forall g0 m0, b < 0 -> forall vars g m, @add_globals F V (g0, m0) vars = (g, m) -> PTree.get id g.(symbols) = Some b -> PTree.get id g0.(symbols) = Some b). induction vars; simpl. - intros. inversion H2. auto. + intros. inv H1. auto. destruct a as [[id1 init1] info1]. caseEq (add_globals (g0, m0) vars). intros g1 m1 EQ g m EQ1. injection EQ1; simpl; clear EQ1. unfold add_symbol; intros A B. rewrite <- B. simpl. rewrite PTree.gsspec. case (peq id id1); intros. - assert (b > 0). injection H2; intros. rewrite <- H3. apply nextblock_pos. + assert (b > 0). inv H1. apply nextblock_pos. omegaContradiction. eauto. intros. - generalize (find_funct_ptr_inv _ _ H3). intro. + generalize (find_funct_ptr_negative _ _ H2). intro. pose (g := add_functs (empty F) (prog_funct p)). - apply H0. - apply H1 with Mem.empty (prog_vars p) (globalenv p) (init_mem p). + apply H. + apply H0 with Mem.empty (prog_vars p) (globalenv p) (init_mem p). auto. unfold globalenv, init_mem. rewrite <- surjective_pairing. reflexivity. assumption. rewrite <- functions_globalenv. assumption. Qed. (* Global environments and program transformations. *) -Section TRANSF_PROGRAM_PARTIAL2. +Section MATCH_PROGRAM. Variable A B V W: Set. -Variable transf_fun: A -> option B. -Variable transf_var: V -> option W. +Variable match_fun: A -> B -> Prop. +Variable match_var: V -> W -> Prop. Variable p: program A V. Variable p': program B W. -Hypothesis transf_OK: - transform_partial_program2 transf_fun transf_var p = Some p'. +Hypothesis match_prog: + match_program match_fun match_var p p'. -Lemma add_functs_transf: +Lemma add_functs_match: forall (fns: list (ident * A)) (tfns: list (ident * B)), - map_partial transf_fun fns = Some tfns -> + list_forall2 (match_funct_entry match_fun) fns tfns -> let r := add_functs (empty A) fns in let tr := add_functs (empty B) tfns in nextfunction tr = nextfunction r /\ symbols tr = symbols r /\ forall (b: block) (f: A), ZMap.get b (functions r) = Some f -> - ZMap.get b (functions tr) = transf_fun f /\ transf_fun f <> None. + exists tf, ZMap.get b (functions tr) = Some tf /\ match_fun f tf. Proof. - induction fns; simpl. + induction 1; simpl. - intros; injection H; intro; subst tfns. - simpl. split. reflexivity. split. reflexivity. + split. reflexivity. split. reflexivity. intros b f; repeat (rewrite ZMap.gi). intros; discriminate. - intro tfns. destruct a. caseEq (transf_fun a). intros a' TA. - caseEq (map_partial transf_fun fns). intros l TPP EQ. - injection EQ; intro; subst tfns. - clear EQ. simpl. - generalize (IHfns l TPP). - intros [HR1 [HR2 HR3]]. - rewrite HR1. rewrite HR2. - split. reflexivity. - split. reflexivity. + destruct a1 as [id1 fn1]. destruct b1 as [id2 fn2]. + simpl. red in H. destruct H. + destruct IHlist_forall2 as [X [Y Z]]. + rewrite X. rewrite Y. + split. auto. + split. congruence. intros b f. - case (zeq b (nextfunction (add_functs (empty A) fns))); intro. - subst b. repeat (rewrite ZMap.gss). - intro EQ; injection EQ; intro; subst f; clear EQ. - rewrite TA. split. auto. discriminate. - repeat (rewrite ZMap.gso; auto). + repeat (rewrite ZMap.gsspec). + destruct (ZIndexed.eq b (nextfunction (add_functs (empty A) al))). + intro EQ; inv EQ. exists fn2; auto. + auto. +Qed. - intros; discriminate. - intros; discriminate. +Lemma add_functs_rev_match: + forall (fns: list (ident * A)) (tfns: list (ident * B)), + list_forall2 (match_funct_entry match_fun) fns tfns -> + let r := add_functs (empty A) fns in + let tr := add_functs (empty B) tfns in + nextfunction tr = nextfunction r /\ + symbols tr = symbols r /\ + forall (b: block) (tf: B), + ZMap.get b (functions tr) = Some tf -> + exists f, ZMap.get b (functions r) = Some f /\ match_fun f tf. +Proof. + induction 1; simpl. + + split. reflexivity. split. reflexivity. + intros b f; repeat (rewrite ZMap.gi). intros; discriminate. + + destruct a1 as [id1 fn1]. destruct b1 as [id2 fn2]. + simpl. red in H. destruct H. + destruct IHlist_forall2 as [X [Y Z]]. + rewrite X. rewrite Y. + split. auto. + split. congruence. + intros b f. + repeat (rewrite ZMap.gsspec). + destruct (ZIndexed.eq b (nextfunction (add_functs (empty A) al))). + intro EQ; inv EQ. exists fn1; auto. + auto. Qed. -Lemma mem_add_globals_transf: +Lemma mem_add_globals_match: forall (g1: genv A) (g2: genv B) (m: mem) (vars: list (ident * list init_data * V)) (tvars: list (ident * list init_data * W)), - map_partial transf_var vars = Some tvars -> + list_forall2 (match_var_entry match_var) vars tvars -> snd (add_globals (g1, m) vars) = snd (add_globals (g2, m) tvars). Proof. - induction vars; simpl. - intros. inversion H. reflexivity. - intro. destruct a as [[id1 init1] info1]. - caseEq (transf_var info1); try congruence. - intros tinfo1 EQ1. - caseEq (map_partial transf_var vars); try congruence. - intros tvars' EQ2 EQ3. - inversion EQ3. simpl. - generalize (IHvars _ EQ2). - destruct (add_globals (g1, m) vars). - destruct (add_globals (g2, m) tvars'). + induction 1; simpl. + auto. + destruct a1 as [[id1 init1] info1]. + destruct b1 as [[id2 init2] info2]. + red in H. destruct H as [X [Y Z]]. subst id2 init2. + generalize IHlist_forall2. + destruct (add_globals (g1, m) al). + destruct (add_globals (g2, m) bl). simpl. intro. subst m1. auto. Qed. -Lemma symbols_add_globals_transf: +Lemma symbols_add_globals_match: forall (g1: genv A) (g2: genv B) (m: mem), symbols g1 = symbols g2 -> forall (vars: list (ident * list init_data * V)) (tvars: list (ident * list init_data * W)), - map_partial transf_var vars = Some tvars -> + list_forall2 (match_var_entry match_var) vars tvars -> symbols (fst (add_globals (g1, m) vars)) = symbols (fst (add_globals (g2, m) tvars)). Proof. - induction vars; simpl. - intros. inversion H0. assumption. - intro. destruct a as [[id1 init1] info1]. - caseEq (transf_var info1); try congruence. intros tinfo1 EQ1. - caseEq (map_partial transf_var vars); try congruence. - intros tvars' EQ2 EQ3. inversion EQ3; simpl. - generalize (IHvars _ EQ2). - generalize (mem_add_globals_transf g1 g2 m vars EQ2). - destruct (add_globals (g1, m) vars). - destruct (add_globals (g2, m) tvars'). + induction 2; simpl. + auto. + destruct a1 as [[id1 init1] info1]. + destruct b1 as [[id2 init2] info2]. + red in H0. destruct H0 as [X [Y Z]]. subst id2 init2. + generalize IHlist_forall2. + generalize (mem_add_globals_match g1 g2 m H1). + destruct (add_globals (g1, m) al). + destruct (add_globals (g2, m) bl). simpl. intros. congruence. Qed. -(* -Lemma prog_funct_transf_OK: - transf_partial_program transf p.(prog_funct) = Some p'.(prog_funct). +Theorem find_funct_ptr_match: + forall (b: block) (f: A), + find_funct_ptr (globalenv p) b = Some f -> + exists tf, find_funct_ptr (globalenv p') b = Some tf /\ match_fun f tf. Proof. - generalize transf_OK; unfold transform_partial_program. - case (transf_partial_program transf (prog_funct p)); simpl; intros. - injection transf_OK0; intros; subst p'. reflexivity. - discriminate. + intros until f. destruct match_prog as [X [Y Z]]. + destruct (add_functs_match X) as [P [Q R]]. + unfold find_funct_ptr. repeat rewrite functions_globalenv. + auto. Qed. -*) -Theorem find_funct_ptr_transf_partial2: - forall (b: block) (f: A), - find_funct_ptr (globalenv p) b = Some f -> - find_funct_ptr (globalenv p') b = transf_fun f /\ transf_fun f <> None. +Theorem find_funct_ptr_rev_match: + forall (b: block) (tf: B), + find_funct_ptr (globalenv p') b = Some tf -> + exists f, find_funct_ptr (globalenv p) b = Some f /\ match_fun f tf. Proof. - intros until f. functional inversion transf_OK. - destruct (add_functs_transf _ H0) as [P [Q R]]. - unfold find_funct_ptr. repeat rewrite functions_globalenv. simpl. + intros until tf. destruct match_prog as [X [Y Z]]. + destruct (add_functs_rev_match X) as [P [Q R]]. + unfold find_funct_ptr. repeat rewrite functions_globalenv. auto. Qed. -Theorem find_funct_transf_partial2: +Theorem find_funct_match: forall (v: val) (f: A), find_funct (globalenv p) v = Some f -> - find_funct (globalenv p') v = transf_fun f /\ transf_fun f <> None. + exists tf, find_funct (globalenv p') v = Some tf /\ match_fun f tf. Proof. intros until f. unfold find_funct. case v; try (intros; discriminate). intros b ofs. case (Int.eq ofs Int.zero); try (intros; discriminate). - apply find_funct_ptr_transf_partial2. + apply find_funct_ptr_match. Qed. -Lemma symbols_init_transf2: +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. +Proof. + intros until tf. unfold find_funct. + case v; try (intros; discriminate). + intros b ofs. + case (Int.eq ofs Int.zero); try (intros; discriminate). + apply find_funct_ptr_rev_match. +Qed. + +Lemma symbols_init_match: symbols (globalenv p') = symbols (globalenv p). Proof. unfold globalenv. unfold globalenv_initmem. - functional inversion transf_OK. - destruct (add_functs_transf _ H0) as [P [Q R]]. - simpl. symmetry. apply symbols_add_globals_transf. auto. auto. + destruct match_prog as [X [Y Z]]. + destruct (add_functs_match X) as [P [Q R]]. + simpl. symmetry. apply symbols_add_globals_match. auto. auto. Qed. -Theorem find_symbol_transf_partial2: +Theorem find_symbol_match: forall (s: ident), find_symbol (globalenv p') s = find_symbol (globalenv p) s. Proof. intros. unfold find_symbol. - rewrite symbols_init_transf2. auto. + rewrite symbols_init_match. auto. +Qed. + +Theorem init_mem_match: + init_mem p' = init_mem p. +Proof. + unfold init_mem. unfold globalenv_initmem. + destruct match_prog as [X [Y Z]]. + symmetry. apply mem_add_globals_match. auto. +Qed. + +End MATCH_PROGRAM. + +Section TRANSF_PROGRAM_PARTIAL2. + +Variable A B V W: Set. +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 prog_match: + match_program + (fun fd tfd => transf_fun fd = OK tfd) + (fun info tinfo => transf_var info = OK tinfo) + p p'. +Proof. + apply transform_partial_program2_match; auto. +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. + intros. + exploit find_funct_ptr_match. eexact prog_match. eauto. + intros [tf [X Y]]. exists tf; auto. +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. + intros. + exploit find_funct_ptr_rev_match. eexact prog_match. eauto. auto. +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. + intros. + exploit find_funct_match. eexact prog_match. eauto. + intros [tf [X Y]]. exists tf; auto. +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. + intros. + exploit find_funct_rev_match. eexact prog_match. eauto. auto. +Qed. + +Theorem find_symbol_transf_partial2: + forall (s: ident), + find_symbol (globalenv p') s = find_symbol (globalenv p) s. +Proof. + intros. eapply find_symbol_match. eexact prog_match. Qed. Theorem init_mem_transf_partial2: init_mem p' = init_mem p. Proof. - unfold init_mem. unfold globalenv_initmem. - functional inversion transf_OK. - simpl. symmetry. apply mem_add_globals_transf. auto. + intros. eapply init_mem_match. eexact prog_match. Qed. End TRANSF_PROGRAM_PARTIAL2. - Section TRANSF_PROGRAM_PARTIAL. Variable A B V: Set. -Variable transf: A -> option B. +Variable transf: A -> res B. Variable p: program A V. Variable p': program B V. -Hypothesis transf_OK: transform_partial_program transf p = Some p'. +Hypothesis transf_OK: transform_partial_program transf p = OK p'. Remark transf2_OK: - transform_partial_program2 transf (fun x => Some x) p = Some p'. + transform_partial_program2 transf (fun x => OK x) p = OK p'. Proof. rewrite <- transf_OK. unfold transform_partial_program2, transform_partial_program. - destruct (map_partial transf (prog_funct p)); auto. + destruct (map_partial prefix_funct_name transf (prog_funct p)); auto. rewrite map_partial_identity; auto. Qed. Theorem find_funct_ptr_transf_partial: forall (b: block) (f: A), find_funct_ptr (globalenv p) b = Some f -> - find_funct_ptr (globalenv p') b = transf f /\ transf f <> None. + exists f', + find_funct_ptr (globalenv p') b = Some f' /\ transf f = OK f'. Proof. exact (@find_funct_ptr_transf_partial2 _ _ _ _ _ _ _ _ transf2_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. +Proof. + exact (@find_funct_ptr_rev_transf_partial2 _ _ _ _ _ _ _ _ transf2_OK). +Qed. + Theorem find_funct_transf_partial: forall (v: val) (f: A), find_funct (globalenv p) v = Some f -> - find_funct (globalenv p') v = transf f /\ transf f <> None. + exists f', + find_funct (globalenv p') v = Some f' /\ transf f = OK f'. Proof. exact (@find_funct_transf_partial2 _ _ _ _ _ _ _ _ transf2_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. +Proof. + exact (@find_funct_rev_transf_partial2 _ _ _ _ _ _ _ _ transf2_OK). +Qed. + Theorem find_symbol_transf_partial: forall (s: ident), find_symbol (globalenv p') s = find_symbol (globalenv p) s. @@ -663,7 +989,7 @@ Variable p: program A V. Let tp := transform_program transf p. Remark transf_OK: - transform_partial_program (fun x => Some (transf x)) p = Some tp. + transform_partial_program (fun x => OK (transf x)) p = OK tp. Proof. unfold tp, transform_program, transform_partial_program. rewrite map_partial_total. reflexivity. @@ -676,7 +1002,16 @@ Theorem find_funct_ptr_transf: Proof. intros. destruct (@find_funct_ptr_transf_partial _ _ _ _ _ _ transf_OK _ _ H) - as [X Y]. auto. + 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. Qed. Theorem find_funct_transf: @@ -686,7 +1021,16 @@ Theorem find_funct_transf: Proof. intros. destruct (@find_funct_transf_partial _ _ _ _ _ _ transf_OK _ _ H) - as [X Y]. auto. + 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. Qed. Theorem find_symbol_transf: diff --git a/common/Main.v b/common/Main.v index f472ec3a..33bc7830 100644 --- a/common/Main.v +++ b/common/Main.v @@ -1,40 +1,48 @@ -(** The compiler back-end and its proof of semantic preservation *) +(** The whole compiler and its proof of semantic preservation *) (** Libraries. *) Require Import Coqlib. Require Import Maps. +Require Import Errors. Require Import AST. Require Import Values. +Require Import Smallstep. (** Languages (syntax and semantics). *) Require Csyntax. Require Csem. Require Csharpminor. Require Cminor. +Require CminorSel. Require RTL. Require LTL. +Require LTLin. Require Linear. Require Mach. Require PPC. (** Translation passes. *) Require Cshmgen. Require Cminorgen. +Require Selection. Require RTLgen. Require Constprop. Require CSE. Require Allocation. Require Tunneling. Require Linearize. +Require Reload. Require Stacking. Require PPCgen. (** Type systems. *) Require Ctyping. Require RTLtyping. Require LTLtyping. +Require LTLintyping. Require Lineartyping. Require Machtyping. (** Proofs of semantic preservation and typing preservation. *) Require Cshmgenproof3. Require Cminorgenproof. +Require Selectionproof. Require RTLgenproof. Require Constpropproof. Require CSEproof. @@ -44,266 +52,234 @@ Require Tunnelingproof. Require Tunnelingtyping. Require Linearizeproof. Require Linearizetyping. +Require Reloadproof. +Require Reloadtyping. Require Stackingproof. Require Stackingtyping. -Require Machabstr2mach. +Require Machabstr2concr. Require PPCgenproof. +Open Local Scope string_scope. + (** * Composing the translation passes *) (** We first define useful monadic composition operators, along with funny (but convenient) notations. *) -Definition apply_total (A B: Set) (x: option A) (f: A -> B) : option B := - match x with None => None | Some x1 => Some (f x1) end. +Definition apply_total (A B: Set) (x: res A) (f: A -> B) : res B := + match x with Error msg => Error msg | OK x1 => OK (f x1) end. Definition apply_partial (A B: Set) - (x: option A) (f: A -> option B) : option B := - match x with None => None | Some x1 => f x1 end. + (x: res A) (f: A -> res B) : res B := + match x with Error msg => Error msg | OK x1 => f x1 end. Notation "a @@@ b" := (apply_partial _ _ a b) (at level 50, left associativity). Notation "a @@ b" := (apply_total _ _ a b) (at level 50, left associativity). -(** We define two translation functions for whole programs: one starting with - a C program, the other with a Cminor program. Both - translations produce PPC programs ready for pretty-printing and - assembling. +(** We define three translation functions for whole programs: one + starting with a C program, one with a Cminor program, one with an + RTL program. The three translations produce PPC programs ready for + pretty-printing and assembling. - There are two ways to compose the compiler passes. The first translates - every function from the Cminor program from Cminor to RTL, then to LTL, etc, - all the way to PPC, and iterates this transformation for every function. - The second translates the whole Cminor program to a RTL program, then to - an LTL program, etc. We follow the first approach because it has lower - memory requirements. + There are two ways to compose the compiler passes. The first + translates every function from the Cminor program from Cminor to + RTL, then to LTL, etc, all the way to PPC, and iterates this + transformation for every function. The second translates the whole + Cminor program to a RTL program, then to an LTL program, etc. + Between Cminor and PPC, we follow the first approach because it has + lower memory requirements. The translation from Clight to PPC + follows the second approach. - The translation of a Cminor function to a PPC function is as follows. *) + The translation of an RTL function to a PPC function is as follows. *) -Definition transf_cminor_fundef (f: Cminor.fundef) : option PPC.fundef := - Some f - @@@ RTLgen.transl_fundef +Definition transf_rtl_fundef (f: RTL.fundef) : res PPC.fundef := + OK f @@ Constprop.transf_fundef @@ CSE.transf_fundef @@@ Allocation.transf_fundef @@ Tunneling.tunnel_fundef @@ Linearize.transf_fundef + @@ Reload.transf_fundef @@@ Stacking.transf_fundef @@@ PPCgen.transf_fundef. +(* Here is the translation of a Cminor function to a PPC function. *) + +Definition transf_cminor_fundef (f: Cminor.fundef) : res PPC.fundef := + OK f + @@ Selection.sel_fundef + @@@ RTLgen.transl_fundef + @@@ transf_rtl_fundef. + (** The corresponding translations for whole program follow. *) -Definition transf_cminor_program (p: Cminor.program) : option PPC.program := +Definition transf_rtl_program (p: RTL.program) : res PPC.program := + transform_partial_program transf_rtl_fundef p. + +Definition transf_cminor_program (p: Cminor.program) : res PPC.program := transform_partial_program transf_cminor_fundef p. -Definition transf_c_program (p: Csyntax.program) : option PPC.program := +Definition transf_c_program (p: Csyntax.program) : res PPC.program := match Ctyping.typecheck_program p with - | false => None + | false => + Error (msg "Ctyping: type error") | true => - Some p + OK p @@@ Cshmgen.transl_program @@@ Cminorgen.transl_program @@@ transf_cminor_program end. -(** * Equivalence with whole program transformations *) - -(** To prove semantic preservation for the whole compiler, it is easier to reason - over the second way to compose the compiler pass: the one that translate - whole programs through each compiler pass. We now define this second translation - and prove that it produces the same PPC programs as the first translation. *) - -Definition transf_cminor_program2 (p: Cminor.program) : option PPC.program := - Some p - @@@ RTLgen.transl_program - @@ Constprop.transf_program - @@ CSE.transf_program - @@@ Allocation.transf_program - @@ Tunneling.tunnel_program - @@ Linearize.transf_program - @@@ Stacking.transf_program - @@@ PPCgen.transf_program. +(** The following lemmas help reason over compositions of passes. *) Lemma map_partial_compose: forall (X A B C: Set) - (f1: A -> option B) (f2: B -> option C) - (p: list (X * A)), - map_partial f1 p @@@ map_partial f2 = - map_partial (fun f => f1 f @@@ f2) p. + (ctx: X -> errmsg) + (f1: A -> res B) (f2: B -> res C) + (pa: list (X * A)) (pc: list (X * C)), + map_partial ctx (fun f => f1 f @@@ f2) pa = OK pc -> + exists pb, map_partial ctx f1 pa = OK pb /\ map_partial ctx f2 pb = OK pc. Proof. - induction p. simpl. auto. - simpl. destruct a. destruct (f1 a). - simpl. simpl in IHp. destruct (map_partial f1 p). - simpl. simpl in IHp. destruct (f2 b). - destruct (map_partial f2 l). - rewrite <- IHp. auto. - rewrite <- IHp. auto. - auto. - simpl. rewrite <- IHp. simpl. destruct (f2 b); auto. - simpl. auto. + induction pa; simpl. + intros. inv H. econstructor; eauto. + intro pc. destruct a as [x a]. + caseEq (f1 a); simpl; try congruence. intros b F1. + caseEq (f2 b); simpl; try congruence. intros c F2 EQ. + monadInv EQ. exploit IHpa; eauto. intros [pb [P Q]]. + rewrite P; simpl. + exists ((x, b) :: pb); split. auto. simpl. rewrite F2. rewrite Q. auto. Qed. -(* -Lemma transform_partial_program2_compose: - forall (A B C V W X: Set) - (f1: A -> option B) (g1: V -> option W) - (f2: B -> option C) (g2: W -> option X) - (p: program A V), - transform_partial_program2 f1 g1 p @@@ - (fun p' => transform_partial_program2 f2 g2 p') = - transform_partial_program2 (fun x => f1 x @@@ f2) (fun x => g1 x @@@ g2) p. +Lemma transform_partial_program_compose: + forall (A B C V: Set) + (f1: A -> res B) (f2: B -> res C) + (pa: program A V) (pc: program C V), + transform_partial_program (fun f => f1 f @@@ f2) pa = OK pc -> + exists pb, transform_partial_program f1 pa = OK pb /\ + transform_partial_program f2 pb = OK pc. Proof. - unfold transform_partial_program2; intros. - rewrite <- map_partial_compose; simpl. - rewrite <- map_partial_compose; simpl. - destruct (map_partial f1 (prog_funct p)); simpl; auto. - destruct (map_partial g1 (prog_vars p)); simpl; auto. - destruct (map_partial f2 l); auto. + intros. monadInv H. + exploit map_partial_compose; eauto. intros [xb [P Q]]. + exists (mkprogram xb (prog_main pa) (prog_vars pa)); split. + unfold transform_partial_program. rewrite P; auto. + unfold transform_partial_program. simpl. rewrite Q; auto. Qed. -Lemma transform_program_partial2_partial: - forall (A B V: Set) (f: A -> option B) (p: program A V), - transform_partial_program f p = - transform_partial_program2 f (fun x => Some x) p. +Lemma transform_program_partial_program: + forall (A B V: Set) (f: A -> B) (p: program A V) (tp: program B V), + transform_partial_program (fun x => OK (f x)) p = OK tp -> + transform_program f p = tp. Proof. - intros. unfold transform_partial_program, transform_partial_program2. - rewrite map_partial_identity. auto. + intros until tp. unfold transform_partial_program. + rewrite map_partial_total. simpl. intros. inv H. auto. Qed. -Lemma apply_partial_transf_program: - forall (A B V: Set) (f: A -> option B) (x: option (program A V)), - x @@@ (fun p => transform_partial_program f p) = - x @@@ (fun p => transform_partial_program2 f (fun x => Some x) p). -Proof. - intros. unfold apply_partial. - destruct x. apply transform_program_partial2_partial. auto. -Qed. -*) -Lemma transform_partial_program_compose: +Lemma transform_program_compose: forall (A B C V: Set) - (f1: A -> option B) (f2: B -> option C) - (p: program A V), - transform_partial_program f1 p @@@ - (fun p' => transform_partial_program f2 p') = - transform_partial_program (fun f => f1 f @@@ f2) p. + (f1: A -> res B) (f2: B -> C) + (pa: program A V) (pc: program C V), + transform_partial_program (fun f => f1 f @@ f2) pa = OK pc -> + exists pb, transform_partial_program f1 pa = OK pb /\ + transform_program f2 pb = pc. Proof. - unfold transform_partial_program; intros. - rewrite <- map_partial_compose. simpl. - destruct (map_partial f1 (prog_funct p)); simpl. - auto. auto. + intros. + replace (fun f : A => f1 f @@ f2) + with (fun f : A => f1 f @@@ (fun x => OK (f2 x))) in H. + exploit transform_partial_program_compose; eauto. + intros [pb [X Y]]. exists pb; split. auto. + apply transform_program_partial_program. auto. + apply extensionality; intro. destruct(f1 x); auto. Qed. -Lemma transform_program_partial_total: - forall (A B V: Set) (f: A -> B) (p: program A V), - Some (transform_program f p) = - transform_partial_program (fun x => Some (f x)) p. +Lemma transform_partial_program_identity: + forall (A V: Set) (pa pb: program A V), + transform_partial_program (@OK A) pa = OK pb -> + pa = pb. Proof. - intros. unfold transform_program, transform_partial_program. - rewrite map_partial_total. auto. + intros until pb. unfold transform_partial_program. + replace (@OK A) with (fun b => @OK A b). + rewrite map_partial_identity. simpl. destruct pa; simpl; congruence. + apply extensionality; auto. Qed. -Lemma apply_total_transf_program: - forall (A B V: Set) (f: A -> B) (x: option (program A V)), - x @@ (fun p => transform_program f p) = - x @@@ (fun p => transform_partial_program (fun x => Some (f x)) p). -Proof. - intros. unfold apply_total, apply_partial. - destruct x. apply transform_program_partial_total. auto. -Qed. +(** * Semantic preservation *) -Lemma transf_cminor_program_equiv: - forall p, transf_cminor_program2 p = transf_cminor_program p. -Proof. - intro. unfold transf_cminor_program, transf_cminor_program2, transf_cminor_fundef. - simpl. - unfold RTLgen.transl_program, - Constprop.transf_program, RTL.program. - rewrite apply_total_transf_program. - rewrite transform_partial_program_compose. - unfold CSE.transf_program, RTL.program. - rewrite apply_total_transf_program. - rewrite transform_partial_program_compose. - unfold Allocation.transf_program, - LTL.program, RTL.program. - rewrite transform_partial_program_compose. - unfold Tunneling.tunnel_program, LTL.program. - rewrite apply_total_transf_program. - rewrite transform_partial_program_compose. - unfold Linearize.transf_program, LTL.program, Linear.program. - rewrite apply_total_transf_program. - rewrite transform_partial_program_compose. - unfold Stacking.transf_program, Linear.program, Mach.program. - rewrite transform_partial_program_compose. - unfold PPCgen.transf_program, Mach.program, PPC.program. - rewrite transform_partial_program_compose. - reflexivity. -Qed. +(** We prove that the [transf_program] translations preserve semantics. + The proof composes the semantic preservation results for each pass. + This establishes the correctness of the whole compiler! *) -(* -Lemma transf_csharpminor_program_equiv: - forall p, transf_csharpminor_program2 p = transf_csharpminor_program p. +Theorem transf_rtl_program_correct: + forall p tp beh, + transf_rtl_program p = OK tp -> + RTL.exec_program p beh -> + PPC.exec_program tp beh. Proof. - intros. - unfold transf_csharpminor_program2, transf_csharpminor_program, transf_csharpminor_fundef. - simpl. - replace transf_cminor_program2 with transf_cminor_program. - unfold transf_cminor_program, Cminorgen.transl_program, Cminor.program, PPC.program. - rewrite apply_partial_transf_program. - rewrite transform_partial_program2_compose. - reflexivity. - symmetry. apply extensionality. exact transf_cminor_program_equiv. -Qed. -*) + intros. unfold transf_rtl_program, transf_rtl_fundef in H. + destruct (transform_partial_program_compose _ _ _ _ _ _ _ _ H) as [p7 [H7 P7]]. + clear H. + destruct (transform_partial_program_compose _ _ _ _ _ _ _ _ H7) as [p6 [H6 P6]]. + clear H7. + destruct (transform_partial_program_compose _ _ _ _ _ _ _ _ H6) as [p5 [H5 P5]]. + clear H6. generalize (transform_program_partial_program _ _ _ _ _ _ P5). clear P5. intro P5. + destruct (transform_partial_program_compose _ _ _ _ _ _ _ _ H5) as [p4 [H4 P4]]. + clear H5. generalize (transform_program_partial_program _ _ _ _ _ _ P4). clear P4. intro P4. + destruct (transform_partial_program_compose _ _ _ _ _ _ _ _ H4) as [p3 [H3 P3]]. + clear H4. generalize (transform_program_partial_program _ _ _ _ _ _ P3). clear P3. intro P3. + destruct (transform_partial_program_compose _ _ _ _ _ _ _ _ H3) as [p2 [H2 P2]]. + clear H3. + destruct (transform_program_compose _ _ _ _ _ _ _ _ H2) as [p1 [H1 P1]]. + clear H2. + destruct (transform_program_compose _ _ _ _ _ _ _ _ H1) as [p0 [H00 P0]]. + clear H1. + generalize (transform_partial_program_identity _ _ _ _ H00). clear H00. intro. subst p0. -(** * Semantic preservation *) + assert (WT3 : LTLtyping.wt_program p3). + apply Alloctyping.program_typing_preserved with p2. auto. + assert (WT4 : LTLtyping.wt_program p4). + subst p4. apply Tunnelingtyping.program_typing_preserved. auto. + assert (WT5 : LTLintyping.wt_program p5). + subst p5. apply Linearizetyping.program_typing_preserved. auto. + assert (WT6 : Lineartyping.wt_program p6). + subst p6. apply Reloadtyping.program_typing_preserved. auto. + assert (WT7: Machtyping.wt_program p7). + apply Stackingtyping.program_typing_preserved with p6. auto. auto. -(** We prove that the [transf_program] translations preserve semantics. The proof - composes the semantic preservation results for each pass. - This establishes the correctness of the whole compiler! *) + apply PPCgenproof.transf_program_correct with p7; auto. + apply Machabstr2concr.exec_program_equiv; auto. + apply Stackingproof.transf_program_correct with p6; auto. + subst p6; apply Reloadproof.transf_program_correct; auto. + subst p5; apply Linearizeproof.transf_program_correct; auto. + subst p4; apply Tunnelingproof.transf_program_correct. + apply Allocproof.transf_program_correct with p2; auto. + subst p2; apply CSEproof.transf_program_correct. + subst p1; apply Constpropproof.transf_program_correct. auto. +Qed. Theorem transf_cminor_program_correct: forall p tp t n, - transf_cminor_program p = Some tp -> + transf_cminor_program p = OK tp -> Cminor.exec_program p t (Vint n) -> - PPC.exec_program tp t (Vint n). + PPC.exec_program tp (Terminates t n). Proof. - intros until n. - rewrite <- transf_cminor_program_equiv. - unfold transf_cminor_program2. - simpl. caseEq (RTLgen.transl_program p). intros p1 EQ1. - simpl. set (p2 := CSE.transf_program (Constprop.transf_program p1)). - caseEq (Allocation.transf_program p2). intros p3 EQ3. - simpl. set (p4 := Tunneling.tunnel_program p3). - set (p5 := Linearize.transf_program p4). - caseEq (Stacking.transf_program p5). intros p6 EQ6. - simpl. intros EQTP EXEC. - assert (WT3 : LTLtyping.wt_program p3). - apply Alloctyping.program_typing_preserved with p2. auto. - assert (WT4 : LTLtyping.wt_program p4). - unfold p4. apply Tunnelingtyping.program_typing_preserved. auto. - assert (WT5 : Lineartyping.wt_program p5). - unfold p5. apply Linearizetyping.program_typing_preserved. auto. - assert (WT6: Machtyping.wt_program p6). - apply Stackingtyping.program_typing_preserved with p5. auto. auto. - apply PPCgenproof.transf_program_correct with p6; auto. - apply Machabstr2mach.exec_program_equiv; auto. - apply Stackingproof.transl_program_correct with p5; auto. - unfold p5; apply Linearizeproof.transf_program_correct. - unfold p4; apply Tunnelingproof.transf_program_correct. - apply Allocproof.transl_program_correct with p2; auto. - unfold p2; apply CSEproof.transf_program_correct; - apply Constpropproof.transf_program_correct. - apply RTLgenproof.transl_program_correct with p; auto. - simpl; intros; discriminate. - simpl; intros; discriminate. - simpl; intros; discriminate. + intros. unfold transf_cminor_program, transf_cminor_fundef in H. + destruct (transform_partial_program_compose _ _ _ _ _ _ _ _ H) as [p3 [H3 P3]]. + clear H. + destruct (transform_partial_program_compose _ _ _ _ _ _ _ _ H3) as [p2 [H2 P2]]. + clear H3. + destruct (transform_program_compose _ _ _ _ _ _ _ _ H2) as [p1 [H1 P1]]. + generalize (transform_partial_program_identity _ _ _ _ H1). clear H1. intro. subst p1. + apply transf_rtl_program_correct with p3. auto. + apply RTLgenproof.transl_program_correct with p2; auto. + rewrite <- P1. apply Selectionproof.sel_program_correct; auto. Qed. Theorem transf_c_program_correct: forall p tp t n, - transf_c_program p = Some tp -> + transf_c_program p = OK tp -> Csem.exec_program p t (Vint n) -> - PPC.exec_program tp t (Vint n). + PPC.exec_program tp (Terminates t n). Proof. intros until n; unfold transf_c_program; simpl. caseEq (Ctyping.typecheck_program p); try congruence; intro. diff --git a/common/Mem.v b/common/Mem.v index 679c41e1..6b66d9da 100644 --- a/common/Mem.v +++ b/common/Mem.v @@ -1,11 +1,11 @@ (** This file develops the memory model that is used in the dynamic - semantics of all the languages of the compiler back-end. + semantics of all the languages used in the compiler. It defines a type [mem] of memory states, the following 4 basic operations over memory states, and their properties: -- [alloc]: allocate a fresh memory block; -- [free]: invalidate a memory block; - [load]: read a memory chunk at a given address; -- [store]: store a memory chunk at a given address. +- [store]: store a memory chunk at a given address; +- [alloc]: allocate a fresh memory block; +- [free]: invalidate a memory block. *) Require Import Coqlib. @@ -15,12 +15,6 @@ Require Import Integers. Require Import Floats. Require Import Values. -(** * Structure of memory states *) - -(** A memory state is organized in several disjoint blocks. Each block - has a low and a high bound that defines its size. Each block map - byte offsets to the contents of this byte. *) - Definition update (A: Set) (x: Z) (v: A) (f: Z -> A) : Z -> A := fun y => if zeq y x then v else f y. @@ -40,32 +34,32 @@ Proof. intros; unfold update. apply zeq_false; auto. Qed. +(** * Structure of memory states *) + +(** A memory state is organized in several disjoint blocks. Each block + has a low and a high bound that defines its size. Each block map + byte offsets to the contents of this byte. *) + (** The possible contents of a byte-sized memory cell. To give intuitions, a 4-byte value [v] stored at offset [d] will be represented by - the content [Datum32 v] at offset [d] and [Cont] at offsets [d+1], + the content [Datum(4, v)] at offset [d] and [Cont] at offsets [d+1], [d+2] and [d+3]. The [Cont] contents enable detecting future writes - that would overlap partially the 4-byte value. *) + that would partially overlap the 4-byte value. *) Inductive content : Set := - | Undef: content (**r undefined contents *) - | Datum8: val -> content (**r a value that fits in 1 byte *) - | Datum16: val -> content (**r first byte of a 2-byte value *) - | Datum32: val -> content (**r first byte of a 4-byte value *) - | Datum64: val -> content (**r first byte of a 8-byte value *) - | Cont: content. (**r continuation bytes for a multi-byte value *) + | Undef: content (**r undefined contents *) + | Datum: nat -> val -> content (**r first byte of a value *) + | Cont: content. (**r continuation bytes for a multi-byte value *) Definition contentmap : Set := Z -> content. (** A memory block comprises the dimensions of the block (low and high bounds) - plus a mapping from byte offsets to contents. For technical reasons, - we also carry around a proof that the mapping is equal to [Undef] - outside the range of allowed byte offsets. *) + plus a mapping from byte offsets to contents. *) Record block_contents : Set := mkblock { low: Z; high: Z; - contents: contentmap; - undef_outside: forall ofs, ofs < low \/ ofs >= high -> contents ofs = Undef + contents: contentmap }. (** A memory state is a mapping from block addresses (represented by [Z] @@ -82,49 +76,43 @@ Record mem : Set := mkmem { (** Memory reads and writes are performed by quantities called memory chunks, encoding the type, size and signedness of the chunk being addressed. - It is useful to extract only the size information as given by the - following [memory_size] type. *) - -Inductive memory_size : Set := - | Size8: memory_size - | Size16: memory_size - | Size32: memory_size - | Size64: memory_size. - -Definition size_mem (sz: memory_size) := - match sz with - | Size8 => 1 - | Size16 => 2 - | Size32 => 4 - | Size64 => 8 + The following functions extract the size information from a chunk. *) + +Definition size_chunk (chunk: memory_chunk) : Z := + match chunk with + | Mint8signed => 1 + | Mint8unsigned => 1 + | Mint16signed => 2 + | Mint16unsigned => 2 + | Mint32 => 4 + | Mfloat32 => 4 + | Mfloat64 => 8 end. -Definition mem_chunk (chunk: memory_chunk) := +Definition pred_size_chunk (chunk: memory_chunk) : nat := match chunk with - | Mint8signed => Size8 - | Mint8unsigned => Size8 - | Mint16signed => Size16 - | Mint16unsigned => Size16 - | Mint32 => Size32 - | Mfloat32 => Size32 - | Mfloat64 => Size64 + | Mint8signed => 0%nat + | Mint8unsigned => 0%nat + | Mint16signed => 1%nat + | Mint16unsigned => 1%nat + | Mint32 => 3%nat + | Mfloat32 => 3%nat + | Mfloat64 => 7%nat end. -Definition size_chunk (chunk: memory_chunk) := size_mem (mem_chunk chunk). +Lemma size_chunk_pred: + forall chunk, size_chunk chunk = 1 + Z_of_nat (pred_size_chunk chunk). +Proof. + destruct chunk; auto. +Qed. (** The initial store. *) Remark one_pos: 1 > 0. Proof. omega. Qed. -Remark undef_undef_outside: - forall lo hi ofs, ofs < lo \/ ofs >= hi -> (fun y => Undef) ofs = Undef. -Proof. - auto. -Qed. - Definition empty_block (lo hi: Z) : block_contents := - mkblock lo hi (fun y => Undef) (undef_undef_outside lo hi). + mkblock lo hi (fun y => Undef). Definition empty: mem := mkmem (fun x => empty_block 0 0) 1 one_pos. @@ -200,8 +188,16 @@ Fixpoint check_cont (n: nat) (p: Z) (m: contentmap) {struct n} : bool := end end. -Definition getN (n: nat) (p: Z) (m: contentmap) : content := - if check_cont n (p + 1) m then m p else Undef. +Definition eq_nat: forall (p q: nat), {p=q} + {p<>q}. +Proof. decide equality. Defined. + +Definition getN (n: nat) (p: Z) (m: contentmap) : val := + match m p with + | Datum n' v => + if eq_nat n n' && check_cont n (p + 1) m then v else Vundef + | _ => + Vundef + end. Fixpoint set_cont (n: nat) (p: Z) (m: contentmap) {struct n} : contentmap := match n with @@ -209,54 +205,47 @@ Fixpoint set_cont (n: nat) (p: Z) (m: contentmap) {struct n} : contentmap := | S n1 => update p Cont (set_cont n1 (p + 1) m) end. -Definition setN (n: nat) (p: Z) (v: content) (m: contentmap) : contentmap := - update p v (set_cont n (p + 1) m). +Definition setN (n: nat) (p: Z) (v: val) (m: contentmap) : contentmap := + update p (Datum n v) (set_cont n (p + 1) m). -Lemma check_cont_true: - forall n p m, - (forall q, p <= q < p + Z_of_nat n -> m q = Cont) -> - check_cont n p m = true. +Lemma check_cont_spec: + forall n m p, + if check_cont n p m + then (forall q, p <= q < p + Z_of_nat n -> m q = Cont) + else (exists q, p <= q < p + Z_of_nat n /\ m q <> Cont). Proof. induction n; intros. - reflexivity. - simpl. rewrite H. apply IHn. - intros. apply H. rewrite inj_S. omega. - rewrite inj_S. omega. + simpl. intros; omegaContradiction. + simpl check_cont. repeat rewrite inj_S. caseEq (m p); intros. + exists p; split. omega. congruence. + exists p; split. omega. congruence. + generalize (IHn m (p + 1)). case (check_cont n (p + 1) m). + intros. assert (p = q \/ p + 1 <= q < p + Zsucc (Z_of_nat n)) by omega. + elim H2; intro. congruence. apply H0; omega. + intros [q [A B]]. exists q; split. omega. auto. Qed. -Hint Resolve check_cont_true. - -Lemma check_cont_inv: - forall n p m, - check_cont n p m = true -> - (forall q, p <= q < p + Z_of_nat n -> m q = Cont). +Lemma check_cont_true: + forall n m p, + (forall q, p <= q < p + Z_of_nat n -> m q = Cont) -> + check_cont n p m = true. Proof. - induction n; intros until m. - unfold Z_of_nat. intros. omegaContradiction. - unfold check_cont; fold check_cont. - caseEq (m p); intros; try discriminate. - assert (p = q \/ p + 1 <= q < (p + 1) + Z_of_nat n). - rewrite inj_S in H1. omega. - elim H2; intro. - subst q. auto. - apply IHn with (p + 1); auto. + intros. generalize (check_cont_spec n m p). + destruct (check_cont n p m). auto. + intros [q [A B]]. elim B; auto. Qed. -Hint Resolve check_cont_inv. - Lemma check_cont_false: - forall n p q m, - p <= q < p + Z_of_nat n -> - m q <> Cont -> + forall n m p q, + p <= q < p + Z_of_nat n -> m q <> Cont -> check_cont n p m = false. Proof. - intros. caseEq (check_cont n p m); intro. - generalize (check_cont_inv _ _ _ H1 q H). intro. contradiction. + intros. generalize (check_cont_spec n m p). + destruct (check_cont n p m). + intros. elim H0; auto. auto. Qed. -Hint Resolve check_cont_false. - Lemma set_cont_inside: forall n p m q, p <= q < p + Z_of_nat n -> @@ -273,8 +262,6 @@ Proof. red; intro; subst q. omega. Qed. -Hint Resolve set_cont_inside. - Lemma set_cont_outside: forall n p m q, q < p \/ p + Z_of_nat n <= q -> @@ -286,160 +273,133 @@ Proof. rewrite update_o. apply IHn. omega. omega. Qed. -Hint Resolve set_cont_outside. - Lemma getN_setN_same: forall n p v m, getN n p (setN n p v m) = v. Proof. - intros. unfold getN, setN. - rewrite check_cont_true. apply update_s. + intros. unfold getN, setN. rewrite update_s. + rewrite check_cont_true. unfold proj_sumbool. + rewrite dec_eq_true. auto. intros. rewrite update_o. apply set_cont_inside. auto. omega. Qed. -Hint Resolve getN_setN_same. - Lemma getN_setN_other: forall n1 n2 p1 p2 v m, p1 + Z_of_nat n1 < p2 \/ p2 + Z_of_nat n2 < p1 -> getN n2 p2 (setN n1 p1 v m) = getN n2 p2 m. Proof. intros. unfold getN, setN. - caseEq (check_cont n2 (p2 + 1) m); intro. - rewrite check_cont_true. rewrite update_o. - apply set_cont_outside. omega. omega. - intros. rewrite update_o. rewrite set_cont_outside. - eapply check_cont_inv. eauto. auto. + generalize (check_cont_spec n2 m (p2 + 1)); + destruct (check_cont n2 (p2 + 1) m); intros. + rewrite check_cont_true. + rewrite update_o. rewrite set_cont_outside. auto. omega. omega. - caseEq (check_cont n2 (p2 + 1) (update p1 v (set_cont n1 (p1 + 1) m))); intros. - assert (check_cont n2 (p2 + 1) m = true). - apply check_cont_true. intros. - generalize (check_cont_inv _ _ _ H1 q H2). - rewrite update_o. rewrite set_cont_outside. auto. omega. omega. - rewrite H0 in H2; discriminate. - auto. -Qed. - -Hint Resolve getN_setN_other. + intros. rewrite update_o. rewrite set_cont_outside. auto. + omega. omega. + destruct H0 as [q [A B]]. + rewrite (check_cont_false n2 (update p1 (Datum n1 v) (set_cont n1 (p1 + 1) m)) (p2 + 1) q). + rewrite update_o. rewrite set_cont_outside. auto. + omega. omega. omega. + rewrite update_o. rewrite set_cont_outside. auto. + omega. omega. +Qed. Lemma getN_setN_overlap: forall n1 n2 p1 p2 v m, p1 <> p2 -> p1 + Z_of_nat n1 >= p2 -> p2 + Z_of_nat n2 >= p1 -> - v <> Cont -> - getN n2 p2 (setN n1 p1 v m) = Cont \/ - getN n2 p2 (setN n1 p1 v m) = Undef. -Proof. - intros. unfold getN. - caseEq (check_cont n2 (p2 + 1) (setN n1 p1 v m)); intro. - case (zlt p2 p1); intro. - assert (p2 + 1 <= p1 < p2 + 1 + Z_of_nat n2). omega. - generalize (check_cont_inv _ _ _ H3 p1 H4). - unfold setN. rewrite update_s. intro. contradiction. - left. unfold setN. rewrite update_o. - apply set_cont_inside. omega. auto. - right; auto. -Qed. - -Hint Resolve getN_setN_overlap. + getN n2 p2 (setN n1 p1 v m) = Vundef. +Proof. + intros. unfold getN, setN. + rewrite update_o; auto. + destruct (zlt p2 p1). + (* [p1] belongs to [[p2, p2 + n2 - 1]], + therefore [check_cont n2 (p2 + 1) ...] is false. *) + rewrite (check_cont_false n2 (update p1 (Datum n1 v) (set_cont n1 (p1 + 1) m)) (p2 + 1) p1). + destruct (set_cont n1 (p1 + 1) m p2); auto. + destruct (eq_nat n2 n); auto. + omega. + rewrite update_s. congruence. + (* [p2] belongs to [[p1 + 1, p1 + n1 - 1]], + therefore [set_cont n1 (p1 + 1) m p2] is [Cont]. *) + rewrite set_cont_inside. auto. omega. +Qed. Lemma getN_setN_mismatch: forall n1 n2 p v m, - getN n2 p (setN n1 p v m) = v \/ getN n2 p (setN n1 p v m) = Undef. + n1 <> n2 -> + getN n2 p (setN n1 p v m) = Vundef. Proof. - intros. unfold getN. - caseEq (check_cont n2 (p + 1) (setN n1 p v m)); intro. - left. unfold setN. apply update_s. - right. auto. + intros. unfold getN, setN. rewrite update_s. + unfold proj_sumbool; rewrite dec_eq_false; simpl. auto. auto. Qed. -Hint Resolve getN_setN_mismatch. +Lemma getN_setN_characterization: + forall m v n1 p1 n2 p2, + getN n2 p2 (setN n1 p1 v m) = v + \/ getN n2 p2 (setN n1 p1 v m) = getN n2 p2 m + \/ getN n2 p2 (setN n1 p1 v m) = Vundef. +Proof. + intros. destruct (zeq p1 p2). subst p2. + destruct (eq_nat n1 n2). subst n2. + left; apply getN_setN_same. + right; right; apply getN_setN_mismatch; auto. + destruct (zlt (p1 + Z_of_nat n1) p2). + right; left; apply getN_setN_other; auto. + destruct (zlt (p2 + Z_of_nat n2) p1). + right; left; apply getN_setN_other; auto. + right; right; apply getN_setN_overlap; omega. +Qed. Lemma getN_init: forall n p, - getN n p (fun y => Undef) = Undef. + getN n p (fun y => Undef) = Vundef. Proof. - intros. unfold getN. - case (check_cont n (p + 1) (fun y => Undef)); auto. + intros. auto. Qed. -Hint Resolve getN_init. +(** [valid_access m chunk b ofs] holds if a memory access (load or store) + of the given chunk is possible in [m] at address [b, ofs]. *) + +Inductive valid_access (m: mem) (chunk: memory_chunk) (b: block) (ofs: Z) : Prop := + | valid_access_intro: + valid_block m b -> + low_bound m b <= ofs -> + ofs + size_chunk chunk <= high_bound m b -> + valid_access m chunk b ofs. (** The following function checks whether accessing the given memory chunk at the given offset in the given block respects the bounds of the block. *) -Definition in_bounds (chunk: memory_chunk) (ofs: Z) (c: block_contents) : - {c.(low) <= ofs /\ ofs + size_chunk chunk <= c.(high)} - + {c.(low) > ofs \/ ofs + size_chunk chunk > c.(high)} := - match zle c.(low) ofs, zle (ofs + size_chunk chunk) c.(high) with - | left P1, left P2 => left _ (conj P1 P2) - | left P1, right P2 => right _ (or_intror _ P2) - | right P1, _ => right _ (or_introl _ P1) - end. - -Lemma in_bounds_holds: - forall (chunk: memory_chunk) (ofs: Z) (c: block_contents) - (A: Set) (a b: A), - c.(low) <= ofs -> ofs + size_chunk chunk <= c.(high) -> - (if in_bounds chunk ofs c then a else b) = a. +Definition in_bounds (m: mem) (chunk: memory_chunk) (b: block) (ofs: Z) : + {valid_access m chunk b ofs} + {~valid_access m chunk b ofs}. Proof. - intros. case (in_bounds chunk ofs c); intro. - auto. - omegaContradiction. -Qed. + intros. + destruct (zlt b m.(nextblock)). + destruct (zle (low_bound m b) ofs). + destruct (zle (ofs + size_chunk chunk) (high_bound m b)). + left; constructor; auto. + right; red; intro V; inv V; omega. + right; red; intro V; inv V; omega. + right; red; intro V; inv V; contradiction. +Defined. -Lemma in_bounds_exten: - forall (chunk: memory_chunk) (ofs: Z) (c: block_contents) (x: contentmap) P, - in_bounds chunk ofs (mkblock (low c) (high c) x P) = - in_bounds chunk ofs c. +Lemma in_bounds_true: + forall m chunk b ofs (A: Set) (a1 a2: A), + valid_access m chunk b ofs -> + (if in_bounds m chunk b ofs then a1 else a2) = a1. Proof. - intros; reflexivity. + intros. destruct (in_bounds m chunk b ofs). auto. contradiction. Qed. -Hint Resolve in_bounds_holds in_bounds_exten. - (** [valid_pointer] holds if the given block address is valid and the given offset falls within the bounds of the corresponding block. *) Definition valid_pointer (m: mem) (b: block) (ofs: Z) : bool := - if zlt b m.(nextblock) then - (let c := m.(blocks) b in - if zle c.(low) ofs then if zlt ofs c.(high) then true else false - else false) - else false. - -(** Read a quantity of size [sz] at offset [ofs] in block contents [c]. - Return [Vundef] if the requested size does not match that of the - current contents, or if the following offsets do not contain [Cont]. - The first check captures a size mismatch between the read and the - latest write at this offset. The second check captures partial overwriting - of the latest write at this offset by a more recent write at a nearby - offset. *) - -Definition load_contents (sz: memory_size) (c: contentmap) (ofs: Z) : val := - match sz with - | Size8 => - match getN 0%nat ofs c with - | Datum8 n => n - | _ => Vundef - end - | Size16 => - match getN 1%nat ofs c with - | Datum16 n => n - | _ => Vundef - end - | Size32 => - match getN 3%nat ofs c with - | Datum32 n => n - | _ => Vundef - end - | Size64 => - match getN 7%nat ofs c with - | Datum64 n => n - | _ => Vundef - end - end. + zlt b m.(nextblock) && + zle (low_bound m b) ofs && + zlt ofs (high_bound m b). (** [load chunk m b ofs] perform a read in memory state [m], at address [b] and offset [ofs]. [None] is returned if the address is invalid @@ -447,15 +407,25 @@ Definition load_contents (sz: memory_size) (c: contentmap) (ofs: Z) : val := Definition load (chunk: memory_chunk) (m: mem) (b: block) (ofs: Z) : option val := - if zlt b m.(nextblock) then - (let c := m.(blocks) b in - if in_bounds chunk ofs c - then Some (Val.load_result chunk - (load_contents (mem_chunk chunk) c.(contents) ofs)) - else None) + if in_bounds m chunk b ofs then + Some (Val.load_result chunk + (getN (pred_size_chunk chunk) ofs (contents (blocks m b)))) else None. +Lemma load_inv: + forall chunk m b ofs v, + load chunk m b ofs = Some v -> + valid_access m chunk b ofs /\ + v = Val.load_result chunk + (getN (pred_size_chunk chunk) ofs (contents (blocks m b))). +Proof. + intros until v; unfold load. + destruct (in_bounds m chunk b ofs); intros. + split. auto. congruence. + congruence. +Qed. + (** [loadv chunk m addr] is similar, but the address and offset are given as a single value [addr], which must be a pointer value. *) @@ -465,90 +435,17 @@ Definition loadv (chunk: memory_chunk) (m: mem) (addr: val) : option val := | _ => None end. -Theorem load_in_bounds: - forall (chunk: memory_chunk) (m: mem) (b: block) (ofs: Z), - valid_block m b -> - low_bound m b <= ofs -> - ofs + size_chunk chunk <= high_bound m b -> - exists v, load chunk m b ofs = Some v. -Proof. - intros. unfold load. rewrite zlt_true; auto. - rewrite in_bounds_holds. - exists (Val.load_result chunk - (load_contents (mem_chunk chunk) - (contents (m.(blocks) b)) - ofs)). - auto. - exact H0. exact H1. -Qed. - -Lemma load_inv: - forall (chunk: memory_chunk) (m: mem) (b: block) (ofs: Z) (v: val), - load chunk m b ofs = Some v -> - let c := m.(blocks) b in - b < m.(nextblock) /\ - c.(low) <= ofs /\ - ofs + size_chunk chunk <= c.(high) /\ - Val.load_result chunk (load_contents (mem_chunk chunk) c.(contents) ofs) = v. -Proof. - intros until v; unfold load. - case (zlt b (nextblock m)); intro. - set (c := m.(blocks) b). - case (in_bounds chunk ofs c). - intuition congruence. - intros; discriminate. - intros; discriminate. -Qed. -Hint Resolve load_in_bounds load_inv. - -(* Write the value [v] with size [sz] at offset [ofs] in block contents [c]. - Return updated block contents. [Cont] contents are stored at the following - offsets. *) - -Definition store_contents (sz: memory_size) (c: contentmap) - (ofs: Z) (v: val) : contentmap := - match sz with - | Size8 => - setN 0%nat ofs (Datum8 v) c - | Size16 => - setN 1%nat ofs (Datum16 v) c - | Size32 => - setN 3%nat ofs (Datum32 v) c - | Size64 => - setN 7%nat ofs (Datum64 v) c - end. - -Remark store_contents_undef_outside: - forall sz c ofs v lo hi, - lo <= ofs /\ ofs + size_mem sz <= hi -> - (forall x, x < lo \/ x >= hi -> c x = Undef) -> - (forall x, x < lo \/ x >= hi -> - store_contents sz c ofs v x = Undef). -Proof. - intros until hi; intros [LO HI] UO. - assert (forall n d x, - ofs + (1 + Z_of_nat n) <= hi -> - x < lo \/ x >= hi -> - setN n ofs d c x = Undef). - intros. unfold setN. rewrite update_o. - transitivity (c x). apply set_cont_outside. omega. - apply UO. omega. omega. - unfold store_contents; destruct sz; unfold size_mem in HI; - intros; apply H; auto; simpl Z_of_nat; auto. -Qed. +(* The memory state [m] after a store of value [v] at offset [ofs] + in block [b]. *) Definition unchecked_store (chunk: memory_chunk) (m: mem) (b: block) - (ofs: Z) (v: val) - (P: (m.(blocks) b).(low) <= ofs /\ - ofs + size_chunk chunk <= (m.(blocks) b).(high)) : mem := + (ofs: Z) (v: val) : mem := let c := m.(blocks) b in mkmem (update b (mkblock c.(low) c.(high) - (store_contents (mem_chunk chunk) c.(contents) ofs v) - (store_contents_undef_outside (mem_chunk chunk) c.(contents) - ofs v _ _ P c.(undef_outside))) + (setN (pred_size_chunk chunk) ofs v c.(contents))) m.(blocks)) m.(nextblock) m.(nextblock_pos). @@ -560,13 +457,21 @@ Definition unchecked_store Definition store (chunk: memory_chunk) (m: mem) (b: block) (ofs: Z) (v: val) : option mem := - if zlt b m.(nextblock) then - match in_bounds chunk ofs (m.(blocks) b) with - | left P => Some(unchecked_store chunk m b ofs v P) - | right _ => None - end - else - None. + if in_bounds m chunk b ofs + then Some(unchecked_store chunk m b ofs v) + else None. + +Lemma store_inv: + forall chunk m b ofs v m', + store chunk m b ofs v = Some m' -> + valid_access m chunk b ofs /\ + m' = unchecked_store chunk m b ofs v. +Proof. + intros until m'; unfold store. + destruct (in_bounds m chunk b ofs); intros. + split. auto. congruence. + congruence. +Qed. (** [storev chunk m addr v] is similar, but the address and offset are given as a single value [addr], which must be a pointer value. *) @@ -577,63 +482,21 @@ Definition storev (chunk: memory_chunk) (m: mem) (addr v: val) : option mem := | _ => None end. -Theorem store_in_bounds: - forall (chunk: memory_chunk) (m: mem) (b: block) (ofs: Z) (v: val), - valid_block m b -> - low_bound m b <= ofs -> - ofs + size_chunk chunk <= high_bound m b -> - exists m', store chunk m b ofs v = Some m'. -Proof. - intros. unfold store. - rewrite zlt_true; auto. - case (in_bounds chunk ofs (blocks m b)); intro P. - exists (unchecked_store chunk m b ofs v P). reflexivity. - unfold low_bound in H0. unfold high_bound in H1. omegaContradiction. -Qed. - -Lemma store_inv: - forall (chunk: memory_chunk) (m m': mem) (b: block) (ofs: Z) (v: val), - store chunk m b ofs v = Some m' -> - let c := m.(blocks) b in - b < m.(nextblock) /\ - c.(low) <= ofs /\ - ofs + size_chunk chunk <= c.(high) /\ - m'.(nextblock) = m.(nextblock) /\ - exists P, m'.(blocks) = - update b (mkblock c.(low) c.(high) - (store_contents (mem_chunk chunk) c.(contents) ofs v) P) - m.(blocks). -Proof. - intros until v; unfold store. - case (zlt b (nextblock m)); intro. - set (c := m.(blocks) b). - case (in_bounds chunk ofs c). - intros; injection H; intro; subst m'. simpl. - intuition. fold c. - exists (store_contents_undef_outside (mem_chunk chunk) - (contents c) ofs v (low c) (high c) a (undef_outside c)). - auto. - intros; discriminate. - intros; discriminate. -Qed. - -Hint Resolve store_in_bounds store_inv. - (** Build a block filled with the given initialization data. *) Fixpoint contents_init_data (pos: Z) (id: list init_data) {struct id}: contentmap := match id with | nil => (fun y => Undef) | Init_int8 n :: id' => - store_contents Size8 (contents_init_data (pos + 1) id') pos (Vint n) + setN 0%nat pos (Vint n) (contents_init_data (pos + 1) id') | Init_int16 n :: id' => - store_contents Size16 (contents_init_data (pos + 2) id') pos (Vint n) + setN 1%nat pos (Vint n) (contents_init_data (pos + 1) id') | Init_int32 n :: id' => - store_contents Size32 (contents_init_data (pos + 4) id') pos (Vint n) + setN 3%nat pos (Vint n) (contents_init_data (pos + 1) id') | Init_float32 f :: id' => - store_contents Size32 (contents_init_data (pos + 4) id') pos (Vfloat f) + setN 3%nat pos (Vfloat f) (contents_init_data (pos + 1) id') | Init_float64 f :: id' => - store_contents Size64 (contents_init_data (pos + 8) id') pos (Vfloat f) + setN 7%nat pos (Vfloat f) (contents_init_data (pos + 1) id') | Init_space n :: id' => contents_init_data (pos + Zmax n 0) id' | Init_pointer x :: id' => @@ -664,32 +527,8 @@ Proof. generalize (Zmax2 z 0). omega. omega. Qed. -Remark contents_init_data_undef_outside: - forall id pos x, - x < pos \/ x >= pos + size_init_data_list id -> - contents_init_data pos id x = Undef. -Proof. - induction id; simpl; intros. - auto. - generalize (size_init_data_list_pos id); intro. - assert (forall n delta dt, - delta = 1 + Z_of_nat n -> - x < pos \/ x >= pos + (delta + size_init_data_list id) -> - setN n pos dt (contents_init_data (pos + delta) id) x = Undef). - intros. unfold setN. rewrite update_o. - transitivity (contents_init_data (pos + delta) id x). - apply set_cont_outside. omega. - apply IHid. omega. omega. - unfold size_init_data in H; destruct a; - try (apply H1; [reflexivity|assumption]). - apply IHid. generalize (Zmax2 z 0). omega. - apply IHid. omega. -Qed. - Definition block_init_data (id: list init_data) : block_contents := - mkblock 0 (size_init_data_list id) - (contents_init_data 0 id) - (contents_init_data_undef_outside id 0). + mkblock 0 (size_init_data_list id) (contents_init_data 0 id). Definition alloc_init_data (m: mem) (id: list init_data) : mem * block := (mkmem (update m.(nextblock) @@ -702,8 +541,7 @@ Definition alloc_init_data (m: mem) (id: list init_data) : mem * block := Remark block_init_data_empty: block_init_data nil = empty_block 0 0. Proof. - unfold block_init_data, empty_block. simpl. - decEq. apply proof_irrelevance. + auto. Qed. (** * Properties of the memory operations *) @@ -716,573 +554,961 @@ Proof. intros; red; intros. subst b'. contradiction. Qed. -Theorem fresh_block_alloc: - forall (m1 m2: mem) (lo hi: Z) (b: block), - alloc m1 lo hi = (m2, b) -> ~(valid_block m1 b). +Lemma valid_access_valid_block: + forall m chunk b ofs, + valid_access m chunk b ofs -> valid_block m b. Proof. - intros. injection H; intros; subst b. - unfold valid_block. omega. + intros. inv H; auto. Qed. -Theorem valid_new_block: - forall (m1 m2: mem) (lo hi: Z) (b: block), - alloc m1 lo hi = (m2, b) -> valid_block m2 b. +Hint Resolve valid_not_valid_diff valid_access_valid_block: mem. + +(** ** Properties related to [load] *) + +Theorem valid_access_load: + forall m chunk b ofs, + valid_access m chunk b ofs -> + exists v, load chunk m b ofs = Some v. Proof. - unfold alloc, valid_block; intros. - injection H; intros. subst b; subst m2; simpl. omega. + intros. econstructor. unfold load. rewrite in_bounds_true; auto. Qed. -Theorem valid_block_alloc: - forall (m1 m2: mem) (lo hi: Z) (b b': block), - alloc m1 lo hi = (m2, b') -> - valid_block m1 b -> valid_block m2 b. +Theorem load_valid_access: + forall m chunk b ofs v, + load chunk m b ofs = Some v -> + valid_access m chunk b ofs. Proof. - unfold alloc, valid_block; intros. - injection H; intros. subst m2; simpl. omega. + intros. generalize (load_inv _ _ _ _ _ H). tauto. Qed. -Theorem valid_block_store: - forall (chunk: memory_chunk) (m1 m2: mem) (b b': block) (ofs: Z) (v: val), - store chunk m1 b' ofs v = Some m2 -> - valid_block m1 b -> valid_block m2 b. +Hint Resolve load_valid_access valid_access_load. + +(** ** Properties related to [store] *) + +Lemma valid_access_store: + forall m1 chunk b ofs v, + valid_access m1 chunk b ofs -> + exists m2, store chunk m1 b ofs v = Some m2. Proof. - intros. generalize (store_inv _ _ _ _ _ _ H). - intros [A [B [C [D [P E]]]]]. - red. rewrite D. exact H0. + intros. econstructor. unfold store. rewrite in_bounds_true; auto. Qed. -Theorem valid_block_free: - forall (m: mem) (b b': block), - valid_block m b -> valid_block (free m b') b. +Hint Resolve valid_access_store: mem. + +Section STORE. +Variable chunk: memory_chunk. +Variable m1: mem. +Variable b: block. +Variable ofs: Z. +Variable v: val. +Variable m2: mem. +Hypothesis STORE: store chunk m1 b ofs v = Some m2. + +Lemma low_bound_store: + forall b', low_bound m2 b' = low_bound m1 b'. Proof. - unfold valid_block, free; intros. - simpl. auto. + intro. elim (store_inv _ _ _ _ _ _ STORE); intros. + subst m2. unfold low_bound, unchecked_store; simpl. + unfold update. destruct (zeq b' b); auto. subst b'; auto. +Qed. + +Lemma high_bound_store: + forall b', high_bound m2 b' = high_bound m1 b'. +Proof. + intro. elim (store_inv _ _ _ _ _ _ STORE); intros. + subst m2. unfold high_bound, unchecked_store; simpl. + unfold update. destruct (zeq b' b); auto. subst b'; auto. Qed. -(** ** Properties related to [alloc] *) +Lemma nextblock_store: + nextblock m2 = nextblock m1. +Proof. + intros. elim (store_inv _ _ _ _ _ _ STORE); intros. + subst m2; reflexivity. +Qed. -Theorem load_alloc_other: - forall (chunk: memory_chunk) (m1 m2: mem) - (b b': block) (ofs lo hi: Z) (v: val), - alloc m1 lo hi = (m2, b') -> - load chunk m1 b ofs = Some v -> - load chunk m2 b ofs = Some v. +Lemma store_valid_block_1: + forall b', valid_block m1 b' -> valid_block m2 b'. Proof. - unfold alloc; intros. - injection H; intros; subst m2; clear H. - generalize (load_inv _ _ _ _ _ H0). - intros (A, (B, (C, D))). - unfold load; simpl. - rewrite zlt_true. - repeat (rewrite update_o). - rewrite in_bounds_holds. congruence. auto. auto. - omega. omega. + unfold valid_block; intros. rewrite nextblock_store; auto. Qed. -Lemma load_contents_init: - forall (sz: memory_size) (ofs: Z), - load_contents sz (fun y => Undef) ofs = Vundef. +Lemma store_valid_block_2: + forall b', valid_block m2 b' -> valid_block m1 b'. Proof. - intros. destruct sz; reflexivity. + unfold valid_block; intros. rewrite nextblock_store in H; auto. Qed. -Theorem load_alloc_same: - forall (chunk: memory_chunk) (m1 m2: mem) - (b b': block) (ofs lo hi: Z) (v: val), - alloc m1 lo hi = (m2, b') -> - load chunk m2 b' ofs = Some v -> - v = Vundef. +Hint Resolve store_valid_block_1 store_valid_block_2: mem. + +Lemma store_valid_access_1: + forall chunk' b' ofs', + valid_access m1 chunk' b' ofs' -> valid_access m2 chunk' b' ofs'. Proof. - unfold alloc; intros. - injection H; intros; subst m2; clear H. - generalize (load_inv _ _ _ _ _ H0). - simpl. rewrite H1. rewrite update_s. simpl. intros (A, (B, (C, D))). - rewrite <- D. rewrite load_contents_init. - destruct chunk; reflexivity. -Qed. + intros. inv H. constructor. auto with mem. + rewrite low_bound_store; auto. + rewrite high_bound_store; auto. +Qed. -Theorem low_bound_alloc: - forall (m1 m2: mem) (b b': block) (lo hi: Z), - alloc m1 lo hi = (m2, b') -> - low_bound m2 b = if zeq b b' then lo else low_bound m1 b. +Lemma store_valid_access_2: + forall chunk' b' ofs', + valid_access m2 chunk' b' ofs' -> valid_access m1 chunk' b' ofs'. Proof. - unfold alloc; intros. - injection H; intros; subst m2; clear H. - unfold low_bound; simpl. - unfold update. - subst b'. - case (zeq b (nextblock m1)); reflexivity. + intros. inv H. constructor. auto with mem. + rewrite low_bound_store in H1; auto. + rewrite high_bound_store in H2; auto. Qed. -Theorem high_bound_alloc: - forall (m1 m2: mem) (b b': block) (lo hi: Z), - alloc m1 lo hi = (m2, b') -> - high_bound m2 b = if zeq b b' then hi else high_bound m1 b. +Lemma store_valid_access_3: + valid_access m1 chunk b ofs. Proof. - unfold alloc; intros. - injection H; intros; subst m2; clear H. - unfold high_bound; simpl. - unfold update. - subst b'. - case (zeq b (nextblock m1)); reflexivity. + elim (store_inv _ _ _ _ _ _ STORE); intros. auto. Qed. -Theorem store_alloc: - forall (chunk: memory_chunk) (m1 m2: mem) (b: block) (ofs lo hi: Z) (v: val), - alloc m1 lo hi = (m2, b) -> - lo <= ofs -> ofs + size_chunk chunk <= hi -> - exists m2', store chunk m2 b ofs v = Some m2'. +Hint Resolve store_valid_access_1 store_valid_access_2 + store_valid_access_3: mem. + +Theorem load_store_similar: + forall chunk', + size_chunk chunk' = size_chunk chunk -> + load chunk' m2 b ofs = Some (Val.load_result chunk' v). Proof. - unfold alloc; intros. - injection H; intros. - assert (A: b < m2.(nextblock)). - subst m2; subst b; simpl; omega. - assert (B: low_bound m2 b <= ofs). - subst m2; subst b. unfold low_bound; simpl. rewrite update_s. - simpl. assumption. - assert (C: ofs + size_chunk chunk <= high_bound m2 b). - subst m2; subst b. unfold high_bound; simpl. rewrite update_s. - simpl. assumption. - exact (store_in_bounds chunk m2 b ofs v A B C). + intros. destruct (store_inv _ _ _ _ _ _ STORE). + unfold load. rewrite in_bounds_true. + decEq. decEq. rewrite H1. unfold unchecked_store; simpl. + rewrite update_s. simpl. + replace (pred_size_chunk chunk) with (pred_size_chunk chunk'). + apply getN_setN_same. + repeat rewrite size_chunk_pred in H. omega. + apply store_valid_access_1. + inv H0. constructor; auto. congruence. Qed. -Hint Resolve store_alloc high_bound_alloc low_bound_alloc load_alloc_same -load_contents_init load_alloc_other. +Theorem load_store_same: + load chunk m2 b ofs = Some (Val.load_result chunk v). +Proof. + eapply load_store_similar; eauto. +Qed. + +Theorem load_store_other: + forall chunk' b' ofs', + b' <> b + \/ ofs' + size_chunk chunk' <= ofs + \/ ofs + size_chunk chunk <= ofs' -> + load chunk' m2 b' ofs' = load chunk' m1 b' ofs'. +Proof. + intros. destruct (store_inv _ _ _ _ _ _ STORE). + unfold load. destruct (in_bounds m1 chunk' b' ofs'). + rewrite in_bounds_true. decEq. decEq. + rewrite H1; unfold unchecked_store; simpl. + unfold update. destruct (zeq b' b). subst b'. + simpl. repeat rewrite size_chunk_pred in H. + apply getN_setN_other. elim H; intro. congruence. omega. + auto. + eauto with mem. + destruct (in_bounds m2 chunk' b' ofs'); auto. + elim n. eauto with mem. +Qed. + +Theorem load_store_overlap: + forall chunk' ofs' v', + load chunk' m2 b ofs' = Some v' -> + ofs' <> ofs -> + ofs' + size_chunk chunk' > ofs -> + ofs + size_chunk chunk > ofs' -> + v' = Vundef. +Proof. + intros. destruct (store_inv _ _ _ _ _ _ STORE). + destruct (load_inv _ _ _ _ _ H). rewrite H6. + rewrite H4. unfold unchecked_store. simpl. rewrite update_s. + simpl. rewrite getN_setN_overlap. + destruct chunk'; reflexivity. + auto. rewrite size_chunk_pred in H2. omega. + rewrite size_chunk_pred in H1. omega. +Qed. + +Theorem load_store_overlap': + forall chunk' ofs', + valid_access m1 chunk' b ofs' -> + ofs' <> ofs -> + ofs' + size_chunk chunk' > ofs -> + ofs + size_chunk chunk > ofs' -> + load chunk' m2 b ofs' = Some Vundef. +Proof. + intros. + assert (exists v', load chunk' m2 b ofs' = Some v'). + eauto with mem. + destruct H3 as [v' LOAD]. rewrite LOAD. decEq. + eapply load_store_overlap; eauto. +Qed. -(** ** Properties related to [free] *) +Theorem load_store_mismatch: + forall chunk' v', + load chunk' m2 b ofs = Some v' -> + size_chunk chunk' <> size_chunk chunk -> + v' = Vundef. +Proof. + intros. destruct (store_inv _ _ _ _ _ _ STORE). + destruct (load_inv _ _ _ _ _ H). rewrite H4. + rewrite H2. unfold unchecked_store. simpl. rewrite update_s. + simpl. rewrite getN_setN_mismatch. + destruct chunk'; reflexivity. + repeat rewrite size_chunk_pred in H0; omega. +Qed. -Theorem load_free: - forall (chunk: memory_chunk) (m: mem) (b bf: block) (ofs: Z), - b <> bf -> - load chunk (free m bf) b ofs = load chunk m b ofs. +Theorem load_store_mismatch': + forall chunk', + valid_access m1 chunk' b ofs -> + size_chunk chunk' <> size_chunk chunk -> + load chunk' m2 b ofs = Some Vundef. Proof. - intros. unfold free, load; simpl. - case (zlt b (nextblock m)). - repeat (rewrite update_o; auto). - reflexivity. + intros. + assert (exists v', load chunk' m2 b ofs = Some v'). + eauto with mem. + destruct H1 as [v' LOAD]. rewrite LOAD. decEq. + eapply load_store_mismatch; eauto. +Qed. + +Inductive load_store_cases + (chunk1: memory_chunk) (b1: block) (ofs1: Z) + (chunk2: memory_chunk) (b2: block) (ofs2: Z) : Set := + | lsc_similar: + b1 = b2 -> ofs1 = ofs2 -> size_chunk chunk1 = size_chunk chunk2 -> + load_store_cases chunk1 b1 ofs1 chunk2 b2 ofs2 + | lsc_other: + b1 <> b2 \/ ofs2 + size_chunk chunk2 <= ofs1 \/ ofs1 + size_chunk chunk1 <= ofs2 -> + load_store_cases chunk1 b1 ofs1 chunk2 b2 ofs2 + | lsc_overlap: + b1 = b2 -> ofs1 <> ofs2 -> ofs2 + size_chunk chunk2 > ofs1 -> ofs1 + size_chunk chunk1 > ofs2 -> + load_store_cases chunk1 b1 ofs1 chunk2 b2 ofs2 + | lsc_mismatch: + b1 = b2 -> ofs1 = ofs2 -> size_chunk chunk1 <> size_chunk chunk2 -> + load_store_cases chunk1 b1 ofs1 chunk2 b2 ofs2. + +Remark size_chunk_pos: + forall chunk1, size_chunk chunk1 > 0. +Proof. + destruct chunk1; simpl; omega. +Qed. + +Definition load_store_classification: + forall (chunk1: memory_chunk) (b1: block) (ofs1: Z) + (chunk2: memory_chunk) (b2: block) (ofs2: Z), + load_store_cases chunk1 b1 ofs1 chunk2 b2 ofs2. +Proof. + intros. destruct (eq_block b1 b2). + destruct (zeq ofs1 ofs2). + destruct (zeq (size_chunk chunk1) (size_chunk chunk2)). + apply lsc_similar; auto. + apply lsc_mismatch; auto. + destruct (zle (ofs2 + size_chunk chunk2) ofs1). + apply lsc_other. tauto. + destruct (zle (ofs1 + size_chunk chunk1) ofs2). + apply lsc_other. tauto. + apply lsc_overlap; auto. + apply lsc_other; tauto. +Qed. + +Theorem load_store_characterization: + forall chunk' b' ofs', + valid_access m1 chunk' b' ofs' -> + load chunk' m2 b' ofs' = + match load_store_classification chunk b ofs chunk' b' ofs' with + | lsc_similar _ _ _ => Some (Val.load_result chunk' v) + | lsc_other _ => load chunk' m1 b' ofs' + | lsc_overlap _ _ _ _ => Some Vundef + | lsc_mismatch _ _ _ => Some Vundef + end. +Proof. + intros. + assert (exists v', load chunk' m2 b' ofs' = Some v') by eauto with mem. + destruct H0 as [v' LOAD]. + destruct (load_store_classification chunk b ofs chunk' b' ofs'). + subst b' ofs'. apply load_store_similar; auto. + apply load_store_other; intuition. + subst b'. rewrite LOAD. decEq. + eapply load_store_overlap; eauto. + subst b' ofs'. rewrite LOAD. decEq. + eapply load_store_mismatch; eauto. Qed. -Theorem low_bound_free: - forall (m: mem) (b bf: block), - b <> bf -> - low_bound (free m bf) b = low_bound m b. +End STORE. + +Hint Resolve store_valid_block_1 store_valid_block_2: mem. +Hint Resolve store_valid_access_1 store_valid_access_2 + store_valid_access_3: mem. + +(** ** Properties related to [alloc]. *) + +Section ALLOC. + +Variable m1: mem. +Variables lo hi: Z. +Variable m2: mem. +Variable b: block. +Hypothesis ALLOC: alloc m1 lo hi = (m2, b). + +Lemma nextblock_alloc: + nextblock m2 = Zsucc (nextblock m1). Proof. - intros. unfold free, low_bound; simpl. - rewrite update_o; auto. + injection ALLOC; intros. rewrite <- H0; auto. Qed. -Theorem high_bound_free: - forall (m: mem) (b bf: block), - b <> bf -> - high_bound (free m bf) b = high_bound m b. +Lemma alloc_result: + b = nextblock m1. Proof. - intros. unfold free, high_bound; simpl. - rewrite update_o; auto. + injection ALLOC; auto. Qed. -Hint Resolve load_free low_bound_free high_bound_free. -(** ** Properties related to [store] *) +Lemma valid_block_alloc: + forall b', valid_block m1 b' -> valid_block m2 b'. +Proof. + unfold valid_block; intros. rewrite nextblock_alloc. omega. +Qed. -Lemma store_is_in_bounds: - forall chunk m1 b ofs v m2, - store chunk m1 b ofs v = Some m2 -> - low_bound m1 b <= ofs /\ ofs + size_chunk chunk <= high_bound m1 b. +Lemma fresh_block_alloc: + ~(valid_block m1 b). Proof. - intros. generalize (store_inv _ _ _ _ _ _ H). - intros [A [B [C [P D]]]]. - unfold low_bound, high_bound. tauto. + unfold valid_block. rewrite alloc_result. omega. Qed. -Lemma load_store_contents_same: - forall (sz: memory_size) (c: contentmap) (ofs: Z) (v: val), - load_contents sz (store_contents sz c ofs v) ofs = v. +Lemma valid_new_block: + valid_block m2 b. Proof. - intros until v. - unfold load_contents, store_contents in |- *; case sz; - rewrite getN_setN_same; reflexivity. + unfold valid_block. rewrite alloc_result. rewrite nextblock_alloc. omega. Qed. - -Theorem load_store_same: - forall (chunk: memory_chunk) (m1 m2: mem) (b: block) (ofs: Z) (v: val), - store chunk m1 b ofs v = Some m2 -> - load chunk m2 b ofs = Some (Val.load_result chunk v). + +Hint Resolve valid_block_alloc fresh_block_alloc valid_new_block: mem. + +Lemma valid_block_alloc_inv: + forall b', valid_block m2 b' -> b' = b \/ valid_block m1 b'. Proof. - intros. - generalize (store_inv _ _ _ _ _ _ H). - intros (A, (B, (C, (D, (P, E))))). - unfold load. rewrite D. - rewrite zlt_true; auto. rewrite E. - repeat (rewrite update_s). simpl. - rewrite in_bounds_exten. rewrite in_bounds_holds; auto. - rewrite load_store_contents_same; auto. -Qed. - -Lemma load_store_contents_other: - forall (sz1 sz2: memory_size) (c: contentmap) - (ofs1 ofs2: Z) (v: val), - ofs2 + size_mem sz2 <= ofs1 \/ ofs1 + size_mem sz1 <= ofs2 -> - load_contents sz2 (store_contents sz1 c ofs1 v) ofs2 = - load_contents sz2 c ofs2. -Proof. - intros until v. - unfold size_mem, store_contents, load_contents; - case sz1; case sz2; intros; - (rewrite getN_setN_other; - [reflexivity | simpl Z_of_nat; omega]). + unfold valid_block; intros. + rewrite nextblock_alloc in H. rewrite alloc_result. + unfold block; omega. Qed. -Theorem load_store_other: - forall (chunk1 chunk2: memory_chunk) (m1 m2: mem) - (b1 b2: block) (ofs1 ofs2: Z) (v: val), - store chunk1 m1 b1 ofs1 v = Some m2 -> - b1 <> b2 - \/ ofs2 + size_chunk chunk2 <= ofs1 - \/ ofs1 + size_chunk chunk1 <= ofs2 -> - load chunk2 m2 b2 ofs2 = load chunk2 m1 b2 ofs2. +Lemma low_bound_alloc: + forall b', low_bound m2 b' = if zeq b' b then lo else low_bound m1 b'. Proof. - intros. - generalize (store_inv _ _ _ _ _ _ H). - intros (A, (B, (C, (D, (P, E))))). - unfold load. rewrite D. - case (zlt b2 (nextblock m1)); intro. - rewrite E; unfold update; case (zeq b2 b1); intro; simpl. - subst b2. rewrite in_bounds_exten. - rewrite load_store_contents_other. auto. - tauto. - reflexivity. - reflexivity. -Qed. - -Ltac LSCO := - match goal with - | |- (match getN ?sz2 ?ofs2 (setN ?sz1 ?ofs1 ?v ?c) with - | Undef => _ - | Datum8 _ => _ - | Datum16 _ => _ - | Datum32 _ => _ - | Datum64 _ => _ - | Cont => _ - end = _) => - elim (getN_setN_overlap sz1 sz2 ofs1 ofs2 v c); - [ let H := fresh in (intro H; rewrite H; reflexivity) - | let H := fresh in (intro H; rewrite H; reflexivity) - | assumption - | simpl Z_of_nat; omega - | simpl Z_of_nat; omega - | discriminate ] - end. + intros. injection ALLOC; intros. rewrite <- H0; unfold low_bound; simpl. + unfold update. rewrite H. destruct (zeq b' b); auto. +Qed. -Lemma load_store_contents_overlap: - forall (sz1 sz2: memory_size) (c: contentmap) - (ofs1 ofs2: Z) (v: val), - ofs1 <> ofs2 -> - ofs2 + size_mem sz2 > ofs1 -> ofs1 + size_mem sz1 > ofs2 -> - load_contents sz2 (store_contents sz1 c ofs1 v) ofs2 = Vundef. +Lemma low_bound_alloc_same: + low_bound m2 b = lo. Proof. - intros. - destruct sz1; destruct sz2; simpl in H0; simpl in H1; simpl; LSCO. -Qed. - -Ltac LSCM := - match goal with - | H:(?x <> ?x) |- _ => - elim H; reflexivity - | |- (match getN ?sz2 ?ofs (setN ?sz1 ?ofs ?v ?c) with - | Undef => _ - | Datum8 _ => _ - | Datum16 _ => _ - | Datum32 _ => _ - | Datum64 _ => _ - | Cont => _ - end = _) => - elim (getN_setN_mismatch sz1 sz2 ofs v c); - [ let H := fresh in (intro H; rewrite H; reflexivity) - | let H := fresh in (intro H; rewrite H; reflexivity) ] - end. + rewrite low_bound_alloc. apply zeq_true. +Qed. -Lemma load_store_contents_mismatch: - forall (sz1 sz2: memory_size) (c: contentmap) - (ofs: Z) (v: val), - sz1 <> sz2 -> - load_contents sz2 (store_contents sz1 c ofs v) ofs = Vundef. +Lemma low_bound_alloc_other: + forall b', valid_block m1 b' -> low_bound m2 b' = low_bound m1 b'. Proof. - intros. - destruct sz1; destruct sz2; simpl; LSCM. -Qed. + intros; rewrite low_bound_alloc. + apply zeq_false. eauto with mem. +Qed. -Theorem low_bound_store: - forall (chunk: memory_chunk) (m1 m2: mem) (b b': block) (ofs: Z) (v: val), - store chunk m1 b ofs v = Some m2 -> - low_bound m2 b' = low_bound m1 b'. +Lemma high_bound_alloc: + forall b', high_bound m2 b' = if zeq b' b then hi else high_bound m1 b'. Proof. - intros. - generalize (store_inv _ _ _ _ _ _ H). - intros (A, (B, (C, (D, (P, E))))). - unfold low_bound. rewrite E; unfold update. - case (zeq b' b); intro. - subst b'. reflexivity. - reflexivity. + intros. injection ALLOC; intros. rewrite <- H0; unfold high_bound; simpl. + unfold update. rewrite H. destruct (zeq b' b); auto. Qed. -Theorem high_bound_store: - forall (chunk: memory_chunk) (m1 m2: mem) (b b': block) (ofs: Z) (v: val), - store chunk m1 b ofs v = Some m2 -> - high_bound m2 b' = high_bound m1 b'. +Lemma high_bound_alloc_same: + high_bound m2 b = hi. Proof. - intros. - generalize (store_inv _ _ _ _ _ _ H). - intros (A, (B, (C, (D, (P, E))))). - unfold high_bound. rewrite E; unfold update. - case (zeq b' b); intro. - subst b'. reflexivity. - reflexivity. + rewrite high_bound_alloc. apply zeq_true. Qed. -Hint Resolve high_bound_store low_bound_store load_store_contents_mismatch - load_store_contents_overlap load_store_other store_is_in_bounds - load_store_contents_same load_store_same load_store_contents_other. +Lemma high_bound_alloc_other: + forall b', valid_block m1 b' -> high_bound m2 b' = high_bound m1 b'. +Proof. + intros; rewrite high_bound_alloc. + apply zeq_false. eauto with mem. +Qed. -(** * Agreement between memory blocks. *) +Lemma valid_access_alloc_other: + forall chunk b' ofs, + valid_access m1 chunk b' ofs -> + valid_access m2 chunk b' ofs. +Proof. + intros. inv H. constructor. auto with mem. + rewrite low_bound_alloc_other; auto. + rewrite high_bound_alloc_other; auto. +Qed. -(** Two memory blocks [c1] and [c2] agree on a range [lo] to [hi] - if they associate the same contents to byte offsets in the range - [lo] (included) to [hi] (excluded). *) +Lemma valid_access_alloc_same: + forall chunk ofs, + lo <= ofs -> ofs + size_chunk chunk <= hi -> + valid_access m2 chunk b ofs. +Proof. + intros. constructor. auto with mem. + rewrite low_bound_alloc_same; auto. + rewrite high_bound_alloc_same; auto. +Qed. + +Hint Resolve valid_access_alloc_other valid_access_alloc_same: mem. + +Lemma valid_access_alloc_inv: + forall chunk b' ofs, + valid_access m2 chunk b' ofs -> + valid_access m1 chunk b' ofs \/ + (b' = b /\ lo <= ofs /\ ofs + size_chunk chunk <= hi). +Proof. + intros. inv H. + elim (valid_block_alloc_inv _ H0); intro. + subst b'. rewrite low_bound_alloc_same in H1. + rewrite high_bound_alloc_same in H2. + right. tauto. + left. constructor. auto. + rewrite low_bound_alloc_other in H1; auto. + rewrite high_bound_alloc_other in H2; auto. +Qed. + +Theorem load_alloc_unchanged: + forall chunk b' ofs, + valid_block m1 b' -> + load chunk m2 b' ofs = load chunk m1 b' ofs. +Proof. + intros. unfold load. + destruct (in_bounds m2 chunk b' ofs). + elim (valid_access_alloc_inv _ _ _ v). intro. + rewrite in_bounds_true; auto. + injection ALLOC; intros. rewrite <- H2; simpl. + rewrite update_o. auto. rewrite H1. apply sym_not_equal. eauto with mem. + intros [A [B C]]. subst b'. elimtype False. eauto with mem. + destruct (in_bounds m1 chunk b' ofs). + elim n; eauto with mem. + auto. +Qed. -Definition contentmap_agree (lo hi: Z) (c1 c2: contentmap) := - forall (ofs: Z), - lo <= ofs < hi -> c1 ofs = c2 ofs. +Theorem load_alloc_other: + forall chunk b' ofs v, + load chunk m1 b' ofs = Some v -> + load chunk m2 b' ofs = Some v. +Proof. + intros. rewrite <- H. apply load_alloc_unchanged. eauto with mem. +Qed. -Definition block_contents_agree (lo hi: Z) (c1 c2: block_contents) := - contentmap_agree lo hi c1.(contents) c2.(contents). +Theorem load_alloc_same: + forall chunk ofs v, + load chunk m2 b ofs = Some v -> + v = Vundef. +Proof. + intros. destruct (load_inv _ _ _ _ _ H). rewrite H1. + injection ALLOC; intros. rewrite <- H3; simpl. + rewrite <- H2. rewrite update_s. + simpl. rewrite getN_init. destruct chunk; auto. +Qed. + +Theorem load_alloc_same': + forall chunk ofs, + lo <= ofs -> ofs + size_chunk chunk <= hi -> + load chunk m2 b ofs = Some Vundef. +Proof. + intros. assert (exists v, load chunk m2 b ofs = Some v). + apply valid_access_load. constructor; eauto with mem. + rewrite low_bound_alloc_same. auto. + rewrite high_bound_alloc_same. auto. + destruct H1 as [v LOAD]. rewrite LOAD. decEq. + eapply load_alloc_same; eauto. +Qed. + +End ALLOC. + +Hint Resolve valid_block_alloc fresh_block_alloc valid_new_block: mem. +Hint Resolve valid_access_alloc_other valid_access_alloc_same: mem. +Hint Resolve load_alloc_unchanged: mem. + +(** ** Properties related to [free]. *) -Definition block_agree (b: block) (lo hi: Z) (m1 m2: mem) := - block_contents_agree lo hi - (m1.(blocks) b) (m2.(blocks) b). +Section FREE. -Theorem block_agree_refl: - forall (m: mem) (b: block) (lo hi: Z), - block_agree b lo hi m m. +Variable m: mem. +Variable bf: block. + +Lemma valid_block_free_1: + forall b, valid_block m b -> valid_block (free m bf) b. Proof. - intros. hnf. auto. + unfold valid_block, free; intros; simpl; auto. Qed. -Theorem block_agree_sym: - forall (m1 m2: mem) (b: block) (lo hi: Z), - block_agree b lo hi m1 m2 -> - block_agree b lo hi m2 m1. +Lemma valid_block_free_2: + forall b, valid_block (free m bf) b -> valid_block m b. Proof. - intros. hnf. intros. symmetry. apply H. auto. + unfold valid_block, free; intros; simpl in *; auto. Qed. -Theorem block_agree_trans: - forall (m1 m2 m3: mem) (b: block) (lo hi: Z), - block_agree b lo hi m1 m2 -> - block_agree b lo hi m2 m3 -> - block_agree b lo hi m1 m3. +Hint Resolve valid_block_free_1 valid_block_free_2: mem. + +Lemma low_bound_free: + forall b, b <> bf -> low_bound (free m bf) b = low_bound m b. Proof. - intros. hnf. intros. - transitivity (contents (blocks m2 b) ofs). - apply H; auto. apply H0; auto. + intros. unfold low_bound, free; simpl. + rewrite update_o; auto. Qed. -Lemma check_cont_agree: - forall (c1 c2: contentmap) (lo hi: Z), - contentmap_agree lo hi c1 c2 -> - forall (n: nat) (ofs: Z), - lo <= ofs -> ofs + Z_of_nat n <= hi -> - check_cont n ofs c2 = check_cont n ofs c1. +Lemma high_bound_free: + forall b, b <> bf -> high_bound (free m bf) b = high_bound m b. Proof. - induction n; intros; simpl. - auto. - rewrite inj_S in H1. - rewrite H. case (c2 ofs); intros; auto. - apply IHn; omega. - omega. + intros. unfold high_bound, free; simpl. + rewrite update_o; auto. Qed. -Lemma getN_agree: - forall (c1 c2: contentmap) (lo hi: Z), - contentmap_agree lo hi c1 c2 -> - forall (n: nat) (ofs: Z), - lo <= ofs -> ofs + Z_of_nat n < hi -> - getN n ofs c2 = getN n ofs c1. +Lemma low_bound_free_same: + forall m b, low_bound (free m b) b = 0. Proof. - intros. unfold getN. - rewrite (check_cont_agree c1 c2 lo hi H n (ofs + 1)). - case (check_cont n (ofs + 1) c1). - symmetry. apply H. omega. auto. - omega. omega. + intros. unfold low_bound; simpl. rewrite update_s. simpl; omega. Qed. -Lemma load_contentmap_agree: - forall (sz: memory_size) (c1 c2: contentmap) (lo hi ofs: Z), - contentmap_agree lo hi c1 c2 -> - lo <= ofs -> ofs + size_mem sz <= hi -> - load_contents sz c2 ofs = load_contents sz c1 ofs. +Lemma high_bound_free_same: + forall m b, high_bound (free m b) b = 0. Proof. - intros sz c1 c2 lo hi ofs EX LO. - unfold load_contents, size_mem; case sz; intro HI; - rewrite (getN_agree c1 c2 lo hi EX); auto; simpl Z_of_nat; omega. + intros. unfold high_bound; simpl. rewrite update_s. simpl; omega. Qed. -Lemma set_cont_agree: - forall (lo hi: Z) (n: nat) (c1 c2: contentmap) (ofs: Z), - contentmap_agree lo hi c1 c2 -> - contentmap_agree lo hi (set_cont n ofs c1) (set_cont n ofs c2). +Lemma valid_access_free_1: + forall chunk b ofs, + valid_access m chunk b ofs -> b <> bf -> + valid_access (free m bf) chunk b ofs. Proof. - induction n; simpl; intros. - auto. - red. intros p B. - case (zeq p ofs); intro. - subst p. repeat (rewrite update_s). reflexivity. - repeat (rewrite update_o). apply IHn. assumption. - assumption. auto. auto. + intros. inv H. constructor. auto with mem. + rewrite low_bound_free; auto. rewrite high_bound_free; auto. Qed. -Lemma setN_agree: - forall (lo hi: Z) (n: nat) (c1 c2: contentmap) (ofs: Z) (v: content), - contentmap_agree lo hi c1 c2 -> - contentmap_agree lo hi (setN n ofs v c1) (setN n ofs v c2). +Lemma valid_access_free_2: + forall chunk ofs, ~(valid_access (free m bf) chunk bf ofs). Proof. - intros. unfold setN. red; intros p B. - case (zeq p ofs); intro. - subst p. repeat (rewrite update_s). reflexivity. - repeat (rewrite update_o; auto). - exact (set_cont_agree lo hi n c1 c2 (ofs + 1) H p B). + intros; red; intros. inv H. + unfold free, low_bound in H1; simpl in H1. rewrite update_s in H1. simpl in H1. + unfold free, high_bound in H2; simpl in H2. rewrite update_s in H2. simpl in H2. + generalize (size_chunk_pos chunk). omega. Qed. -Lemma store_contentmap_agree: - forall (sz: memory_size) (c1 c2: contentmap) (lo hi ofs: Z) (v: val), - contentmap_agree lo hi c1 c2 -> - contentmap_agree lo hi - (store_contents sz c1 ofs v) (store_contents sz c2 ofs v). +Hint Resolve valid_access_free_1 valid_access_free_2: mem. + +Lemma valid_access_free_inv: + forall chunk b ofs, + valid_access (free m bf) chunk b ofs -> + valid_access m chunk b ofs /\ b <> bf. Proof. - intros. unfold store_contents; case sz; apply setN_agree; auto. + intros. destruct (eq_block b bf). subst b. + elim (valid_access_free_2 _ _ H). + inv H. rewrite low_bound_free in H1; auto. + rewrite high_bound_free in H2; auto. + split; auto. constructor; auto with mem. Qed. -Lemma set_cont_outside_agree: - forall (lo hi: Z) (n: nat) (c1 c2: contentmap) (ofs: Z), - contentmap_agree lo hi c1 c2 -> - ofs + Z_of_nat n <= lo \/ hi <= ofs -> - contentmap_agree lo hi c1 (set_cont n ofs c2). +Theorem load_free: + forall chunk b ofs, + b <> bf -> + load chunk (free m bf) b ofs = load chunk m b ofs. Proof. - induction n; intros; simpl. - auto. - red; intros p R. rewrite inj_S in H0. - unfold update. case (zeq p ofs); intro. - subst p. omegaContradiction. - apply IHn. auto. omega. auto. + intros. unfold load. + destruct (in_bounds m chunk b ofs). + rewrite in_bounds_true; auto with mem. + unfold free; simpl. rewrite update_o; auto. + destruct (in_bounds (free m bf) chunk b ofs); auto. + elim n. elim (valid_access_free_inv _ _ _ v); auto. +Qed. + +End FREE. + +(** ** Properties related to [free_list] *) + +Lemma valid_block_free_list_1: + forall bl m b, valid_block m b -> valid_block (free_list m bl) b. +Proof. + induction bl; simpl; intros. auto. + apply valid_block_free_1; auto. Qed. -Lemma setN_outside_agree: - forall (lo hi: Z) (n: nat) (c1 c2: contentmap) (ofs: Z) (v: content), - contentmap_agree lo hi c1 c2 -> - ofs + Z_of_nat n < lo \/ hi <= ofs -> - contentmap_agree lo hi c1 (setN n ofs v c2). +Lemma valid_block_free_list_2: + forall bl m b, valid_block (free_list m bl) b -> valid_block m b. Proof. - intros. unfold setN. red; intros p R. - unfold update. case (zeq p ofs); intro. - omegaContradiction. - apply (set_cont_outside_agree lo hi n c1 c2 (ofs + 1) H). - omega. auto. + induction bl; simpl; intros. auto. + apply IHbl. apply valid_block_free_2 with a; auto. Qed. -Lemma store_contentmap_outside_agree: - forall (sz: memory_size) (c1 c2: contentmap) (lo hi ofs: Z) (v: val), - contentmap_agree lo hi c1 c2 -> - ofs + size_mem sz <= lo \/ hi <= ofs -> - contentmap_agree lo hi c1 (store_contents sz c2 ofs v). +Lemma valid_access_free_list: + forall chunk b ofs m bl, + valid_access m chunk b ofs -> ~In b bl -> + valid_access (free_list m bl) chunk b ofs. Proof. - intros until v. - unfold store_contents; case sz; simpl; intros; - apply setN_outside_agree; auto; simpl Z_of_nat; omega. + induction bl; simpl; intros. auto. + apply valid_access_free_1. apply IHbl. auto. intuition. intuition congruence. Qed. -Theorem load_agree: - forall (chunk: memory_chunk) (m1 m2: mem) - (b: block) (lo hi: Z) (ofs: Z) (v1 v2: val), - block_agree b lo hi m1 m2 -> - lo <= ofs -> ofs + size_chunk chunk <= hi -> - load chunk m1 b ofs = Some v1 -> - load chunk m2 b ofs = Some v2 -> - v1 = v2. +Lemma valid_access_free_list_inv: + forall chunk b ofs m bl, + valid_access (free_list m bl) chunk b ofs -> + ~In b bl /\ valid_access m chunk b ofs. +Proof. + induction bl; simpl; intros. + tauto. + elim (valid_access_free_inv _ _ _ _ _ H); intros. + elim (IHbl H0); intros. + intuition congruence. +Qed. + +(** ** Properties related to pointer validity *) + +Lemma valid_pointer_valid_access: + forall m b ofs, + valid_pointer m b ofs = true <-> valid_access m Mint8unsigned b ofs. +Proof. + unfold valid_pointer; intros; split; intros. + destruct (andb_prop _ _ H). destruct (andb_prop _ _ H0). + constructor. red. eapply proj_sumbool_true; eauto. + eapply proj_sumbool_true; eauto. + change (size_chunk Mint8unsigned) with 1. + generalize (proj_sumbool_true _ H1). omega. + inv H. unfold proj_sumbool. + rewrite zlt_true; auto. rewrite zle_true; auto. + change (size_chunk Mint8unsigned) with 1 in H2. + rewrite zlt_true. auto. omega. +Qed. + +Theorem valid_pointer_alloc: + forall (m1 m2: mem) (lo hi: Z) (b b': block) (ofs: Z), + alloc m1 lo hi = (m2, b') -> + valid_pointer m1 b ofs = true -> + valid_pointer m2 b ofs = true. +Proof. + intros. rewrite valid_pointer_valid_access in H0. + rewrite valid_pointer_valid_access. + eauto with mem. +Qed. + +Theorem valid_pointer_store: + forall (chunk: memory_chunk) (m1 m2: mem) (b b': block) (ofs ofs': Z) (v: val), + store chunk m1 b' ofs' v = Some m2 -> + valid_pointer m1 b ofs = true -> valid_pointer m2 b ofs = true. +Proof. + intros. rewrite valid_pointer_valid_access in H0. + rewrite valid_pointer_valid_access. + eauto with mem. +Qed. + +(** * Generic injections between memory states. *) + +Section GENERIC_INJECT. + +Definition meminj : Set := block -> option (block * Z). + +Variable val_inj: meminj -> val -> val -> Prop. + +(* +Hypothesis val_inj_ptr: + forall mi b1 ofs1 b2 ofs2, + val_inj mi (Vptr b1 ofs1) (Vptr b2 ofs2) <-> + exists delta, mi b1 = Some(b2, delta) /\ ofs2 = Int.repr (Int.signed ofs1 + delta). +*) + +Hypothesis val_inj_undef: + forall mi, val_inj mi Vundef Vundef. + +Definition mem_inj (mi: meminj) (m1 m2: mem) := + forall chunk b1 ofs v1 b2 delta, + mi b1 = Some(b2, delta) -> + load chunk m1 b1 ofs = Some v1 -> + exists v2, load chunk m2 b2 (ofs + delta) = Some v2 /\ val_inj mi v1 v2. + +Lemma valid_access_inj: + forall mi m1 m2 chunk b1 ofs b2 delta, + mi b1 = Some(b2, delta) -> + mem_inj mi m1 m2 -> + valid_access m1 chunk b1 ofs -> + valid_access m2 chunk b2 (ofs + delta). Proof. intros. - generalize (load_inv _ _ _ _ _ H2). intros [K [L [M N]]]. - generalize (load_inv _ _ _ _ _ H3). intros [P [Q [R S]]]. - subst v1; subst v2. symmetry. - decEq. eapply load_contentmap_agree. - apply H. auto. auto. -Qed. - -Theorem store_agree: - forall (chunk: memory_chunk) (m1 m2 m1' m2': mem) - (b: block) (lo hi: Z) - (b': block) (ofs: Z) (v: val), - block_agree b lo hi m1 m2 -> - store chunk m1 b' ofs v = Some m1' -> - store chunk m2 b' ofs v = Some m2' -> - block_agree b lo hi m1' m2'. + assert (exists v1, load chunk m1 b1 ofs = Some v1) by eauto with mem. + destruct H2 as [v1 LOAD1]. + destruct (H0 _ _ _ _ _ _ H LOAD1) as [v2 [LOAD2 VCP]]. + eauto with mem. +Qed. + +Hint Resolve valid_access_inj: mem. + +Lemma store_unmapped_inj: + forall mi m1 m2 b ofs v chunk m1', + mem_inj mi m1 m2 -> + mi b = None -> + store chunk m1 b ofs v = Some m1' -> + mem_inj mi m1' m2. +Proof. + intros; red; intros. + assert (load chunk0 m1 b1 ofs0 = Some v1). + rewrite <- H3; symmetry. eapply load_store_other; eauto. + left. congruence. + eapply H; eauto. +Qed. + +Lemma store_outside_inj: + forall mi m1 m2 chunk b ofs v m2', + mem_inj mi m1 m2 -> + (forall b' delta, + mi b' = Some(b, delta) -> + high_bound m1 b' + delta <= ofs + \/ ofs + size_chunk chunk <= low_bound m1 b' + delta) -> + store chunk m2 b ofs v = Some m2' -> + mem_inj mi m1 m2'. +Proof. + intros; red; intros. + exploit H; eauto. intros [v2 [LOAD2 VINJ]]. + exists v2; split; auto. + rewrite <- LOAD2. eapply load_store_other; eauto. + destruct (eq_block b2 b). subst b2. + right. generalize (H0 _ _ H2); intro. + assert (valid_access m1 chunk0 b1 ofs0) by eauto with mem. + inv H5. omega. auto. +Qed. + +Definition meminj_no_overlap (mi: meminj) (m: mem) : Prop := + forall b1 b1' delta1 b2 b2' delta2, + b1 <> b2 -> + mi b1 = Some (b1', delta1) -> + mi b2 = Some (b2', delta2) -> + b1' <> b2' + \/ low_bound m b1 >= high_bound m b1 + \/ low_bound m b2 >= high_bound m b2 + \/ high_bound m b1 + delta1 <= low_bound m b2 + delta2 + \/ high_bound m b2 + delta2 <= low_bound m b1 + delta1. + +Lemma store_mapped_inj: + forall mi m1 m2 b1 ofs b2 delta v1 v2 chunk m1', + mem_inj mi m1 m2 -> + meminj_no_overlap mi m1 -> + mi b1 = Some(b2, delta) -> + store chunk m1 b1 ofs v1 = Some m1' -> + (forall chunk', size_chunk chunk' = size_chunk chunk -> + val_inj mi (Val.load_result chunk' v1) (Val.load_result chunk' v2)) -> + exists m2', + store chunk m2 b2 (ofs + delta) v2 = Some m2' /\ mem_inj mi m1' m2'. Proof. - intros. - generalize (store_inv _ _ _ _ _ _ H0). - intros [I [J [K [L [x M]]]]]. - generalize (store_inv _ _ _ _ _ _ H1). - intros [P [Q [R [S [y T]]]]]. - red. red. - rewrite M; rewrite T; unfold update. - case (zeq b b'); intro; simpl. - subst b'. apply store_contentmap_agree. assumption. - apply H. -Qed. - -Theorem store_outside_agree: - forall (chunk: memory_chunk) (m1 m2 m2': mem) - (b: block) (lo hi: Z) - (b': block) (ofs: Z) (v: val), - block_agree b lo hi m1 m2 -> - b <> b' \/ ofs + size_chunk chunk <= lo \/ hi <= ofs -> - store chunk m2 b' ofs v = Some m2' -> - block_agree b lo hi m1 m2'. + intros. + assert (exists m2', store chunk m2 b2 (ofs + delta) v2 = Some m2') by eauto with mem. + destruct H4 as [m2' STORE2]. + exists m2'; split. auto. + red. intros chunk' b1' ofs' v b2' delta' CP LOAD1. + assert (valid_access m1 chunk' b1' ofs') by eauto with mem. + generalize (load_store_characterization _ _ _ _ _ _ H2 _ _ _ H4). + destruct (load_store_classification chunk b1 ofs chunk' b1' ofs'); + intro. + (* similar *) + subst b1' ofs'. + rewrite CP in H1. inv H1. + rewrite LOAD1 in H5. inv H5. + exists (Val.load_result chunk' v2). split. + eapply load_store_similar; eauto. + auto. + (* disjoint *) + rewrite LOAD1 in H5. + destruct (H _ _ _ _ _ _ CP (sym_equal H5)) as [v2' [LOAD2 VCP]]. + exists v2'. split; auto. + rewrite <- LOAD2. eapply load_store_other; eauto. + destruct (eq_block b1 b1'). subst b1'. + rewrite CP in H1; inv H1. + right. elim o; [congruence | omega]. + assert (valid_access m1 chunk b1 ofs) by eauto with mem. + generalize (H0 _ _ _ _ _ _ n H1 CP). intros [A | [A | [A | A]]]. + auto. + inv H6. generalize (size_chunk_pos chunk). intro. omegaContradiction. + inv H4. generalize (size_chunk_pos chunk'). intro. omegaContradiction. + right. inv H4. inv H6. omega. + (* overlapping *) + subst b1'. rewrite CP in H1; inv H1. + assert (exists v2', load chunk' m2' b2 (ofs' + delta) = Some v2') by eauto with mem. + destruct H1 as [v2' LOAD2']. + assert (v2' = Vundef). eapply load_store_overlap; eauto. + omega. omega. omega. + exists v2'; split. auto. + replace v with Vundef by congruence. subst v2'. apply val_inj_undef. + (* mismatch *) + subst b1' ofs'. rewrite CP in H1; inv H1. + assert (exists v2', load chunk' m2' b2 (ofs + delta) = Some v2') by eauto with mem. + destruct H1 as [v2' LOAD2']. + assert (v2' = Vundef). eapply load_store_mismatch; eauto. + exists v2'; split. auto. + replace v with Vundef by congruence. subst v2'. apply val_inj_undef. +Qed. + +Lemma alloc_parallel_inj: + forall mi m1 m2 lo1 hi1 m1' b1 lo2 hi2 m2' b2 delta, + mem_inj mi m1 m2 -> + alloc m1 lo1 hi1 = (m1', b1) -> + alloc m2 lo2 hi2 = (m2', b2) -> + mi b1 = Some(b2, delta) -> + lo2 <= lo1 + delta -> hi1 + delta <= hi2 -> + mem_inj mi m1' m2'. +Proof. + intros; red; intros. + exploit (valid_access_alloc_inv m1); eauto with mem. + intros [A | [A [B C]]]. + assert (load chunk m1 b0 ofs = Some v1). + rewrite <- H6. symmetry. eapply load_alloc_unchanged; eauto with mem. + exploit H; eauto. intros [v2 [LOAD2 VINJ]]. + exists v2; split. + rewrite <- LOAD2. eapply load_alloc_unchanged; eauto with mem. + auto. + subst b0. rewrite H2 in H5. inversion H5. subst b3 delta0. + assert (v1 = Vundef). eapply load_alloc_same with (m1 := m1); eauto. + subst v1. + assert (exists v2, load chunk m2' b2 (ofs + delta) = Some v2). + apply valid_access_load. + eapply valid_access_alloc_same; eauto. omega. omega. + destruct H7 as [v2 LOAD2]. + assert (v2 = Vundef). eapply load_alloc_same with (m1 := m2); eauto. + subst v2. + exists Vundef; split. auto. apply val_inj_undef. +Qed. + +Lemma alloc_right_inj: + forall mi m1 m2 lo hi b2 m2', + mem_inj mi m1 m2 -> + alloc m2 lo hi = (m2', b2) -> + mem_inj mi m1 m2'. Proof. - intros. - generalize (store_inv _ _ _ _ _ _ H1). - intros [I [J [K [L [x M]]]]]. - red. red. rewrite M; unfold update; - case (zeq b b'); intro; simpl. - subst b'. apply store_contentmap_outside_agree. - assumption. - elim H0; intro. tauto. exact H2. - apply H. + intros; red; intros. + exploit H; eauto. intros [v2 [LOAD2 VINJ]]. + exists v2; split; auto. + assert (valid_block m2 b0). + apply valid_access_valid_block with chunk (ofs + delta). + eauto with mem. + rewrite <- LOAD2. eapply load_alloc_unchanged; eauto. +Qed. + +Hypothesis val_inj_undef_any: + forall mi v, val_inj mi Vundef v. + +Lemma alloc_left_unmapped_inj: + forall mi m1 m2 lo hi b1 m1', + mem_inj mi m1 m2 -> + alloc m1 lo hi = (m1', b1) -> + mi b1 = None -> + mem_inj mi m1' m2. +Proof. + intros; red; intros. + exploit (valid_access_alloc_inv m1); eauto with mem. + intros [A | [A [B C]]]. + eapply H; eauto. + rewrite <- H3. symmetry. eapply load_alloc_unchanged; eauto with mem. + subst b0. congruence. +Qed. + +Lemma alloc_left_mapped_inj: + forall mi m1 m2 lo hi b1 m1' b2 delta, + mem_inj mi m1 m2 -> + alloc m1 lo hi = (m1', b1) -> + mi b1 = Some(b2, delta) -> + valid_block m2 b2 -> + low_bound m2 b2 <= lo + delta -> hi + delta <= high_bound m2 b2 -> + mem_inj mi m1' m2. +Proof. + intros; red; intros. + exploit (valid_access_alloc_inv m1); eauto with mem. + intros [A | [A [B C]]]. + eapply H; eauto. + rewrite <- H6. symmetry. eapply load_alloc_unchanged; eauto with mem. + subst b0. rewrite H1 in H5. inversion H5. subst b3 delta0. + assert (v1 = Vundef). eapply load_alloc_same with (m1 := m1); eauto. + subst v1. + assert (exists v2, load chunk m2 b2 (ofs + delta) = Some v2). + apply valid_access_load. constructor. auto. omega. omega. + destruct H7 as [v2 LOAD2]. exists v2; split. auto. + apply val_inj_undef_any. +Qed. + +Lemma free_parallel_inj: + forall mi m1 m2 b1 b2 delta, + mem_inj mi m1 m2 -> + mi b1 = Some(b2, delta) -> + (forall b delta', mi b = Some(b2, delta') -> b = b1) -> + mem_inj mi (free m1 b1) (free m2 b2). +Proof. + intros; red; intros. + exploit valid_access_free_inv; eauto with mem. intros [A B]. + assert (load chunk m1 b0 ofs = Some v1). + rewrite <- H3. symmetry. apply load_free. auto. + exploit H; eauto. intros [v2 [LOAD2 INJ]]. + exists v2; split. + rewrite <- LOAD2. apply load_free. + red; intro; subst b3. elim B. eauto. + auto. Qed. -(** * Store extensions *) +Lemma free_left_inj: + forall mi m1 m2 b1, + mem_inj mi m1 m2 -> + mem_inj mi (free m1 b1) m2. +Proof. + intros; red; intros. + exploit valid_access_free_inv; eauto with mem. intros [A B]. + eapply H; eauto with mem. + rewrite <- H1; symmetry; eapply load_free; eauto. +Qed. + +Lemma free_list_left_inj: + forall mi bl m1 m2, + mem_inj mi m1 m2 -> + mem_inj mi (free_list m1 bl) m2. +Proof. + induction bl; intros; simpl. + auto. + apply free_left_inj. auto. +Qed. + +Lemma free_right_inj: + forall mi m1 m2 b2, + mem_inj mi m1 m2 -> + (forall b1 delta chunk ofs, + mi b1 = Some(b2, delta) -> ~(valid_access m1 chunk b1 ofs)) -> + mem_inj mi m1 (free m2 b2). +Proof. + intros; red; intros. + assert (b0 <> b2). + red; intro; subst b0. elim (H0 b1 delta chunk ofs H1). + eauto with mem. + exploit H; eauto. intros [v2 [LOAD2 INJ]]. + exists v2; split; auto. + rewrite <- LOAD2. apply load_free. auto. +Qed. + +Lemma valid_pointer_inj: + forall mi m1 m2 b1 ofs b2 delta, + mi b1 = Some(b2, delta) -> + mem_inj mi m1 m2 -> + valid_pointer m1 b1 ofs = true -> + valid_pointer m2 b2 (ofs + delta) = true. +Proof. + intros. rewrite valid_pointer_valid_access in H1. + rewrite valid_pointer_valid_access. eauto with mem. +Qed. + +End GENERIC_INJECT. + +(** ** Store extensions *) (** A store [m2] extends a store [m1] if [m2] can be obtained from [m1] by increasing the sizes of the memory blocks of [m1] (decreasing the low bounds, increasing the high bounds), while still keeping the - same contents for block offsets that are valid in [m1]. - This notion is used in the proof of semantic equivalence in - module [Machenv]. *) + same contents for block offsets that are valid in [m1]. *) -Definition block_contents_extends (c1 c2: block_contents) := - c2.(low) <= c1.(low) /\ c1.(high) <= c2.(high) /\ - contentmap_agree c1.(low) c1.(high) c1.(contents) c2.(contents). +Definition inject_id : meminj := fun b => Some(b, 0). + +Definition val_inj_id (mi: meminj) (v1 v2: val) : Prop := v1 = v2. Definition extends (m1 m2: mem) := - m1.(nextblock) = m2.(nextblock) /\ - forall (b: block), - b < m1.(nextblock) -> - block_contents_extends (m1.(blocks) b) (m2.(blocks) b). + nextblock m1 = nextblock m2 /\ mem_inj val_inj_id inject_id m1 m2. Theorem extends_refl: forall (m: mem), extends m m. Proof. - intro. red. split. - reflexivity. - intros. red. - split. omega. split. omega. - red. intros. reflexivity. + intros; split. auto. + red; unfold inject_id; intros. inv H. + exists v1; split. replace (ofs + 0) with ofs by omega. auto. + unfold val_inj_id; auto. Qed. Theorem alloc_extends: @@ -1293,16 +1519,18 @@ Theorem alloc_extends: alloc m2 lo2 hi2 = (m2', b2) -> b1 = b2 /\ extends m1' m2'. Proof. - unfold extends, alloc; intros. - injection H2; intros; subst m1'; subst b1. - injection H3; intros; subst m2'; subst b2. - simpl. intuition. - rewrite <- H4. case (zeq b (nextblock m1)); intro. - subst b. repeat rewrite update_s. - red; simpl. intuition. - red; intros; reflexivity. - repeat rewrite update_o. apply H5. omega. - auto. auto. + intros. destruct H. + assert (b1 = b2). + transitivity (nextblock m1). eapply alloc_result; eauto. + symmetry. rewrite H. eapply alloc_result; eauto. + subst b2. split. auto. split. + rewrite (nextblock_alloc _ _ _ _ _ H2). + rewrite (nextblock_alloc _ _ _ _ _ H3). + congruence. + eapply alloc_parallel_inj; eauto. + unfold val_inj_id; auto. + unfold inject_id; eauto. + omega. omega. Qed. Theorem free_extends: @@ -1310,16 +1538,11 @@ Theorem free_extends: extends m1 m2 -> extends (free m1 b) (free m2 b). Proof. - unfold extends, free; intros. - simpl. intuition. - red; intros; simpl. - case (zeq b0 b); intro. - subst b0; repeat (rewrite update_s). - simpl. split. omega. split. omega. - red. intros. omegaContradiction. - repeat (rewrite update_o). - exact (H1 b0 H). - auto. auto. + intros. destruct H. split. + simpl; auto. + eapply free_parallel_inj; eauto. + unfold inject_id. eauto. + unfold inject_id; intros. congruence. Qed. Theorem load_extends: @@ -1328,18 +1551,10 @@ Theorem load_extends: load chunk m1 b ofs = Some v -> load chunk m2 b ofs = Some v. Proof. - intros sz m1 m2 b ofs v (X, Y) L. - generalize (load_inv _ _ _ _ _ L). - intros (A, (B, (C, D))). - unfold load. rewrite <- X. rewrite zlt_true; auto. - generalize (Y b A); intros [M [P Q]]. - rewrite in_bounds_holds. - rewrite <- D. - decEq. decEq. - apply load_contentmap_agree with - (lo := low((blocks m1) b)) - (hi := high((blocks m1) b)); auto. - omega. omega. + intros. destruct H. + exploit H1; eauto. unfold inject_id. eauto. + unfold val_inj_id. intros [v2 [LOAD EQ]]. + replace (ofs + 0) with ofs in LOAD by omega. congruence. Qed. Theorem store_within_extends: @@ -1348,24 +1563,21 @@ Theorem store_within_extends: store chunk m1 b ofs v = Some m1' -> exists m2', store chunk m2 b ofs v = Some m2' /\ extends m1' m2'. Proof. - intros sz m1 m2 m1' b ofs v (X, Y) STORE. - generalize (store_inv _ _ _ _ _ _ STORE). - intros (A, (B, (C, (D, (x, E))))). - generalize (Y b A); intros [M [P Q]]. - unfold store. rewrite <- X. rewrite zlt_true; auto. - case (in_bounds sz ofs (blocks m2 b)); intro. - exists (unchecked_store sz m2 b ofs v a). - split. auto. + intros. destruct H. + exploit store_mapped_inj; eauto. + unfold val_inj_id; eauto. + unfold meminj_no_overlap, inject_id; intros. + inv H3. inv H4. auto. + unfold inject_id; eauto. + unfold val_inj_id; intros. eauto. + intros [m2' [STORE MINJ]]. + exists m2'; split. + replace (ofs + 0) with ofs in STORE by omega. auto. split. - unfold unchecked_store; simpl. congruence. - intros b' LT. - unfold block_contents_extends, unchecked_store, block_contents_agree. - rewrite E; unfold update; simpl. - case (zeq b' b); intro; simpl. - subst b'. split. omega. split. omega. - apply store_contentmap_agree. auto. - apply Y. rewrite <- D. auto. - omegaContradiction. + rewrite (nextblock_store _ _ _ _ _ _ H0). + rewrite (nextblock_store _ _ _ _ _ _ STORE). + auto. + auto. Qed. Theorem store_outside_extends: @@ -1375,59 +1587,147 @@ Theorem store_outside_extends: store chunk m2 b ofs v = Some m2' -> extends m1 m2'. Proof. - intros sz m1 m2 m2' b ofs v (X, Y) BOUNDS STORE. - generalize (store_inv _ _ _ _ _ _ STORE). - intros (A, (B, (C, (D, (x, E))))). - split. - congruence. - intros b' LT. - rewrite E; unfold update; case (zeq b' b); intro. - subst b'. generalize (Y b LT). intros [M [P Q]]. - red; simpl. split. omega. split. omega. - apply store_contentmap_outside_agree. - assumption. exact BOUNDS. - auto. -Qed. - -(** * Memory extensionality properties *) - -Lemma block_contents_exten: - forall (c1 c2: block_contents), - c1.(low) = c2.(low) -> - c1.(high) = c2.(high) -> - block_contents_agree c1.(low) c1.(high) c1 c2 -> - c1 = c2. -Proof. - intros. caseEq c1; intros lo1 hi1 m1 UO1 EQ1. subst c1. - caseEq c2; intros lo2 hi2 m2 UO2 EQ2. subst c2. - simpl in *. subst lo2 hi2. - assert (m1 = m2). - unfold contentmap. apply extensionality. intro. - case (zlt x lo1); intro. - rewrite UO1. rewrite UO2. auto. tauto. tauto. - case (zlt x hi1); intro. - apply H1. omega. - rewrite UO1. rewrite UO2. auto. tauto. tauto. - subst m2. - assert (UO1 = UO2). - apply proof_irrelevance. - subst UO2. reflexivity. -Qed. - -Theorem mem_exten: - forall m1 m2, - m1.(nextblock) = m2.(nextblock) -> - (forall b, m1.(blocks) b = m2.(blocks) b) -> - m1 = m2. -Proof. - intros. destruct m1 as [map1 nb1 nextpos1]. destruct m2 as [map2 nb2 nextpos2]. - simpl in *. subst nb2. - assert (map1 = map2). apply extensionality. assumption. - assert (nextpos1 = nextpos2). apply proof_irrelevance. + intros. destruct H. split. + rewrite (nextblock_store _ _ _ _ _ _ H1). auto. + eapply store_outside_inj; eauto. + unfold inject_id; intros. inv H3. omega. +Qed. + +Theorem valid_pointer_extends: + forall m1 m2 b ofs, + extends m1 m2 -> valid_pointer m1 b ofs = true -> + valid_pointer m2 b ofs = true. +Proof. + intros. destruct H. + replace ofs with (ofs + 0) by omega. + apply valid_pointer_inj with val_inj_id inject_id m1 b; auto. +Qed. + +(** * The ``less defined than'' relation over memory states *) + +(** A memory state [m1] is less defined than [m2] if, for all addresses, + the value [v1] read in [m1] at this address is less defined than + the value [v2] read in [m2], that is, either [v1 = v2] or [v1 = Vundef]. *) + +Definition val_inj_lessdef (mi: meminj) (v1 v2: val) : Prop := + Val.lessdef v1 v2. + +Definition lessdef (m1 m2: mem) : Prop := + nextblock m1 = nextblock m2 /\ + mem_inj val_inj_lessdef inject_id m1 m2. + +Lemma lessdef_refl: + forall m, lessdef m m. +Proof. + intros; split. auto. + red; intros. unfold inject_id in H. inv H. + exists v1; split. replace (ofs + 0) with ofs by omega. auto. + red. constructor. +Qed. + +Lemma load_lessdef: + forall m1 m2 chunk b ofs v1, + lessdef m1 m2 -> load chunk m1 b ofs = Some v1 -> + exists v2, load chunk m2 b ofs = Some v2 /\ Val.lessdef v1 v2. +Proof. + intros. destruct H. + exploit H1; eauto. unfold inject_id. eauto. + intros [v2 [LOAD INJ]]. exists v2; split. + replace ofs with (ofs + 0) by omega. auto. + auto. +Qed. + +Lemma loadv_lessdef: + forall m1 m2 chunk addr1 addr2 v1, + lessdef m1 m2 -> Val.lessdef addr1 addr2 -> + loadv chunk m1 addr1 = Some v1 -> + exists v2, loadv chunk m2 addr2 = Some v2 /\ Val.lessdef v1 v2. +Proof. + intros. inv H0. + destruct addr2; simpl in *; try discriminate. + eapply load_lessdef; eauto. + simpl in H1; discriminate. +Qed. + +Lemma store_lessdef: + forall m1 m2 chunk b ofs v1 v2 m1', + lessdef m1 m2 -> Val.lessdef v1 v2 -> + store chunk m1 b ofs v1 = Some m1' -> + exists m2', store chunk m2 b ofs v2 = Some m2' /\ lessdef m1' m2'. +Proof. + intros. destruct H. + exploit store_mapped_inj; eauto. + unfold val_inj_lessdef; intros; constructor. + red; unfold inject_id; intros. inv H4. inv H5. auto. + unfold inject_id; eauto. + unfold val_inj_lessdef; intros. + apply Val.load_result_lessdef. eexact H0. + intros [m2' [STORE MINJ]]. + exists m2'; split. replace ofs with (ofs + 0) by omega. auto. + split. + rewrite (nextblock_store _ _ _ _ _ _ H1). + rewrite (nextblock_store _ _ _ _ _ _ STORE). + auto. + auto. +Qed. + +Lemma storev_lessdef: + forall m1 m2 chunk addr1 v1 addr2 v2 m1', + lessdef m1 m2 -> Val.lessdef addr1 addr2 -> Val.lessdef v1 v2 -> + storev chunk m1 addr1 v1 = Some m1' -> + exists m2', storev chunk m2 addr2 v2 = Some m2' /\ lessdef m1' m2'. +Proof. + intros. inv H0. + destruct addr2; simpl in H2; try discriminate. + simpl. eapply store_lessdef; eauto. + discriminate. +Qed. + +Lemma alloc_lessdef: + forall m1 m2 lo hi b1 m1' b2 m2', + lessdef m1 m2 -> alloc m1 lo hi = (m1', b1) -> alloc m2 lo hi = (m2', b2) -> + b1 = b2 /\ lessdef m1' m2'. +Proof. + intros. destruct H. + assert (b1 = b2). + transitivity (nextblock m1). eapply alloc_result; eauto. + symmetry. rewrite H. eapply alloc_result; eauto. + subst b2. split. auto. split. + rewrite (nextblock_alloc _ _ _ _ _ H0). + rewrite (nextblock_alloc _ _ _ _ _ H1). congruence. + eapply alloc_parallel_inj; eauto. + unfold val_inj_lessdef; auto. + unfold inject_id; eauto. + omega. omega. Qed. -(** * Store injections *) +Lemma free_lessdef: + forall m1 m2 b, lessdef m1 m2 -> lessdef (free m1 b) (free m2 b). +Proof. + intros. destruct H. split. + simpl; auto. + eapply free_parallel_inj; eauto. + unfold inject_id. eauto. + unfold inject_id; intros. congruence. +Qed. + +Lemma valid_block_lessdef: + forall m1 m2 b, lessdef m1 m2 -> valid_block m1 b -> valid_block m2 b. +Proof. + unfold valid_block. intros. destruct H. rewrite <- H; auto. +Qed. + +Lemma valid_pointer_lessdef: + forall m1 m2 b ofs, + lessdef m1 m2 -> valid_pointer m1 b ofs = true -> valid_pointer m2 b ofs = true. +Proof. + intros. destruct H. + replace ofs with (ofs + 0) by omega. + apply valid_pointer_inj with val_inj_lessdef inject_id m1 b; auto. +Qed. + +(** ** Memory injections *) (** A memory injection [f] is a function from addresses to either [None] or [Some] of an address and an offset. It defines a correspondence @@ -1437,718 +1737,358 @@ Qed. a sub-block at offset [ofs] of the block [b'] in [m2]. *) -Definition meminj := (block -> option (block * Z))%type. - -Section MEM_INJECT. - -Variable f: meminj. - (** A memory injection defines a relation between values that is the identity relation, except for pointer values which are shifted as prescribed by the memory injection. *) -Inductive val_inject: val -> val -> Prop := +Inductive val_inject (mi: meminj): val -> val -> Prop := | val_inject_int: - forall i, val_inject (Vint i) (Vint i) + forall i, val_inject mi (Vint i) (Vint i) | val_inject_float: - forall f, val_inject (Vfloat f) (Vfloat f) + forall f, val_inject mi (Vfloat f) (Vfloat f) | val_inject_ptr: forall b1 ofs1 b2 ofs2 x, - f b1 = Some (b2, x) -> + mi b1 = Some (b2, x) -> ofs2 = Int.add ofs1 (Int.repr x) -> - val_inject (Vptr b1 ofs1) (Vptr b2 ofs2) + val_inject mi (Vptr b1 ofs1) (Vptr b2 ofs2) | val_inject_undef: forall v, - val_inject Vundef v. + val_inject mi Vundef v. Hint Resolve val_inject_int val_inject_float val_inject_ptr -val_inject_undef. + val_inject_undef. -Inductive val_list_inject: list val -> list val-> Prop:= +Inductive val_list_inject (mi: meminj): list val -> list val-> Prop:= | val_nil_inject : - val_list_inject nil nil + val_list_inject mi nil nil | val_cons_inject : forall v v' vl vl' , - val_inject v v' -> val_list_inject vl vl'-> - val_list_inject (v::vl) (v':: vl'). - -Inductive val_content_inject: memory_size -> val -> val -> Prop := - | val_content_inject_base: - forall sz v1 v2, - val_inject v1 v2 -> - val_content_inject sz v1 v2 - | val_content_inject_8: - forall n1 n2, - Int.cast8unsigned n1 = Int.cast8unsigned n2 -> - val_content_inject Size8 (Vint n1) (Vint n2) - | val_content_inject_16: - forall n1 n2, - Int.cast16unsigned n1 = Int.cast16unsigned n2 -> - val_content_inject Size16 (Vint n1) (Vint n2) - | val_content_inject_32: - forall f1 f2, - Float.singleoffloat f1 = Float.singleoffloat f2 -> - val_content_inject Size32 (Vfloat f1) (Vfloat f2). + val_inject mi v v' -> val_list_inject mi vl vl'-> + val_list_inject mi (v :: vl) (v' :: vl'). -Hint Resolve val_content_inject_base. - -Inductive content_inject: content -> content -> Prop := - | content_inject_undef: - forall c, - content_inject Undef c - | content_inject_datum8: - forall v1 v2, - val_content_inject Size8 v1 v2 -> - content_inject (Datum8 v1) (Datum8 v2) - | content_inject_datum16: - forall v1 v2, - val_content_inject Size16 v1 v2 -> - content_inject (Datum16 v1) (Datum16 v2) - | content_inject_datum32: - forall v1 v2, - val_content_inject Size32 v1 v2 -> - content_inject (Datum32 v1) (Datum32 v2) - | content_inject_datum64: - forall v1 v2, - val_content_inject Size64 v1 v2 -> - content_inject (Datum64 v1) (Datum64 v2) - | content_inject_cont: - content_inject Cont Cont. - -Hint Resolve content_inject_undef content_inject_datum8 -content_inject_datum16 content_inject_datum32 content_inject_datum64 -content_inject_cont. - -Definition contentmap_inject (c1 c2: contentmap) (lo hi delta: Z) : Prop := - forall x, lo <= x < hi -> - content_inject (c1 x) (c2 (x + delta)). - -(** A block contents [c1] injects into another block content [c2] at - offset [delta] if the contents of [c1] at all valid offsets - correspond to the contents of [c2] at the same offsets shifted by [delta]. - Some additional conditions are imposed to guard against arithmetic - overflow in address computations. *) - -Record block_contents_inject (c1 c2: block_contents) (delta: Z) : Prop := - mk_block_contents_inject { - bci_range1: Int.min_signed <= delta <= Int.max_signed; - bci_range2: delta = 0 \/ - (Int.min_signed <= c2.(low) /\ c2.(high) <= Int.max_signed); - bci_lowhigh:forall x, c1.(low) <= x < c1.(high) -> - c2.(low) <= x+delta < c2.(high) ; - bci_contents: - contentmap_inject c1.(contents) c2.(contents) c1.(low) c1.(high) delta - }. +Hint Resolve val_nil_inject val_cons_inject. (** A memory state [m1] injects into another memory state [m2] via the memory injection [f] if the following conditions hold: +- loads in [m1] must have matching loads in [m2] in the sense + of the [mem_inj] predicate; - unallocated blocks in [m1] must be mapped to [None] by [f]; -- if [f b = Some(b', delta)], [b'] must be valid in [m2] and - the contents of [b] in [m1] must inject into the contents of [b'] in [m2] - with offset [delta]; -- distinct blocks in [m1] cannot be mapped to overlapping sub-blocks in [m2]. +- if [f b = Some(b', delta)], [b'] must be valid in [m2]; +- distinct blocks in [m1] are mapped to non-overlapping sub-blocks in [m2]; +- the sizes of [m2]'s blocks are representable with signed machine integers; +- the offsets [delta] are representable with signed machine integers. *) -Record mem_inject (m1 m2: mem) : Prop := +Record mem_inject (f: meminj) (m1 m2: mem) : Prop := mk_mem_inject { + mi_inj: + mem_inj val_inject f m1 m2; mi_freeblocks: - forall b, b >= m1.(nextblock) -> f b = None; + forall b, ~(valid_block m1 b) -> f b = None; mi_mappedblocks: + forall b b' delta, f b = Some(b', delta) -> valid_block m2 b'; + mi_no_overlap: + meminj_no_overlap f m1; + mi_range_1: forall b b' delta, f b = Some(b', delta) -> - b' < m2.(nextblock) /\ - block_contents_inject (m1.(blocks) b) - (m2.(blocks) b') - delta; - mi_no_overlap: - forall b1 b2 b1' b2' delta1 delta2, - b1 <> b2 -> - f b1 = Some (b1', delta1) -> - f b2 = Some (b2', delta2) -> - b1' <> b2' - \/ (forall x1 x2, low_bound m1 b1 <= x1 < high_bound m1 b1 -> - low_bound m1 b2 <= x2 < high_bound m1 b2 -> - x1+delta1 <> x2+delta2) - }. + Int.min_signed <= delta <= Int.max_signed; + mi_range_2: + forall b b' delta, + f b = Some(b', delta) -> + delta = 0 \/ (Int.min_signed <= low_bound m2 b' /\ high_bound m2 b' <= Int.max_signed) + }. + (** The following lemmas establish the absence of machine integer overflow during address computations. *) -Lemma size_mem_pos: forall sz, size_mem sz > 0. -Proof. destruct sz; simpl; omega. Qed. - -Lemma size_chunk_pos: forall chunk, size_chunk chunk > 0. -Proof. intros. unfold size_chunk. apply size_mem_pos. Qed. - Lemma address_inject: - forall m1 m2 chunk b1 ofs1 b2 ofs2 x, - mem_inject m1 m2 -> - (m1.(blocks) b1).(low) <= Int.signed ofs1 -> - Int.signed ofs1 + size_chunk chunk <= (m1.(blocks) b1).(high) -> - f b1 = Some (b2, x) -> - ofs2 = Int.add ofs1 (Int.repr x) -> - Int.signed ofs2 = Int.signed ofs1 + x. + forall f m1 m2 chunk b1 ofs1 b2 delta, + mem_inject f m1 m2 -> + valid_access m1 chunk b1 (Int.signed ofs1) -> + f b1 = Some (b2, delta) -> + Int.signed (Int.add ofs1 (Int.repr delta)) = Int.signed ofs1 + delta. Proof. - intros. - generalize (size_chunk_pos chunk). intro. - generalize (mi_mappedblocks m1 m2 H _ _ _ H2). intros [C D]. - inversion D. - elim bci_range4 ; intro. - (**x=0**) - subst x . rewrite Zplus_0_r. rewrite Int.add_zero in H3. - subst ofs2 ; auto . - (**x<>0**) - rewrite H3. rewrite Int.add_signed. repeat rewrite Int.signed_repr. - auto. auto. - assert (low (blocks m1 b1) <= Int.signed ofs1 < high (blocks m1 b1)). - omega. - generalize (bci_lowhigh0 (Int.signed ofs1) H6). omega. - auto. + intros. inversion H. + elim (mi_range_4 _ _ _ H1); intro. + (* delta = 0 *) + subst delta. change (Int.repr 0) with Int.zero. + rewrite Int.add_zero. omega. + (* delta <> 0 *) + rewrite Int.add_signed. + repeat rewrite Int.signed_repr. auto. + eauto. + assert (valid_access m2 chunk b2 (Int.signed ofs1 + delta)). + eapply valid_access_inj; eauto. + inv H3. generalize (size_chunk_pos chunk); omega. + eauto. Qed. Lemma valid_pointer_inject_no_overflow: - forall m1 m2 b ofs b' x, - mem_inject m1 m2 -> + forall f m1 m2 b ofs b' x, + mem_inject f m1 m2 -> valid_pointer m1 b (Int.signed ofs) = true -> f b = Some(b', x) -> Int.min_signed <= Int.signed ofs + Int.signed (Int.repr x) <= Int.max_signed. Proof. - intros. unfold valid_pointer in H0. - destruct (zlt b (nextblock m1)); try discriminate. - destruct (zle (low (blocks m1 b)) (Int.signed ofs)); try discriminate. - destruct (zlt (Int.signed ofs) (high (blocks m1 b))); try discriminate. - inversion H. generalize (mi_mappedblocks0 _ _ _ H1). - intros [A B]. inversion B. - elim bci_range4 ; intro. - (**x=0**) - rewrite Int.signed_repr ; auto. - subst x . rewrite Zplus_0_r. apply Int.signed_range . - (**x<>0**) - generalize (bci_lowhigh0 _ (conj z0 z1)). intro. - rewrite Int.signed_repr. omega. auto. -Qed. - -(** Relation between injections and loads. *) - -Lemma check_cont_inject: - forall c1 c2 lo hi delta, - contentmap_inject c1 c2 lo hi delta -> - forall n p, - lo <= p -> p + Z_of_nat n <= hi -> - check_cont n p c1 = true -> - check_cont n (p + delta) c2 = true. -Proof. - induction n. - intros. simpl. reflexivity. - simpl check_cont. rewrite inj_S. intros p H0 H1. - assert (lo <= p < hi). omega. - generalize (H p H2). intro. inversion H3; intros; try discriminate. - replace (p + delta + 1) with ((p + 1) + delta). - apply IHn. omega. omega. auto. + intros. inv H. rewrite valid_pointer_valid_access in H0. + assert (valid_access m2 Mint8unsigned b' (Int.signed ofs + x)). + eapply valid_access_inj; eauto. + inv H. change (size_chunk Mint8unsigned) with 1 in H4. + rewrite Int.signed_repr; eauto. + exploit mi_range_4; eauto. intros [A | [A B]]. + subst x. rewrite Zplus_0_r. apply Int.signed_range. omega. Qed. -Hint Resolve check_cont_inject. - -Lemma getN_inject: - forall c1 c2 lo hi delta, - contentmap_inject c1 c2 lo hi delta -> - forall n p, - lo <= p -> p + Z_of_nat n < hi -> - content_inject (getN n p c1) (getN n (p + delta) c2). -Proof. - intros. simpl in H1. - assert (lo <= p < hi). omega. - unfold getN. - caseEq (check_cont n (p + 1) c1); intro. - replace (check_cont n (p + delta + 1) c2) with true. - apply H. assumption. - symmetry. replace (p + delta + 1) with ((p + 1) + delta). - eapply check_cont_inject; eauto. - omega. omega. omega. - constructor. -Qed. - -Hint Resolve getN_inject. - -Definition ztonat (z:Z): nat:= -match z with -| Z0 => O -| Zpos p => (nat_of_P p) -| Zneg p =>O -end. - -Lemma load_contents_inject: - forall sz c1 c2 lo hi delta p, - contentmap_inject c1 c2 lo hi delta -> - lo <= p -> p + size_mem sz <= hi -> - val_content_inject sz (load_contents sz c1 p) (load_contents sz c2 (p + delta)). -Proof. -intros. -assert (content_inject (getN (ztonat (size_mem sz)-1) p c1) -(getN (ztonat(size_mem sz)-1) (p + delta) c2)). -induction sz; assert (lo<= p< hi); simpl in H1; try omega; -apply getN_inject with lo hi; try assumption; simpl ; try omega. -induction sz ; simpl; inversion H2; auto. -Qed. - -Hint Resolve load_contents_inject. - -Lemma load_result_inject: - forall chunk v1 v2, - val_content_inject (mem_chunk chunk) v1 v2 -> - val_inject (Val.load_result chunk v1) (Val.load_result chunk v2). -Proof. -intros. -destruct chunk; simpl in H; inversion H; simpl; auto; -try (inversion H0; simpl; auto; fail). -replace (Int.cast8signed n2) with (Int.cast8signed n1). constructor. -apply Int.cast8_signed_equal_if_unsigned_equal; auto. -rewrite H0; constructor. -replace (Int.cast16signed n2) with (Int.cast16signed n1). constructor. -apply Int.cast16_signed_equal_if_unsigned_equal; auto. -rewrite H0; constructor. -inversion H0; simpl; auto. -apply val_inject_ptr with x; auto. -Qed. - -Lemma in_bounds_inject: - forall chunk c1 c2 delta p, - block_contents_inject c1 c2 delta -> - c1.(low) <= p /\ p + size_chunk chunk <= c1.(high) -> - c2.(low) <= p + delta /\ (p + delta) + size_chunk chunk <= c2.(high). +Lemma valid_pointer_inject: + forall f m1 m2 b ofs b' ofs', + mem_inject f m1 m2 -> + valid_pointer m1 b (Int.signed ofs) = true -> + val_inject f (Vptr b ofs) (Vptr b' ofs') -> + valid_pointer m2 b' (Int.signed ofs') = true. Proof. - intros. - inversion H. - generalize (size_chunk_pos chunk); intro. - assert (low c1 <= p + size_chunk chunk - 1 < high c1). - omega. - generalize (bci_lowhigh0 _ H2). intro. - assert (low c1 <= p < high c1). - omega. - generalize (bci_lowhigh0 _ H4). intro. - omega. + intros. inv H1. + exploit valid_pointer_inject_no_overflow; eauto. intro NOOV. + inv H. rewrite Int.add_signed. rewrite Int.signed_repr; auto. + rewrite Int.signed_repr; eauto. + eapply valid_pointer_inj; eauto. Qed. -Lemma block_cont_val: -forall c1 c2 delta p sz, -block_contents_inject c1 c2 delta -> -c1.(low) <= p -> p + size_mem sz <= c1.(high) -> - val_content_inject sz (load_contents sz c1.(contents) p) - (load_contents sz c2.(contents) (p + delta)). -Proof. -intros. -inversion H . -apply load_contents_inject with c1.(low) c1.(high) ;assumption. -Qed. +(** Relation between injections and loads. *) Lemma load_inject: - forall m1 m2 chunk b1 ofs b2 delta v1, - mem_inject m1 m2 -> + forall f m1 m2 chunk b1 ofs b2 delta v1, + mem_inject f m1 m2 -> load chunk m1 b1 ofs = Some v1 -> f b1 = Some (b2, delta) -> - exists v2, load chunk m2 b2 (ofs + delta) = Some v2 /\ val_inject v1 v2. + exists v2, load chunk m2 b2 (ofs + delta) = Some v2 /\ val_inject f v1 v2. Proof. - intros. - generalize (load_inv _ _ _ _ _ H0). intros [A [B [C D]]]. - inversion H. - generalize (mi_mappedblocks0 _ _ _ H1). intros [U V]. - inversion V. - exists (Val.load_result chunk (load_contents (mem_chunk chunk) - (m2.(blocks) b2).(contents) (ofs+delta))). - split. - unfold load. - generalize (size_chunk_pos chunk); intro. - rewrite zlt_true. rewrite in_bounds_holds. auto. - assert (low (blocks m1 b1) <= ofs < high (blocks m1 b1)). - omega. - generalize (bci_lowhigh0 _ H3). tauto. - assert (low (blocks m1 b1) <= ofs + size_chunk chunk - 1 < high(blocks m1 b1)). - omega. - generalize (bci_lowhigh0 _ H3). omega. - assumption. - rewrite <- D. apply load_result_inject. - eapply load_contents_inject; eauto. + intros. inversion H. + eapply mi_inj0; eauto. Qed. Lemma loadv_inject: - forall m1 m2 chunk a1 a2 v1, - mem_inject m1 m2 -> + forall f m1 m2 chunk a1 a2 v1, + mem_inject f m1 m2 -> loadv chunk m1 a1 = Some v1 -> - val_inject a1 a2 -> - exists v2, loadv chunk m2 a2 = Some v2 /\ val_inject v1 v2. + val_inject f a1 a2 -> + exists v2, loadv chunk m2 a2 = Some v2 /\ val_inject f v1 v2. Proof. - intros. - induction H1 ; simpl in H0 ; try discriminate H0. - simpl. - replace (Int.signed ofs2) with (Int.signed ofs1 + x). - apply load_inject with m1 b1 ; assumption. - symmetry. generalize (load_inv _ _ _ _ _ H0). intros [A [B [C D]]]. - apply address_inject with m1 m2 chunk b1 b2; auto. + intros. inv H1; simpl in H0; try discriminate. + exploit load_inject; eauto. intros [v2 [LOAD INJ]]. + exists v2; split; auto. simpl. + replace (Int.signed (Int.add ofs1 (Int.repr x))) + with (Int.signed ofs1 + x). + auto. symmetry. eapply address_inject; eauto with mem. Qed. (** Relation between injections and stores. *) -Lemma set_cont_inject: - forall c1 c2 lo hi delta, - contentmap_inject c1 c2 lo hi delta -> - forall n p, - lo <= p -> p + Z_of_nat n <= hi -> - contentmap_inject (set_cont n p c1) (set_cont n (p + delta) c2) lo hi delta. -Proof. -induction n. intros. simpl. assumption. -intros. simpl. unfold contentmap_inject. -intros p2 Hp2. unfold update. -case (zeq p2 p); intro. -subst p2. rewrite zeq_true. constructor. -rewrite zeq_false. replace (p + delta + 1) with ((p + 1) + delta). -apply IHn. omega. rewrite inj_S in H1. omega. assumption. -omega. omega. -Qed. - -Lemma setN_inject: - forall c1 c2 lo hi delta n p v1 v2, - contentmap_inject c1 c2 lo hi delta -> - content_inject v1 v2 -> - lo <= p -> p + Z_of_nat n < hi -> - contentmap_inject (setN n p v1 c1) (setN n (p + delta) v2 c2) - lo hi delta. -Proof. - intros. unfold setN. red; intros. - unfold update. - case (zeq x p); intro. - subst p. rewrite zeq_true. assumption. - rewrite zeq_false. - replace (p + delta + 1) with ((p + 1) + delta). - apply set_cont_inject with lo hi. - assumption. omega. omega. assumption. omega. - omega. -Qed. - -Lemma store_contents_inject: - forall c1 c2 lo hi delta sz p v1 v2, - contentmap_inject c1 c2 lo hi delta -> - val_content_inject sz v1 v2 -> - lo <= p -> p + size_mem sz <= hi -> - contentmap_inject (store_contents sz c1 p v1) - (store_contents sz c2 (p + delta) v2) - lo hi delta. -Proof. - intros. - destruct sz; simpl in *; apply setN_inject; auto; simpl; omega. -Qed. - -Lemma set_cont_outside1 : - forall n p m q , - (forall x , p <= x < p + Z_of_nat n -> x <> q) -> - (set_cont n p m) q = m q. -Proof. - induction n; intros; simpl. - auto. - rewrite inj_S in H. rewrite update_o. apply IHn. - intros. apply H. omega. - apply H. omega. -Qed. - -Lemma set_cont_outside_inject: - forall c1 c2 lo hi delta, - contentmap_inject c1 c2 lo hi delta -> - forall n p, - (forall x1 x2, p <= x1 < p + Z_of_nat n -> - lo <= x2 < hi -> - x1 <> x2 + delta) -> - contentmap_inject c1 (set_cont n p c2) lo hi delta. -Proof. - unfold contentmap_inject. intros. - rewrite set_cont_outside1. apply H. assumption. - intros. apply H0. auto. auto. -Qed. - -Lemma setN_outside_inject: - forall n c1 c2 lo hi delta p v, - contentmap_inject c1 c2 lo hi delta -> - (forall x1 x2, p <= x1 < p + Z_of_nat (S n) -> - lo <= x2 < hi -> - x1 <> x2 + delta) -> - contentmap_inject c1 (setN n p v c2) lo hi delta. -Proof. - intros. unfold setN. red; intros. rewrite update_o. - apply set_cont_outside_inject with lo hi. auto. - intros. apply H0. rewrite inj_S. omega. auto. auto. - apply H0. rewrite inj_S. omega. auto. -Qed. +Inductive val_content_inject (f: meminj): memory_chunk -> val -> val -> Prop := + | val_content_inject_base: + forall chunk v1 v2, + val_inject f v1 v2 -> + val_content_inject f chunk v1 v2 + | val_content_inject_8: + forall chunk n1 n2, + chunk = Mint8unsigned \/ chunk = Mint8signed -> + Int.cast8unsigned n1 = Int.cast8unsigned n2 -> + val_content_inject f chunk (Vint n1) (Vint n2) + | val_content_inject_16: + forall chunk n1 n2, + chunk = Mint16unsigned \/ chunk = Mint16signed -> + Int.cast16unsigned n1 = Int.cast16unsigned n2 -> + val_content_inject f chunk (Vint n1) (Vint n2) + | val_content_inject_32: + forall f1 f2, + Float.singleoffloat f1 = Float.singleoffloat f2 -> + val_content_inject f Mfloat32 (Vfloat f1) (Vfloat f2). -Lemma store_contents_outside_inject: - forall c1 c2 lo hi delta sz p v, - contentmap_inject c1 c2 lo hi delta -> - (forall x1 x2, p <= x1 < p + size_mem sz -> - lo <= x2 < hi -> - x1 <> x2 + delta)-> - contentmap_inject c1 (store_contents sz c2 p v) lo hi delta. -Proof. - intros c1 c2 lo hi delta sz. generalize (size_mem_pos sz) . intro . - induction sz ;intros ;simpl ; apply setN_outside_inject ; assumption . -Qed. +Hint Resolve val_content_inject_base. -Lemma store_mapped_inject_1: - forall chunk m1 b1 ofs v1 n1 m2 b2 delta v2, - mem_inject m1 m2 -> +Lemma load_result_inject: + forall f chunk v1 v2 chunk', + val_content_inject f chunk v1 v2 -> + size_chunk chunk = size_chunk chunk' -> + val_inject f (Val.load_result chunk' v1) (Val.load_result chunk' v2). +Proof. + intros. inv H; simpl. + inv H1; destruct chunk'; simpl; econstructor; eauto. + + elim H1; intro; subst chunk; + destruct chunk'; simpl in H0; try discriminate; simpl. + replace (Int.cast8signed n1) with (Int.cast8signed n2). + constructor. apply Int.cast8_signed_equal_if_unsigned_equal; auto. + rewrite H2. constructor. + replace (Int.cast8signed n1) with (Int.cast8signed n2). + constructor. apply Int.cast8_signed_equal_if_unsigned_equal; auto. + rewrite H2. constructor. + + elim H1; intro; subst chunk; + destruct chunk'; simpl in H0; try discriminate; simpl. + replace (Int.cast16signed n1) with (Int.cast16signed n2). + constructor. apply Int.cast16_signed_equal_if_unsigned_equal; auto. + rewrite H2. constructor. + replace (Int.cast16signed n1) with (Int.cast16signed n2). + constructor. apply Int.cast16_signed_equal_if_unsigned_equal; auto. + rewrite H2. constructor. + + destruct chunk'; simpl in H0; try discriminate; simpl. + constructor. rewrite H1; constructor. +Qed. + +Lemma store_mapped_inject_1 : + forall f chunk m1 b1 ofs v1 n1 m2 b2 delta v2, + mem_inject f m1 m2 -> store chunk m1 b1 ofs v1 = Some n1 -> f b1 = Some (b2, delta) -> - val_content_inject (mem_chunk chunk) v1 v2 -> + val_content_inject f chunk v1 v2 -> exists n2, store chunk m2 b2 (ofs + delta) v2 = Some n2 - /\ mem_inject n1 n2. -Proof. -intros. -generalize (size_chunk_pos chunk); intro SIZEPOS. -generalize (store_inv _ _ _ _ _ _ H0). -intros [A [B [C [D [P E]]]]]. -inversion H. -generalize (mi_mappedblocks0 _ _ _ H1). intros [U V]. -inversion V. -generalize (in_bounds_inject _ _ _ _ _ V (conj B C)). intro BND. -exists (unchecked_store chunk m2 b2 (ofs+delta) v2 BND). -split. unfold store. -rewrite zlt_true; auto. -case (in_bounds chunk (ofs + delta) (blocks m2 b2)); intro. -assert (a = BND). apply proof_irrelevance. congruence. -omegaContradiction. -constructor. -intros. apply mi_freeblocks0. rewrite <- D. assumption. -intros. generalize (mi_mappedblocks0 b b' delta0 H3). -intros [W Y]. split. simpl. auto. -rewrite E; simpl. unfold update. -(* Cas 1: memes blocs b = b1 b'= b2 *) -case (zeq b b1); intro. -subst b. assert (b'= b2). congruence. subst b'. -assert (delta0 = delta). congruence. subst delta0. -rewrite zeq_true. inversion Y. constructor; simpl; auto. -apply store_contents_inject; auto. -(* Cas 2: blocs differents dans m1 mais mappes sur le meme bloc de m2 *) -case (zeq b' b2); intro. -subst b'. -inversion Y. constructor; simpl; auto. -generalize (store_contents_outside_inject _ _ _ _ _ (mem_chunk chunk) - (ofs+delta) v2 bci_contents1). -intros. -apply H4. -elim (mi_no_overlap0 b b1 b2 b2 delta0 delta n H3 H1). -tauto. -unfold high_bound, low_bound. intros. -apply sym_not_equal. replace x1 with ((x1 - delta) + delta). -apply H5. assumption. unfold size_chunk in C. omega. omega. -(* Cas 3: blocs differents dans m1 et dans m2 *) -auto. - -unfold high_bound, low_bound. -rewrite E; simpl; intros. -unfold high_bound, low_bound in mi_no_overlap0. -unfold update. -case (zeq b0 b1). -intro. subst b1. simpl. -rewrite zeq_false; auto. -intro. case (zeq b3 b1); intro. -subst b3. simpl. auto. -auto. + /\ mem_inject f n1 n2. +Proof. + intros. inversion H. + exploit store_mapped_inj; eauto. + intros; constructor. + intros. apply load_result_inject with chunk; eauto. + intros [n2 [STORE MINJ]]. + exists n2; split. auto. constructor. + (* inj *) + auto. + (* freeblocks *) + intros. apply mi_freeblocks0. red; intro. elim H3. eauto with mem. + (* mappedblocks *) + intros. eauto with mem. + (* no_overlap *) + red; intros. + repeat rewrite (low_bound_store _ _ _ _ _ _ H0). + repeat rewrite (high_bound_store _ _ _ _ _ _ H0). + eapply mi_no_overlap0; eauto. + (* range *) + auto. + intros. + repeat rewrite (low_bound_store _ _ _ _ _ _ STORE). + repeat rewrite (high_bound_store _ _ _ _ _ _ STORE). + eapply mi_range_4; eauto. Qed. Lemma store_mapped_inject: - forall chunk m1 b1 ofs v1 n1 m2 b2 delta v2, - mem_inject m1 m2 -> + forall f chunk m1 b1 ofs v1 n1 m2 b2 delta v2, + mem_inject f m1 m2 -> store chunk m1 b1 ofs v1 = Some n1 -> f b1 = Some (b2, delta) -> - val_inject v1 v2 -> + val_inject f v1 v2 -> exists n2, store chunk m2 b2 (ofs + delta) v2 = Some n2 - /\ mem_inject n1 n2. + /\ mem_inject f n1 n2. Proof. intros. eapply store_mapped_inject_1; eauto. Qed. Lemma store_unmapped_inject: - forall chunk m1 b1 ofs v1 n1 m2, - mem_inject m1 m2 -> + forall f chunk m1 b1 ofs v1 n1 m2, + mem_inject f m1 m2 -> store chunk m1 b1 ofs v1 = Some n1 -> f b1 = None -> - mem_inject n1 m2. -Proof. -intros. -inversion H. -generalize (store_inv _ _ _ _ _ _ H0). -intros [A [B [C [D [P E]]]]]. -constructor. -rewrite D. assumption. -intros. elim (mi_mappedblocks0 _ _ _ H2); intros. -split. auto. -rewrite E; unfold update. -rewrite zeq_false. assumption. -congruence. -intros. -assert (forall b, low_bound n1 b = low_bound m1 b). - intros. unfold low_bound; rewrite E; unfold update. - case (zeq b b1); intros. subst b1; reflexivity. reflexivity. -assert (forall b, high_bound n1 b = high_bound m1 b). - intros. unfold high_bound; rewrite E; unfold update. - case (zeq b b1); intros. subst b1; reflexivity. reflexivity. -repeat rewrite H5. repeat rewrite H6. auto. + mem_inject f n1 m2. +Proof. + intros. inversion H. + constructor. + (* inj *) + eapply store_unmapped_inj; eauto. + (* freeblocks *) + intros. apply mi_freeblocks0. red; intros; elim H2; eauto with mem. + (* mappedblocks *) + intros. eapply mi_mappedblocks0; eauto with mem. + (* no_overlap *) + red; intros. + repeat rewrite (low_bound_store _ _ _ _ _ _ H0). + repeat rewrite (high_bound_store _ _ _ _ _ _ H0). + eapply mi_no_overlap0; eauto. + (* range *) + auto. auto. Qed. Lemma storev_mapped_inject_1: - forall chunk m1 a1 v1 n1 m2 a2 v2, - mem_inject m1 m2 -> + forall f chunk m1 a1 v1 n1 m2 a2 v2, + mem_inject f m1 m2 -> storev chunk m1 a1 v1 = Some n1 -> - val_inject a1 a2 -> - val_content_inject (mem_chunk chunk) v1 v2 -> + val_inject f a1 a2 -> + val_content_inject f chunk v1 v2 -> exists n2, - storev chunk m2 a2 v2 = Some n2 /\ mem_inject n1 n2. + storev chunk m2 a2 v2 = Some n2 /\ mem_inject f n1 n2. Proof. - intros. destruct a1; simpl in H0; try discriminate. - inversion H1. subst b. - simpl. replace (Int.signed ofs2) with (Int.signed i + x). + intros. inv H1; simpl in H0; try discriminate. + simpl. replace (Int.signed (Int.add ofs1 (Int.repr x))) + with (Int.signed ofs1 + x). eapply store_mapped_inject_1; eauto. - symmetry. generalize (store_inv _ _ _ _ _ _ H0). intros [A [B [C [D [P E]]]]]. - apply address_inject with m1 m2 chunk b1 b2; auto. + symmetry. eapply address_inject; eauto with mem. Qed. Lemma storev_mapped_inject: - forall chunk m1 a1 v1 n1 m2 a2 v2, - mem_inject m1 m2 -> + forall f chunk m1 a1 v1 n1 m2 a2 v2, + mem_inject f m1 m2 -> storev chunk m1 a1 v1 = Some n1 -> - val_inject a1 a2 -> - val_inject v1 v2 -> + val_inject f a1 a2 -> + val_inject f v1 v2 -> exists n2, - storev chunk m2 a2 v2 = Some n2 /\ mem_inject n1 n2. + storev chunk m2 a2 v2 = Some n2 /\ mem_inject f n1 n2. Proof. intros. eapply storev_mapped_inject_1; eauto. Qed. (** Relation between injections and [free] *) -Lemma free_first_inject : - forall m1 m2 b, - mem_inject m1 m2 -> - mem_inject (free m1 b) m2. -Proof. - intros. inversion H. constructor . auto. - simpl. intros. - generalize (mi_mappedblocks0 b0 b' delta H0). - intros [A B] . split. assumption . unfold update. - case (zeq b0 b); intro. inversion B. constructor; simpl; auto. - intros. omega. - unfold contentmap_inject. - intros. omegaContradiction. - auto. intros. - unfold free . unfold low_bound , high_bound. simpl. unfold update. - case (zeq b1 b);intro. simpl. - right. intros. omegaContradiction. - case (zeq b2 b);intro. simpl. - right . intros. omegaContradiction. - unfold low_bound, high_bound in mi_no_overlap0. auto. -Qed. - -Lemma free_first_list_inject : - forall l m1 m2, - mem_inject m1 m2 -> - mem_inject (free_list m1 l) m2. -Proof. - induction l; simpl; intros. - auto. - apply free_first_inject. auto. -Qed. - -Lemma free_snd_inject: - forall m1 m2 b, - (forall b1 delta, f b1 = Some(b, delta) -> - low_bound m1 b1 >= high_bound m1 b1) -> - mem_inject m1 m2 -> - mem_inject m1 (free m2 b). -Proof. - intros. inversion H0. constructor. auto. - simpl. intros. - generalize (mi_mappedblocks0 b0 b' delta H1). - intros [A B] . split. assumption . - inversion B. unfold update. - case (zeq b' b); intro. - subst b'. generalize (H _ _ H1). unfold low_bound, high_bound; intro. - constructor. auto. elim bci_range4 ; intro. - (**delta=0**) - left ; auto . - (** delta<>0**) - right . - simpl. compute. split; intro; congruence. - intros. omegaContradiction. - red; intros. omegaContradiction. - auto. - auto. -Qed. - -Lemma bounds_free_block: - forall m1 b m1' , free m1 b = m1' -> - low_bound m1' b >= high_bound m1' b. +Lemma meminj_no_overlap_free: + forall mi m b, + meminj_no_overlap mi m -> + meminj_no_overlap mi (free m b). Proof. - intros. unfold free in H. - rewrite<- H . unfold low_bound , high_bound . - simpl . rewrite update_s. simpl. omega. + intros; red; intros. + assert (low_bound (free m b) b >= high_bound (free m b) b). + rewrite low_bound_free_same; rewrite high_bound_free_same; auto. + omega. + destruct (eq_block b1 b); destruct (eq_block b2 b); subst; auto. + repeat (rewrite low_bound_free; auto). + repeat (rewrite high_bound_free; auto). Qed. -Lemma free_empty_bounds: - forall l m1 , - let m1' := free_list m1 l in - (forall b, In b l -> low_bound m1' b >= high_bound m1' b). +Lemma meminj_no_overlap_free_list: + forall mi m bl, + meminj_no_overlap mi m -> + meminj_no_overlap mi (free_list m bl). Proof. - induction l . intros . inversion H. - intros. - generalize (in_inv H). - intro . elim H0. intro . subst b. simpl in m1' . - generalize ( bounds_free_block - (fold_right (fun (b : block) (m : mem) => free m b) m1 l) a m1') . - intros. apply H1. auto . intros. simpl in m1'. unfold m1' . - unfold low_bound , high_bound . simpl . - unfold update; case (zeq b a); intro; simpl. - omega . - unfold low_bound , high_bound in IHl . auto. -Qed. + induction bl; simpl; intros. auto. + apply meminj_no_overlap_free. auto. +Qed. Lemma free_inject: - forall m1 m2 l b, + forall f m1 m2 l b, (forall b1 delta, f b1 = Some(b, delta) -> In b1 l) -> - mem_inject m1 m2 -> - mem_inject (free_list m1 l) (free m2 b). -Proof. - intros. apply free_snd_inject. - intros. apply free_empty_bounds. apply H with delta. auto. - apply free_first_list_inject. auto. -Qed. - -Lemma contents_init_data_inject: - forall id, contentmap_inject (contents_init_data 0 id) (contents_init_data 0 id) 0 (size_init_data_list id) 0. -Proof. - intro id0. - set (sz0 := size_init_data_list id0). - assert (forall id pos, - 0 <= pos -> pos + size_init_data_list id <= sz0 -> - contentmap_inject (contents_init_data pos id) (contents_init_data pos id) 0 sz0 0). - induction id; simpl; intros. - red; intros; constructor. - assert (forall n dt, - size_init_data a = 1 + Z_of_nat n -> - content_inject dt dt -> - contentmap_inject (setN n pos dt (contents_init_data (pos + size_init_data a) id)) - (setN n pos dt (contents_init_data (pos + size_init_data a) id)) - 0 sz0 0). - intros. set (pos' := pos) in |- * at 3. replace pos' with (pos + 0). - apply setN_inject. apply IHid. omega. omega. auto. auto. - generalize (size_init_data_list_pos id). omega. unfold pos'; omega. - destruct a; - try (apply H1; [reflexivity|repeat constructor]). - apply IHid. generalize (Zmax2 z 0). omega. simpl in H0; omega. - apply IHid. omega. simpl size_init_data in H0. omega. - apply H. omega. unfold sz0. omega. -Qed. - -End MEM_INJECT. - -Hint Resolve val_inject_int val_inject_float val_inject_ptr val_inject_undef. -Hint Resolve val_nil_inject val_cons_inject. + mem_inject f m1 m2 -> + mem_inject f (free_list m1 l) (free m2 b). +Proof. + intros. inversion H0. constructor. + (* inj *) + apply free_right_inj. apply free_list_left_inj. auto. + intros; red; intros. + elim (valid_access_free_list_inv _ _ _ _ _ H2); intros. + elim H3; eauto. + (* freeblocks *) + intros. apply mi_freeblocks0. red; intro; elim H1. + apply valid_block_free_list_1; auto. + (* mappedblocks *) + intros. apply valid_block_free_1. eauto. + (* overlap *) + apply meminj_no_overlap_free_list; auto. + (* range *) + auto. + intros. destruct (eq_block b' b). subst b'. + rewrite low_bound_free_same; rewrite high_bound_free_same. + right; compute; intuition congruence. + rewrite low_bound_free; auto. rewrite high_bound_free; auto. + eauto. +Qed. (** Monotonicity properties of memory injections. *) @@ -2160,16 +2100,11 @@ Lemma inject_incr_refl : Proof. unfold inject_incr . intros. left . auto . Qed. Lemma inject_incr_trans : - forall f1 f2 f3 , + forall f1 f2 f3, inject_incr f1 f2 -> inject_incr f2 f3 -> inject_incr f1 f3 . Proof . - unfold inject_incr . intros . - generalize (H b) . intro . generalize (H0 b) . intro . - elim H1 ; elim H2 ; intros. - rewrite H3 in H4 . left . auto . - rewrite H3 in H4 . right . auto . - right ; auto . - right ; auto . + unfold inject_incr; intros. + generalize (H b); generalize (H0 b); intuition congruence. Qed. Lemma val_inject_incr: @@ -2192,61 +2127,17 @@ Lemma val_list_inject_incr: inject_incr f1 f2 -> val_list_inject f1 vl vl' -> val_list_inject f2 vl vl'. Proof. - induction vl ; intros; inversion H0. auto . - subst a . generalize (val_inject_incr f1 f2 v v' H H3) . - intro . auto . -Qed. - -Hint Resolve inject_incr_refl val_inject_incr val_list_inject_incr. - -Section MEM_INJECT_INCR. - -Variable f1 f2: meminj. -Hypothesis INCR: inject_incr f1 f2. - -Lemma val_content_inject_incr: - forall chunk v v', - val_content_inject f1 chunk v v' -> - val_content_inject f2 chunk v v'. -Proof. - intros. inversion H. - apply val_content_inject_base. eapply val_inject_incr; eauto. - apply val_content_inject_8; auto. - apply val_content_inject_16; auto. - apply val_content_inject_32; auto. + induction vl; intros; inv H0. auto. + constructor. eapply val_inject_incr; eauto. auto. Qed. -Lemma content_inject_incr: - forall c c', content_inject f1 c c' -> content_inject f2 c c'. -Proof. - induction 1; constructor; eapply val_content_inject_incr; eauto. -Qed. - -Lemma contentmap_inject_incr: - forall c c' lo hi delta, - contentmap_inject f1 c c' lo hi delta -> - contentmap_inject f2 c c' lo hi delta. -Proof. - unfold contentmap_inject; intros. - apply content_inject_incr. auto. -Qed. - -Lemma block_contents_inject_incr: - forall c c' delta, - block_contents_inject f1 c c' delta -> - block_contents_inject f2 c c' delta. -Proof. - intros. inversion H. constructor; auto. - apply contentmap_inject_incr; auto. -Qed. - -End MEM_INJECT_INCR. +Hint Resolve inject_incr_refl val_inject_incr val_list_inject_incr. (** Properties of injections and allocations. *) Definition extend_inject (b: block) (x: option (block * Z)) (f: meminj) : meminj := - fun b' => if eq_block b' b then x else f b'. + fun (b': block) => if zeq b' b then x else f b'. Lemma extend_inject_incr: forall f b x, @@ -2254,7 +2145,7 @@ Lemma extend_inject_incr: inject_incr f (extend_inject b x f). Proof. intros; red; intros. unfold extend_inject. - case (eq_block b0 b); intro. subst b0. right; auto. left; auto. + destruct (zeq b0 b). subst b0; auto. auto. Qed. Lemma alloc_right_inject: @@ -2263,14 +2154,17 @@ Lemma alloc_right_inject: alloc m2 lo hi = (m2', b) -> mem_inject f m1 m2'. Proof. - intros. unfold alloc in H0. injection H0; intros A B; clear H0. - inversion H. - constructor. - assumption. - intros. generalize (mi_mappedblocks0 _ _ _ H0). intros [C D]. - rewrite <- B; simpl. split. omega. - rewrite update_o. auto. omega. - assumption. + intros. inversion H. constructor. + eapply alloc_right_inj; eauto. + auto. + intros. eauto with mem. + auto. + auto. + intros. replace (low_bound m2' b') with (low_bound m2 b'). + replace (high_bound m2' b') with (high_bound m2 b'). + eauto. + symmetry. eapply high_bound_alloc_other; eauto. + symmetry. eapply low_bound_alloc_other; eauto. Qed. Lemma alloc_unmapped_inject: @@ -2280,26 +2174,36 @@ Lemma alloc_unmapped_inject: mem_inject (extend_inject b None f) m1' m2 /\ inject_incr f (extend_inject b None f). Proof. - intros. unfold alloc in H0. injection H0; intros; clear H0. - inversion H. + intros. inversion H. assert (inject_incr f (extend_inject b None f)). - apply extend_inject_incr. apply mi_freeblocks0. rewrite H1. omega. - split; auto. - constructor. - rewrite <- H2; simpl; intros. unfold extend_inject. - case (eq_block b0 b); intro. auto. apply mi_freeblocks0. omega. - intros until delta. unfold extend_inject at 1. case (eq_block b0 b); intro. - intros; discriminate. - intros. rewrite <- H2; simpl. rewrite H1. - rewrite update_o; auto. - elim (mi_mappedblocks0 _ _ _ H3). intros A B. - split. auto. apply block_contents_inject_incr with f. auto. auto. - intros until delta2. unfold extend_inject. - case (eq_block b1 b); intro. congruence. - case (eq_block b2 b); intro. congruence. - rewrite <- H2. unfold low_bound, high_bound; simpl. rewrite H1. - repeat rewrite update_o; auto. - exact (mi_no_overlap0 b1 b2 b1' b2' delta1 delta2). + apply extend_inject_incr. apply mi_freeblocks0. eauto with mem. + split; auto. constructor. + (* inj *) + eapply alloc_left_unmapped_inj; eauto. + red; intros. unfold extend_inject in H2. + destruct (zeq b1 b). congruence. + exploit mi_inj0; eauto. intros [v2 [LOAD VINJ]]. + exists v2; split. auto. + apply val_inject_incr with f; auto. + unfold extend_inject. apply zeq_true. + (* freeblocks *) + intros. unfold extend_inject. destruct (zeq b0 b). auto. + apply mi_freeblocks0; red; intro. elim H2. eauto with mem. + (* mappedblocks *) + intros. unfold extend_inject in H2. destruct (zeq b0 b). + discriminate. eauto. + (* overlap *) + red; unfold extend_inject, update; intros. + repeat rewrite (low_bound_alloc _ _ _ _ _ H0). + repeat rewrite (high_bound_alloc _ _ _ _ _ H0). + destruct (zeq b1 b); try discriminate. + destruct (zeq b2 b); try discriminate. + eauto. + (* range *) + unfold extend_inject; intros. + destruct (zeq b0 b). discriminate. eauto. + unfold extend_inject; intros. + destruct (zeq b0 b). discriminate. eauto. Qed. Lemma alloc_mapped_inject: @@ -2319,50 +2223,41 @@ Lemma alloc_mapped_inject: mem_inject (extend_inject b (Some (b', ofs)) f) m1' m2 /\ inject_incr f (extend_inject b (Some (b', ofs)) f). Proof. - intros. - generalize (fun b' => low_bound_alloc _ _ b' _ _ _ H0). - intro LOW. - generalize (fun b' => high_bound_alloc _ _ b' _ _ _ H0). - intro HIGH. - unfold alloc in H0. injection H0; intros A B; clear H0. - inversion H. - (* inject_incr *) + intros. inversion H. assert (inject_incr f (extend_inject b (Some (b', ofs)) f)). - apply extend_inject_incr. apply mi_freeblocks0. rewrite A. omega. + apply extend_inject_incr. apply mi_freeblocks0. eauto with mem. split; auto. constructor. - (* mi_freeblocks *) - rewrite <- B; simpl; intros. unfold extend_inject. - case (eq_block b0 b); intro. unfold block in *. omegaContradiction. - apply mi_freeblocks0. omega. - (* mi_mappedblocks *) - intros until delta. unfold extend_inject at 1. - case (eq_block b0 b); intro. - intros. subst b0. inversion H8. subst b'0; subst delta. - split. assumption. - rewrite <- B; simpl. rewrite A. rewrite update_s. - constructor; auto. - unfold empty_block. simpl. intros. unfold low_bound in H5. unfold high_bound in H6. omega. - simpl. red; intros. constructor. - intros. - generalize (mi_mappedblocks0 _ _ _ H8). intros [C D]. - split. auto. - rewrite <- B; simpl; rewrite A; rewrite update_o; auto. - apply block_contents_inject_incr with f; auto. - (* no overlap *) - intros until delta2. unfold extend_inject. - repeat rewrite LOW. repeat rewrite HIGH. unfold eq_block. - case (zeq b1 b); case (zeq b2 b); intros. - congruence. - inversion H9. subst b1'; subst delta1. - case (eq_block b' b2'); intro. - subst b2'. generalize (H7 _ _ H10). intro. - right. intros. omega. left. auto. - inversion H10. subst b2'; subst delta2. - case (eq_block b' b1'); intro. - subst b1'. generalize (H7 _ _ H9). intro. - right. intros. omega. left. auto. - apply mi_no_overlap0; auto. + (* inj *) + eapply alloc_left_mapped_inj; eauto. + red; intros. unfold extend_inject in H9. + rewrite zeq_false in H9. + exploit mi_inj0; eauto. intros [v2 [LOAD VINJ]]. + exists v2; split. auto. eapply val_inject_incr; eauto. + eauto with mem. + unfold extend_inject. apply zeq_true. + (* freeblocks *) + intros. unfold extend_inject. rewrite zeq_false. + apply mi_freeblocks0. red; intro. elim H9; eauto with mem. + apply sym_not_equal; eauto with mem. + (* mappedblocks *) + unfold extend_inject; intros. + destruct (zeq b0 b). inv H9. auto. eauto. + (* overlap *) + red; unfold extend_inject, update; intros. + repeat rewrite (low_bound_alloc _ _ _ _ _ H0). + repeat rewrite (high_bound_alloc _ _ _ _ _ H0). + destruct (zeq b1 b); [inv H10|idtac]; + (destruct (zeq b2 b); [inv H11|idtac]). + congruence. + destruct (zeq b1' b2'). subst b2'. generalize (H7 _ _ H11). tauto. auto. + destruct (zeq b1' b2'). subst b2'. generalize (H7 _ _ H10). tauto. auto. + eauto. + (* range *) + unfold extend_inject; intros. + destruct (zeq b0 b). inv H9. auto. eauto. + unfold extend_inject; intros. + destruct (zeq b0 b). inv H9. auto. eauto. Qed. Lemma alloc_parallel_inject: @@ -2371,20 +2266,104 @@ Lemma alloc_parallel_inject: alloc m1 lo hi = (m1', b1) -> alloc m2 lo hi = (m2', b2) -> Int.min_signed <= lo -> hi <= Int.max_signed -> - mem_inject (extend_inject b1 (Some(b2,0)) f) m1' m2' /\ - inject_incr f (extend_inject b1 (Some(b2,0)) f). + mem_inject (extend_inject b1 (Some(b2, 0)) f) m1' m2' /\ + inject_incr f (extend_inject b1 (Some(b2, 0)) f). Proof. intros. - generalize (low_bound_alloc _ _ b2 _ _ _ H1). rewrite zeq_true; intro LOW. - generalize (high_bound_alloc _ _ b2 _ _ _ H1). rewrite zeq_true; intro HIGH. eapply alloc_mapped_inject; eauto. eapply alloc_right_inject; eauto. - eapply valid_new_block; eauto. - compute. intuition congruence. - rewrite LOW; auto. - rewrite HIGH; auto. - rewrite LOW; omega. - rewrite HIGH; omega. - intros. elim (mi_mappedblocks _ _ _ H _ _ _ H4); intros. - injection H1; intros. rewrite H7 in H5. omegaContradiction. + eauto with mem. + compute; intuition congruence. + rewrite (low_bound_alloc_same _ _ _ _ _ H1). auto. + rewrite (high_bound_alloc_same _ _ _ _ _ H1). auto. + rewrite (low_bound_alloc_same _ _ _ _ _ H1). omega. + rewrite (high_bound_alloc_same _ _ _ _ _ H1). omega. + intros. elimtype False. inv H. + exploit mi_mappedblocks0; eauto. + change (~ valid_block m2 b2). eauto with mem. +Qed. + +Definition meminj_init (m: mem) : meminj := + fun (b: block) => if zlt b m.(nextblock) then Some(b, 0) else None. + +Definition mem_inject_neutral (m: mem) : Prop := + forall f chunk b ofs v, + load chunk m b ofs = Some v -> val_inject f v v. + +Lemma init_inject: + forall m, + mem_inject_neutral m -> + mem_inject (meminj_init m) m m. +Proof. + intros; constructor. + (* inj *) + red; intros. unfold meminj_init in H0. + destruct (zlt b1 (nextblock m)); inversion H0. + subst b2 delta. exists v1; split. + rewrite Zplus_0_r. auto. eapply H; eauto. + (* free blocks *) + unfold valid_block, meminj_init; intros. + apply zlt_false. omega. + (* mapped blocks *) + unfold valid_block, meminj_init; intros. + destruct (zlt b (nextblock m)); inversion H0. subst b'; auto. + (* overlap *) + red; unfold meminj_init; intros. + destruct (zlt b1 (nextblock m)); inversion H1. + destruct (zlt b2 (nextblock m)); inversion H2. + left; congruence. + (* range *) + unfold meminj_init; intros. + destruct (zlt b (nextblock m)); inversion H0. subst delta. + compute; intuition congruence. + unfold meminj_init; intros. + destruct (zlt b (nextblock m)); inversion H0. subst delta. + auto. +Qed. + +Remark getN_setN_inject: + forall f m v n1 p1 n2 p2, + val_inject f (getN n2 p2 m) (getN n2 p2 m) -> + val_inject f v v -> + val_inject f (getN n2 p2 (setN n1 p1 v m)) + (getN n2 p2 (setN n1 p1 v m)). +Proof. + intros. + destruct (getN_setN_characterization m v n1 p1 n2 p2) + as [A | [A | A]]; rewrite A; auto. +Qed. + +Remark getN_contents_init_data_inject: + forall f n ofs id pos, + val_inject f (getN n ofs (contents_init_data pos id)) + (getN n ofs (contents_init_data pos id)). +Proof. + induction id; simpl; intros. + repeat rewrite getN_init. constructor. + destruct a; auto; apply getN_setN_inject; auto. +Qed. + +Lemma alloc_init_data_neutral: + forall m id m' b, + mem_inject_neutral m -> + alloc_init_data m id = (m', b) -> + mem_inject_neutral m'. +Proof. + intros. injection H0; intros A B. + red; intros. + exploit load_inv; eauto. intros [C D]. + rewrite <- B in D; simpl in D. rewrite A in D. + unfold update in D. destruct (zeq b0 b). + subst b0. rewrite D. simpl. + apply load_result_inject with chunk. constructor. + apply getN_contents_init_data_inject. auto. + apply H with chunk b0 ofs. unfold load. + rewrite in_bounds_true. congruence. + inversion C. constructor. + generalize H2. unfold valid_block. rewrite <- B; simpl. + rewrite A. unfold block in n; intros. omega. + replace (low_bound m b0) with (low_bound m' b0). auto. + unfold low_bound; rewrite <- B; simpl; rewrite A. rewrite update_o; auto. + replace (high_bound m b0) with (high_bound m' b0). auto. + unfold high_bound; rewrite <- B; simpl; rewrite A. rewrite update_o; auto. Qed. diff --git a/common/Smallstep.v b/common/Smallstep.v new file mode 100644 index 00000000..7f6c776f --- /dev/null +++ b/common/Smallstep.v @@ -0,0 +1,460 @@ +(** Tools for small-step operational semantics *) + +(** This module defines generic operations and theorems over + the one-step transition relations that are used to specify + operational semantics in small-step style. *) + +Require Import Coqlib. +Require Import AST. +Require Import Events. +Require Import Globalenvs. +Require Import Integers. + +Set Implicit Arguments. + +(** * Closures of transitions relations *) + +Section CLOSURES. + +Variable genv: Set. +Variable state: Set. + +(** A one-step transition relation has the following signature. + It is parameterized by a global environment, which does not + change during the transition. It relates the initial state + of the transition with its final state. The [trace] parameter + captures the observable events possibly generated during the + transition. *) + +Variable step: genv -> state -> trace -> state -> Prop. + +(** Zero, one or several transitions. Also known as Kleene closure, + or reflexive transitive closure. *) + +Inductive star (ge: genv): state -> trace -> state -> Prop := + | star_refl: forall s, + star ge s E0 s + | star_step: forall s1 t1 s2 t2 s3 t, + step ge s1 t1 s2 -> star ge s2 t2 s3 -> t = t1 ** t2 -> + star ge s1 t s3. + +Lemma star_one: + forall ge s1 t s2, step ge s1 t s2 -> star ge s1 t s2. +Proof. + intros. eapply star_step; eauto. apply star_refl. traceEq. +Qed. + +Lemma star_trans: + forall ge s1 t1 s2, star ge s1 t1 s2 -> + forall t2 s3 t, star ge s2 t2 s3 -> t = t1 ** t2 -> star ge s1 t s3. +Proof. + induction 1; intros. + rewrite H0. simpl. auto. + eapply star_step; eauto. traceEq. +Qed. + +Lemma star_left: + forall ge s1 t1 s2 t2 s3 t, + step ge s1 t1 s2 -> star ge s2 t2 s3 -> t = t1 ** t2 -> + star ge s1 t s3. +Proof star_step. + +Lemma star_right: + forall ge s1 t1 s2 t2 s3 t, + star ge s1 t1 s2 -> step ge s2 t2 s3 -> t = t1 ** t2 -> + star ge s1 t s3. +Proof. + intros. eapply star_trans. eauto. apply star_one. eauto. auto. +Qed. + +(** One or several transitions. Also known as the transitive closure. *) + +Inductive plus (ge: genv): state -> trace -> state -> Prop := + | plus_left: forall s1 t1 s2 t2 s3 t, + step ge s1 t1 s2 -> star ge s2 t2 s3 -> t = t1 ** t2 -> + plus ge s1 t s3. + +Lemma plus_one: + forall ge s1 t s2, + step ge s1 t s2 -> plus ge s1 t s2. +Proof. + intros. econstructor; eauto. apply star_refl. traceEq. +Qed. + +Lemma plus_star: + forall ge s1 t s2, plus ge s1 t s2 -> star ge s1 t s2. +Proof. + intros. inversion H; subst. + eapply star_step; eauto. +Qed. + +Lemma plus_right: + forall ge s1 t1 s2 t2 s3 t, + star ge s1 t1 s2 -> step ge s2 t2 s3 -> t = t1 ** t2 -> + plus ge s1 t s3. +Proof. + intros. inversion H; subst. simpl. apply plus_one. auto. + rewrite Eapp_assoc. eapply plus_left; eauto. + eapply star_right; eauto. +Qed. + +Lemma plus_left': + forall ge s1 t1 s2 t2 s3 t, + step ge s1 t1 s2 -> plus ge s2 t2 s3 -> t = t1 ** t2 -> + plus ge s1 t s3. +Proof. + intros. eapply plus_left; eauto. apply plus_star; auto. +Qed. + +Lemma plus_right': + forall ge s1 t1 s2 t2 s3 t, + plus ge s1 t1 s2 -> step ge s2 t2 s3 -> t = t1 ** t2 -> + plus ge s1 t s3. +Proof. + intros. eapply plus_right; eauto. apply plus_star; auto. +Qed. + +Lemma plus_star_trans: + forall ge s1 t1 s2 t2 s3 t, + plus ge s1 t1 s2 -> star ge s2 t2 s3 -> t = t1 ** t2 -> plus ge s1 t s3. +Proof. + intros. inversion H; subst. + econstructor; eauto. eapply star_trans; eauto. + traceEq. +Qed. + +Lemma star_plus_trans: + forall ge s1 t1 s2 t2 s3 t, + star ge s1 t1 s2 -> plus ge s2 t2 s3 -> t = t1 ** t2 -> plus ge s1 t s3. +Proof. + intros. inversion H; subst. + simpl; auto. + rewrite Eapp_assoc. + econstructor. eauto. eapply star_trans. eauto. + apply plus_star. eauto. eauto. auto. +Qed. + +Lemma plus_trans: + forall ge s1 t1 s2 t2 s3 t, + plus ge s1 t1 s2 -> plus ge s2 t2 s3 -> t = t1 ** t2 -> plus ge s1 t s3. +Proof. + intros. eapply plus_star_trans. eauto. apply plus_star. eauto. auto. +Qed. + +Lemma plus_inv: + forall ge s1 t s2, plus ge s1 t s2 -> + step ge s1 t s2 \/ exists s', exists t1, exists t2, step ge s1 t1 s' /\ plus ge s' t2 s2 /\ t = t1 ** t2. +Proof. + intros. inversion H; subst. inversion H1; subst. + left. rewrite E0_right. auto. + right. exists s3; exists t1; exists (t0 ** t3); split. auto. + split. econstructor; eauto. auto. +Qed. + +(** Infinitely many transitions *) + +CoInductive forever (ge: genv): state -> traceinf -> Prop := + | forever_intro: forall s1 t s2 T, + step ge s1 t s2 -> forever ge s2 T -> + forever ge s1 (t *** T). + +(** An alternate, equivalent definition of [forever] that is useful + for coinductive reasoning. *) + +CoInductive forever_N (ge: genv): nat -> state -> traceinf -> Prop := + | forever_N_star: forall s1 t s2 p q T, + star ge s1 t s2 -> (p < q)%nat -> forever_N ge p s2 T -> + forever_N ge q s1 (t *** T) + | forever_N_plus: forall s1 t s2 p q T, + plus ge s1 t s2 -> forever_N ge p s2 T -> + forever_N ge q s1 (t *** T). + +Remark Peano_induction: + forall (P: nat -> Prop), + (forall p, (forall q, (q < p)%nat -> P q) -> P p) -> + forall p, P p. +Proof. + intros P IH. + assert (forall p, forall q, (q < p)%nat -> P q). + induction p; intros. elimtype False; omega. + apply IH. intros. apply IHp. omega. + intro. apply H with (S p). omega. +Qed. + +Lemma forever_N_inv: + forall ge p s T, + forever_N ge p s T -> + exists t, exists s', exists q, exists T', + step ge s t s' /\ forever_N ge q s' T' /\ T = t *** T'. +Proof. + intros ge p. pattern p. apply Peano_induction; intros. + inv H0. + (* star case *) + inv H1. + (* no transition *) + change (E0 *** T0) with T0. apply H with p1. auto. auto. + (* at least one transition *) + exists t1; exists s0; exists p0; exists (t2 *** T0). + split. auto. split. eapply forever_N_star; eauto. + apply Eappinf_assoc. + (* plus case *) + inv H1. + exists t1; exists s0; exists (S p1); exists (t2 *** T0). + split. auto. split. eapply forever_N_star; eauto. + apply Eappinf_assoc. +Qed. + +Lemma forever_N_forever: + forall ge p s T, forever_N ge p s T -> forever ge s T. +Proof. + cofix COINDHYP; intros. + destruct (forever_N_inv H) as [t [s' [q [T' [A [B C]]]]]]. + rewrite C. apply forever_intro with s'. auto. + apply COINDHYP with q; auto. +Qed. + +(** * Outcomes for program executions *) + +(** The two valid outcomes for the execution of a program: +- Termination, with a finite trace of observable events + and an integer value that stands for the process exit code + (the return value of the main function). +- Divergence with an infinite trace of observable events. + (The actual events generated by the execution can be a + finite prefix of this trace, or the whole trace.) +*) + +Inductive program_behavior: Set := + | Terminates: trace -> int -> program_behavior + | Diverges: traceinf -> program_behavior. + +(** Given a characterization of initial states and final states, + [program_behaves] relates a program behaviour with the + sequences of transitions that can be taken from an initial state + to a final state. *) + +Variable initial_state: state -> Prop. +Variable final_state: state -> int -> Prop. + +Inductive program_behaves (ge: genv): program_behavior -> Prop := + | program_terminates: forall s t s' r, + initial_state s -> + star ge s t s' -> + final_state s' r -> + program_behaves ge (Terminates t r) + | program_diverges: forall s T, + initial_state s -> + forever ge s T -> + program_behaves ge (Diverges T). + +End CLOSURES. + +(** * Simulations between two small-step semantics. *) + +(** In this section, we show that if two transition relations + satisfy certain simulation diagrams, then every program behaviour + generated by the first transition relation can also occur + with the second transition relation. *) + +Section SIMULATION. + +(** The first small-step semantics is axiomatized as follows. *) + +Variable genv1: Set. +Variable state1: Set. +Variable step1: genv1 -> state1 -> trace -> state1 -> Prop. +Variable initial_state1: state1 -> Prop. +Variable final_state1: state1 -> int -> Prop. +Variable ge1: genv1. + +(** The second small-step semantics is also axiomatized. *) + +Variable genv2: Set. +Variable state2: Set. +Variable step2: genv2 -> state2 -> trace -> state2 -> Prop. +Variable initial_state2: state2 -> Prop. +Variable final_state2: state2 -> int -> Prop. +Variable ge2: genv2. + +(** We assume given a matching relation between states of both semantics. + This matching relation must be compatible with initial states + and with final states. *) + + +Variable match_states: state1 -> state2 -> Prop. + +Hypothesis match_initial_states: + forall st1, initial_state1 st1 -> + exists st2, initial_state2 st2 /\ match_states st1 st2. + +Hypothesis match_final_states: + forall st1 st2 r, + match_states st1 st2 -> + final_state1 st1 r -> + final_state2 st2 r. + +(** Simulation when one transition in the first program + corresponds to zero, one or several transitions in the second program. + However, there is no stuttering: infinitely many transitions + in the source program must correspond to infinitely many + transitions in the second program. *) + +Section SIMULATION_STAR. + +(** [measure] is a nonnegative integer associated with states + of the first semantics. It must decrease when we take + a stuttering step. *) + +Variable measure: state1 -> nat. + +Hypothesis simulation: + forall st1 t st1', step1 ge1 st1 t st1' -> + forall st2, match_states st1 st2 -> + (exists st2', plus step2 ge2 st2 t st2' /\ match_states st1' st2') + \/ (measure st1' < measure st1 /\ t = E0 /\ match_states st1' st2)%nat. + +Lemma simulation_star_star: + forall st1 t st1', star step1 ge1 st1 t st1' -> + forall st2, match_states st1 st2 -> + exists st2', star step2 ge2 st2 t st2' /\ match_states st1' st2'. +Proof. + induction 1; intros. + exists st2; split. apply star_refl. auto. + elim (simulation H H2). + intros [st2' [A B]]. + destruct (IHstar _ B) as [st3' [C D]]. + exists st3'; split. apply star_trans with t1 st2' t2. + apply plus_star; auto. auto. auto. auto. + intros [A [B C]]. rewrite H1. rewrite B. simpl. apply IHstar; auto. +Qed. + +Lemma simulation_star_forever: + forall st1 st2 T, + forever step1 ge1 st1 T -> match_states st1 st2 -> + forever step2 ge2 st2 T. +Proof. + assert (forall st1 st2 T, + forever step1 ge1 st1 T -> match_states st1 st2 -> + forever_N step2 ge2 (measure st1) st2 T). + cofix COINDHYP; intros. + inversion H; subst. elim (simulation H1 H0). + intros [st2' [A B]]. apply forever_N_plus with st2' (measure s2). + auto. apply COINDHYP. assumption. assumption. + intros [A [B C]]. + apply forever_N_star with st2 (measure s2). + rewrite B. apply star_refl. auto. + apply COINDHYP. assumption. auto. + intros. eapply forever_N_forever; eauto. +Qed. + +Lemma simulation_star_preservation: + forall beh, + program_behaves step1 initial_state1 final_state1 ge1 beh -> + program_behaves step2 initial_state2 final_state2 ge2 beh. +Proof. + intros. inversion H; subst. + destruct (match_initial_states H0) as [s2 [A B]]. + destruct (simulation_star_star H1 B) as [s2' [C D]]. + econstructor; eauto. + destruct (match_initial_states H0) as [s2 [A B]]. + econstructor; eauto. + eapply simulation_star_forever; eauto. +Qed. + +End SIMULATION_STAR. + +(** Lock-step simulation: each transition in the first semantics + corresponds to exactly one transition in the second semantics. *) + +Section SIMULATION_STEP. + +Hypothesis simulation: + forall st1 t st1', step1 ge1 st1 t st1' -> + forall st2, match_states st1 st2 -> + exists st2', step2 ge2 st2 t st2' /\ match_states st1' st2'. + +Lemma simulation_step_preservation: + forall beh, + program_behaves step1 initial_state1 final_state1 ge1 beh -> + program_behaves step2 initial_state2 final_state2 ge2 beh. +Proof. + intros. + pose (measure := fun (st: state1) => 0%nat). + assert (simulation': + forall st1 t st1', step1 ge1 st1 t st1' -> + forall st2, match_states st1 st2 -> + (exists st2', plus step2 ge2 st2 t st2' /\ match_states st1' st2') + \/ (measure st1' < measure st1 /\ t = E0 /\ match_states st1' st2)%nat). + intros. destruct (simulation H0 H1) as [st2' [A B]]. + left; exists st2'; split. apply plus_one; auto. auto. + eapply simulation_star_preservation; eauto. +Qed. + +End SIMULATION_STEP. + +(** Simulation when one transition in the first program corresponds + to one or several transitions in the second program. *) + +Section SIMULATION_PLUS. + +Hypothesis simulation: + forall st1 t st1', step1 ge1 st1 t st1' -> + forall st2, match_states st1 st2 -> + exists st2', plus step2 ge2 st2 t st2' /\ match_states st1' st2'. + +Lemma simulation_plus_preservation: + forall beh, + program_behaves step1 initial_state1 final_state1 ge1 beh -> + program_behaves step2 initial_state2 final_state2 ge2 beh. +Proof. + intros. + pose (measure := fun (st: state1) => 0%nat). + assert (simulation': + forall st1 t st1', step1 ge1 st1 t st1' -> + forall st2, match_states st1 st2 -> + (exists st2', plus step2 ge2 st2 t st2' /\ match_states st1' st2') + \/ (measure st1' < measure st1 /\ t = E0 /\ match_states st1' st2)%nat). + intros. destruct (simulation H0 H1) as [st2' [A B]]. + left; exists st2'; auto. + eapply simulation_star_preservation; eauto. +Qed. + +End SIMULATION_PLUS. + +(** Simulation when one transition in the first program + corresponds to zero or one transitions in the second program. + However, there is no stuttering: infinitely many transitions + in the source program must correspond to infinitely many + transitions in the second program. *) + +Section SIMULATION_OPT. + +Variable measure: state1 -> nat. + +Hypothesis simulation: + forall st1 t st1', step1 ge1 st1 t st1' -> + forall st2, match_states st1 st2 -> + (exists st2', step2 ge2 st2 t st2' /\ match_states st1' st2') + \/ (measure st1' < measure st1 /\ t = E0 /\ match_states st1' st2)%nat. + +Lemma simulation_opt_preservation: + forall beh, + program_behaves step1 initial_state1 final_state1 ge1 beh -> + program_behaves step2 initial_state2 final_state2 ge2 beh. +Proof. + assert (simulation': + forall st1 t st1', step1 ge1 st1 t st1' -> + forall st2, match_states st1 st2 -> + (exists st2', plus step2 ge2 st2 t st2' /\ match_states st1' st2') + \/ (measure st1' < measure st1 /\ t = E0 /\ match_states st1' st2)%nat). + intros. elim (simulation H H0). + intros [st2' [A B]]. left. exists st2'; split. apply plus_one; auto. auto. + intros [A [B C]]. right. intuition. + intros. eapply simulation_star_preservation; eauto. +Qed. + +End SIMULATION_OPT. + +End SIMULATION. + + diff --git a/common/Switch.v b/common/Switch.v new file mode 100644 index 00000000..e8b39671 --- /dev/null +++ b/common/Switch.v @@ -0,0 +1,165 @@ +(** Multi-way branches (``[switch]'') and their compilation + to 2-way comparison trees. *) + +Require Import EqNat. +Require Import Coqlib. +Require Import Integers. + +(** A multi-way branch is composed of a list of (key, action) pairs, + plus a default action. *) + +Definition table : Set := list (int * nat). + +Fixpoint switch_target (n: int) (dfl: nat) (cases: table) + {struct cases} : nat := + match cases with + | nil => dfl + | (key, action) :: rem => + if Int.eq n key then action else switch_target n dfl rem + end. + +(** Multi-way branches are translated to a 2-way comparison tree. + Each node of the tree performs an equality test or a less-than + test against one of the keys. *) + +Inductive comptree : Set := + | CTaction: nat -> comptree + | CTifeq: int -> nat -> comptree -> comptree + | CTiflt: int -> comptree -> comptree -> comptree. + +Fixpoint comptree_match (n: int) (t: comptree) {struct t}: nat := + match t with + | CTaction act => act + | CTifeq key act t' => + if Int.eq n key then act else comptree_match n t' + | CTiflt key t1 t2 => + if Int.ltu n key then comptree_match n t1 else comptree_match n t2 + end. + +(** The translation from a table to a comparison tree is performed + by untrusted Caml code (function [compile_switch] in + file [RTLgenaux.ml]). In Coq, we validate a posteriori the + result of this function. In other terms, we now develop + and prove correct Coq functions that take a table and a comparison + tree, and check that their semantics are equivalent. *) + +Fixpoint split_lt (pivot: int) (cases: table) + {struct cases} : table * table := + match cases with + | nil => (nil, nil) + | (key, act) :: rem => + let (l, r) := split_lt pivot rem in + if Int.ltu key pivot + then ((key, act) :: l, r) + else (l, (key, act) :: r) + end. + +Fixpoint split_eq (pivot: int) (cases: table) + {struct cases} : option nat * table := + match cases with + | nil => (None, nil) + | (key, act) :: rem => + let (same, others) := split_eq pivot rem in + if Int.eq key pivot + then (Some act, others) + else (same, (key, act) :: others) + end. + +Fixpoint validate_switch (default: nat) (cases: table) (t: comptree) + {struct t} : bool := + match t with + | CTaction act => + match cases with + | nil => beq_nat act default + | _ => false + end + | CTifeq pivot act t' => + match split_eq pivot cases with + | (None, _) => false + | (Some act', others) => beq_nat act act' && validate_switch default others t' + end + | CTiflt pivot t1 t2 => + match split_lt pivot cases with + | (lcases, rcases) => + validate_switch default lcases t1 && validate_switch default rcases t2 + end + end. + +(** Correctness proof for validation. *) + +Lemma split_eq_prop: + forall v default n cases optact cases', + split_eq n cases = (optact, cases') -> + switch_target v default cases = + (if Int.eq v n + then match optact with Some act => act | None => default end + else switch_target v default cases'). +Proof. + induction cases; simpl; intros until cases'. + intros. inversion H; subst. simpl. + destruct (Int.eq v n); auto. + destruct a as [key act]. + case_eq (split_eq n cases). intros same other SEQ. + rewrite (IHcases _ _ SEQ). + predSpec Int.eq Int.eq_spec key n; intro EQ; inversion EQ; simpl. + subst n. destruct (Int.eq v key). auto. auto. + predSpec Int.eq Int.eq_spec v key. + subst v. predSpec Int.eq Int.eq_spec key n. congruence. auto. + auto. +Qed. + +Lemma split_lt_prop: + forall v default n cases lcases rcases, + split_lt n cases = (lcases, rcases) -> + switch_target v default cases = + (if Int.ltu v n + then switch_target v default lcases + else switch_target v default rcases). +Proof. + induction cases; intros until rcases; simpl. + intro. inversion H; subst. simpl. + destruct (Int.ltu v n); auto. + destruct a as [key act]. + case_eq (split_lt n cases). intros lc rc SEQ. + rewrite (IHcases _ _ SEQ). + case_eq (Int.ltu key n); intros; inv H0; simpl. + predSpec Int.eq Int.eq_spec v key. + subst v. rewrite H. auto. + auto. + predSpec Int.eq Int.eq_spec v key. + subst v. rewrite H. auto. + auto. +Qed. + +Definition table_tree_agree + (default: nat) (cases: table) (t: comptree) : Prop := + forall v, switch_target v default cases = comptree_match v t. + +Lemma validate_switch_correct: + forall default t cases, + validate_switch default cases t = true -> + table_tree_agree default cases t. +Proof. + induction t; simpl; intros until cases. + (* base case *) + destruct cases. 2: congruence. + intro. replace n with default. + red; intros; simpl; auto. + symmetry. apply beq_nat_eq. auto. + (* eq node *) + case_eq (split_eq i cases). intros optact cases' EQ. + destruct optact as [ act | ]. 2: congruence. + intros. destruct (andb_prop _ _ H). + replace n with act. + generalize (IHt _ H1); intro. + red; intros. simpl. rewrite <- H2. + change act with (match Some act with Some act => act | None => default end). + eapply split_eq_prop; eauto. + symmetry. apply beq_nat_eq. auto. + (* lt node *) + case_eq (split_lt i cases). intros lcases rcases EQ V. + destruct (andb_prop _ _ V). + red; intros. simpl. + rewrite <- (IHt1 _ H). rewrite <- (IHt2 _ H0). + eapply split_lt_prop; eauto. +Qed. diff --git a/common/Values.v b/common/Values.v index aa59e045..e5b49711 100644 --- a/common/Values.v +++ b/common/Values.v @@ -885,4 +885,68 @@ Proof. elim H0; intro; subst v; reflexivity. Qed. +(** The ``is less defined'' relation between values. + A value is less defined than itself, and [Vundef] is + less defined than any value. *) + +Inductive lessdef: val -> val -> Prop := + | lessdef_refl: forall v, lessdef v v + | lessdef_undef: forall v, lessdef Vundef v. + +Inductive lessdef_list: list val -> list val -> Prop := + | lessdef_list_nil: + lessdef_list nil nil + | lessdef_list_cons: + forall v1 v2 vl1 vl2, + lessdef v1 v2 -> lessdef_list vl1 vl2 -> + lessdef_list (v1 :: vl1) (v2 :: vl2). + +Hint Resolve lessdef_refl lessdef_undef lessdef_list_nil lessdef_list_cons. + +Lemma lessdef_list_inv: + forall vl1 vl2, lessdef_list vl1 vl2 -> vl1 = vl2 \/ In Vundef vl1. +Proof. + induction 1; simpl. + tauto. + inv H. destruct IHlessdef_list. + left; congruence. tauto. tauto. +Qed. + +Lemma load_result_lessdef: + forall chunk v1 v2, + lessdef v1 v2 -> lessdef (load_result chunk v1) (load_result chunk v2). +Proof. + intros. inv H. auto. destruct chunk; simpl; auto. +Qed. + +Lemma cast8signed_lessdef: + forall v1 v2, lessdef v1 v2 -> lessdef (cast8signed v1) (cast8signed v2). +Proof. + intros; inv H; simpl; auto. +Qed. + +Lemma cast8unsigned_lessdef: + forall v1 v2, lessdef v1 v2 -> lessdef (cast8unsigned v1) (cast8unsigned v2). +Proof. + intros; inv H; simpl; auto. +Qed. + +Lemma cast16signed_lessdef: + forall v1 v2, lessdef v1 v2 -> lessdef (cast16signed v1) (cast16signed v2). +Proof. + intros; inv H; simpl; auto. +Qed. + +Lemma cast16unsigned_lessdef: + forall v1 v2, lessdef v1 v2 -> lessdef (cast16unsigned v1) (cast16unsigned v2). +Proof. + intros; inv H; simpl; auto. +Qed. + +Lemma singleoffloat_lessdef: + forall v1 v2, lessdef v1 v2 -> lessdef (singleoffloat v1) (singleoffloat v2). +Proof. + intros; inv H; simpl; auto. +Qed. + End Val. diff --git a/coq b/coq index 1f6bf5f8..b110c54f 100755 --- a/coq +++ b/coq @@ -1,4 +1,4 @@ #!/bin/sh # Start coqide with the right -I options -exec coqide -I lib -I common -I backend -I cfrontend "$@" +coqide -I lib -I common -I backend -I cfrontend $1 && make ${1}o diff --git a/doc/backend.html b/doc/backend.html deleted file mode 100644 index e33896ce..00000000 --- a/doc/backend.html +++ /dev/null @@ -1,250 +0,0 @@ - - - -The Compcert certified compiler back-end - - - - - - - - -

The Compcert certified compiler back-end

-

Commented Coq development

-

Version 0.2, 2006-01-07

- -

Introduction

- -

The Compcert back-end is a compiler that generates PowerPC assembly -code from a low-level intermediate language called Cminor and a -slightly more expressive intermediate language called Csharpminor. -The particularity of this compiler is that it is written mostly within -the specification language of the Coq proof assistant, and its -correctness --- the fact that the generated assembly code is -semantically equivalent to its source program --- was entirely proved -within the Coq proof assistant.

- -

A high-level overview of the Compcert back-end and its proof of -correctness can be found in the following paper:

-Xavier Leroy, Formal -certification of a compiler back-end, or: programming a compiler with -a proof assistant. Proceedings of the POPL 2006 symposium. - -

This Web site gives a commented listing of the underlying Coq -specifications and proofs. Proof scripts and the parts of the -compiler written directly in Caml are omitted. This development is a -work in progress; some parts may have changed since the overview paper -above was written.

- -

This document and all Coq source files referenced from it are -copyright 2005, 2006 Institut National de Recherche en Informatique et -en Automatique (INRIA) and distributed under the terms of the GNU General Public -License version 2.

- -

Table of contents

- -

Libraries, algorithms, data structures

- - - -

Source, intermediate and target languages: syntax and semantics

- - - -

Compiler passes

- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
PassSource & targetCompiler codeCorrectness proof
Recognition of operators and addressing modesCsharpminor to CminorCmconstrCmconstrproof
Stack allocation of local variables
whose address is taken		Csharpminor to CminorCminorgenCminorgenproof
Construction of the CFG,
3-address code generation		Cminor to RTLRTLgenRTLgenproof1
- RTLgenproof
Constant propagationRTL to RTLConstpropConstpropproof
Common subexpression eliminationRTL to RTLCSECSEproof
Register allocation by coloring
of an interference graph		RTL to LTLConventions
- InterfGraph
- Coloring
- Parallelmove
- Allocation
-
- Coloringproof
- Allocproof_aux
- Allocproof
Branch tunnelingLTL to LTLTunnelingTunnelingproof
Linearization of the CFGLTL to LinearLinearizeLinearizeproof
Laying out the activation recordsLinear to MachStackingStackingproof
Storing the activation records in memoryMach to Mach(none) - Machabstr2mach
Emission of PowerPC assemblyMach to PPCPPCgenPPCgenproof1
- PPCgenproof
- -

Type systems

- -Trivial type systems are used to statically capture well-formedness -conditions on the intermediate languages. - -Proofs that compiler passes are type-preserving: - - -

All together

- - - -
-
Xavier.Leroy@inria.fr
-
- - - diff --git a/doc/coqdoc.css b/doc/coqdoc.css new file mode 100644 index 00000000..f2ae96da --- /dev/null +++ b/doc/coqdoc.css @@ -0,0 +1,62 @@ +body { + color: black; + background: white; + margin-left: 15%; + margin-right: 5%; +} + +#main a.idref:visited {color : #416DFF; text-decoration : none; } +#main a.idref:link {color : #416DFF; text-decoration : none; } +#main a.idref:hover {text-decoration : none; } +#main a.idref:active {text-decoration : none; } + +#main a.modref:visited {color : #416DFF; text-decoration : none; } +#main a.modref:link {color : #416DFF; text-decoration : none; } +#main a.modref:hover {text-decoration : none; } +#main a.modref:active {text-decoration : none; } + +#main .keyword { color : #cf1d1d } + +#main .doc { + margin-left: -5%; +} + +#main span.docright { + position: absolute; + left: 60%; + width: 40% +} + +h1.libtitle { + font-size: 2em; + margin-left: -15%; + margin-right: -5%; + text-align: center +} + +h1 { + font-size: 1.5em; +} +h2 { + font-size: 1.17em; +} + +h1, h2 { + font-family: sans-serif; +} + +.doc code { + color: #008000; +} + +/* Pied de page */ + +hr { margin-left: -15%; margin-right:-5%; } + +#footer { font-size: 0.83em; + font-family: sans-serif; } + +#footer a:visited { color: blue; } +#footer a:link { text-decoration: none; + color: #888888; } + diff --git a/doc/index.html b/doc/index.html index 33afe85e..709767b7 100644 --- a/doc/index.html +++ b/doc/index.html @@ -1,8295 +1,270 @@ - - -Index - + + + +The Compcert certified compiler back-end + - + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Global IndexABCDEFGHIJKLMNOPQRSTUVWXYZ_(3806 entries)
Axiom IndexABCDEFGHIJKLMNOPQRSTUVWXYZ_(39 entries)
Lemma IndexABCDEFGHIJKLMNOPQRSTUVWXYZ_(1753 entries)
Constructor IndexABCDEFGHIJKLMNOPQRSTUVWXYZ_(700 entries)
Inductive IndexABCDEFGHIJKLMNOPQRSTUVWXYZ_(155 entries)
Definition IndexABCDEFGHIJKLMNOPQRSTUVWXYZ_(1017 entries)
Module IndexABCDEFGHIJKLMNOPQRSTUVWXYZ_(78 entries)
Library IndexABCDEFGHIJKLMNOPQRSTUVWXYZ_(64 entries)
-
-

Global Index

-

A

-a [inductive, in backend.Op]
-a [inductive, in backend.Op]
-Abased [constructor, in backend.Op]
-abs [axiom, in lib.Floats]
-absf [definition, in backend.Values]
-absfloat [definition, in backend.Cmconstr]
-add [axiom, in lib.Floats]
-add [definition, in backend.Values]
-add [definition, in lib.Sets]
-add [definition, in backend.Cmconstr]
-add [definition, in backend.RTLtyping]
-add [definition, in lib.Integers]
-addf [definition, in backend.Cmconstr]
-addf [definition, in backend.Values]
-addf_cases [inductive, in backend.Cmconstr]
-addf_case1 [constructor, in backend.Cmconstr]
-addf_case2 [constructor, in backend.Cmconstr]
-addf_commut [axiom, in lib.Floats]
-addf_commut [lemma, in backend.Values]
-addf_default [constructor, in backend.Cmconstr]
-addf_match [definition, in backend.Cmconstr]
-addf_match_aux [definition, in backend.Cmconstr]
-addimm [definition, in backend.PPCgen]
-addimm [definition, in backend.Cmconstr]
-addimm_cases [inductive, in backend.Cmconstr]
-addimm_case1 [constructor, in backend.Cmconstr]
-addimm_case2 [constructor, in backend.Cmconstr]
-addimm_case3 [constructor, in backend.Cmconstr]
-addimm_case4 [constructor, in backend.Cmconstr]
-addimm_correct [lemma, in backend.PPCgenproof1]
-addimm_default [constructor, in backend.Cmconstr]
-addimm_match [definition, in backend.Cmconstr]
-addimm_1 [definition, in backend.PPCgen]
-addimm_1_correct [lemma, in backend.PPCgenproof1]
-addimm_2 [definition, in backend.PPCgen]
-addimm_2_correct [lemma, in backend.PPCgenproof1]
-addressing [definition, in backend.Cmconstr]
-addressing [inductive, in backend.Op]
-addressing_cases [inductive, in backend.Cmconstr]
-addressing_case1 [constructor, in backend.Cmconstr]
-addressing_case2 [constructor, in backend.Cmconstr]
-addressing_case3 [constructor, in backend.Cmconstr]
-addressing_case4 [constructor, in backend.Cmconstr]
-addressing_case5 [constructor, in backend.Cmconstr]
-addressing_default [constructor, in backend.Cmconstr]
-addressing_match [definition, in backend.Cmconstr]
-address_inject [lemma, in backend.Mem]
-addr_strength_reduction [definition, in backend.Constprop]
-addr_strength_reduction_cases [inductive, in backend.Constprop]
-addr_strength_reduction_case1 [constructor, in backend.Constprop]
-addr_strength_reduction_case2 [constructor, in backend.Constprop]
-addr_strength_reduction_case3 [constructor, in backend.Constprop]
-addr_strength_reduction_correct [lemma, in backend.Constpropproof]
-addr_strength_reduction_default [constructor, in backend.Constprop]
-addr_strength_reduction_match [definition, in backend.Constprop]
-addr_taken_expr [definition, in backend.Cminorgen]
-addr_taken_stmt [definition, in backend.Cminorgen]
-add_and [lemma, in lib.Integers]
-add_assoc [lemma, in lib.Integers]
-add_assoc [lemma, in backend.Values]
-add_call [definition, in backend.Allocation]
-add_call_correct [lemma, in backend.Allocproof]
-add_cases [inductive, in backend.Cmconstr]
-add_case1 [constructor, in backend.Cmconstr]
-add_case2 [constructor, in backend.Cmconstr]
-add_case3 [constructor, in backend.Cmconstr]
-add_case4 [constructor, in backend.Cmconstr]
-add_case5 [constructor, in backend.Cmconstr]
-add_commut [lemma, in lib.Integers]
-add_commut [lemma, in backend.Values]
-add_cond [definition, in backend.Allocation]
-add_cond_correct [lemma, in backend.Allocproof]
-add_default [constructor, in backend.Cmconstr]
-add_edges_instr [definition, in backend.Coloring]
-add_edges_instrs [definition, in backend.Coloring]
-add_edges_instrs_correct [lemma, in backend.Coloringproof]
-add_edges_instrs_correct_aux [lemma, in backend.Coloringproof]
-add_edges_instrs_incl_aux [lemma, in backend.Coloringproof]
-add_edges_instr_correct [lemma, in backend.Coloringproof]
-add_edges_instr_incl [lemma, in backend.Coloringproof]
-add_entry [definition, in backend.Allocation]
-add_entry_correct [lemma, in backend.Allocproof]
-add_funct [definition, in backend.Globalenvs]
-add_functs [definition, in backend.Globalenvs]
-add_functs_transf [lemma, in backend.Globalenvs]
-add_globals [definition, in backend.Globalenvs]
-add_instr [definition, in backend.RTLgen]
-add_instr_at [lemma, in backend.RTLgenproof1]
-add_instr_incr [lemma, in backend.RTLgenproof1]
-add_instr_wf [lemma, in backend.RTLgen]
-add_interf [definition, in backend.InterfGraph]
-add_interf_call [definition, in backend.Coloring]
-add_interf_call_correct [lemma, in backend.Coloringproof]
-add_interf_call_correct_aux_1 [lemma, in backend.Coloringproof]
-add_interf_call_correct_aux_2 [lemma, in backend.Coloringproof]
-add_interf_call_incl [lemma, in backend.Coloringproof]
-add_interf_call_incl_aux_1 [lemma, in backend.Coloringproof]
-add_interf_call_incl_aux_2 [lemma, in backend.Coloringproof]
-add_interf_correct [lemma, in backend.InterfGraph]
-add_interf_entry [definition, in backend.Coloring]
-add_interf_entry_correct [lemma, in backend.Coloringproof]
-add_interf_entry_incl [lemma, in backend.Coloringproof]
-add_interf_incl [lemma, in backend.InterfGraph]
-add_interf_live [definition, in backend.Coloring]
-add_interf_live_correct [lemma, in backend.Coloringproof]
-add_interf_live_correct_aux [lemma, in backend.Coloringproof]
-add_interf_live_incl [lemma, in backend.Coloringproof]
-add_interf_live_incl_aux [lemma, in backend.Coloringproof]
-add_interf_move [definition, in backend.Coloring]
-add_interf_move_correct [lemma, in backend.Coloringproof]
-add_interf_move_incl [lemma, in backend.Coloringproof]
-add_interf_mreg [definition, in backend.InterfGraph]
-add_interf_mreg_correct [lemma, in backend.InterfGraph]
-add_interf_mreg_incl [lemma, in backend.InterfGraph]
-add_interf_op [definition, in backend.Coloring]
-add_interf_op_correct [lemma, in backend.Coloringproof]
-add_interf_op_incl [lemma, in backend.Coloringproof]
-add_interf_params [definition, in backend.Coloring]
-add_interf_params_correct [lemma, in backend.Coloringproof]
-add_interf_params_correct_aux [lemma, in backend.Coloringproof]
-add_interf_params_incl [lemma, in backend.Coloringproof]
-add_interf_params_incl_aux [lemma, in backend.Coloringproof]
-add_letvar [definition, in backend.RTLgen]
-add_letvar_wf [lemma, in backend.RTLgenproof1]
-add_load [definition, in backend.CSE]
-add_load [definition, in backend.Allocation]
-add_load_correct [lemma, in backend.Allocproof]
-add_load_satisfiable [lemma, in backend.CSEproof]
-add_match [definition, in backend.Cmconstr]
-add_match_aux [definition, in backend.Cmconstr]
-add_move [definition, in backend.RTLgen]
-add_move [definition, in backend.Allocation]
-add_move_correct [lemma, in backend.RTLgenproof]
-add_move_correct [lemma, in backend.Allocproof]
-add_move_incr [lemma, in backend.RTLgenproof1]
-add_neg_zero [lemma, in lib.Integers]
-add_op [definition, in backend.Allocation]
-add_op [definition, in backend.CSE]
-add_op_correct [lemma, in backend.Allocproof]
-add_op_satisfiable [lemma, in backend.CSEproof]
-add_permut [lemma, in backend.Values]
-add_permut [lemma, in lib.Integers]
-add_permut_4 [lemma, in backend.Values]
-add_pref [definition, in backend.InterfGraph]
-add_prefs_call [definition, in backend.Coloring]
-add_prefs_call_incl [lemma, in backend.Coloringproof]
-add_pref_incl [lemma, in backend.InterfGraph]
-add_pref_mreg [definition, in backend.InterfGraph]
-add_pref_mreg_incl [lemma, in backend.InterfGraph]
-add_reload [definition, in backend.Allocation]
-add_reloads [definition, in backend.Allocation]
-add_reloads_correct [lemma, in backend.Allocproof]
-add_reloads_correct_rec [lemma, in backend.Allocproof]
-add_reload_correct [lemma, in backend.Allocproof]
-add_return [definition, in backend.Allocation]
-add_return_correct [lemma, in backend.Allocproof]
-add_rhs [definition, in backend.CSE]
-add_rhs_satisfiable [lemma, in backend.CSEproof]
-add_signed [lemma, in lib.Integers]
-add_spill [definition, in backend.Allocation]
-add_spill_correct [lemma, in backend.Allocproof]
-add_store [definition, in backend.Allocation]
-add_store_correct [lemma, in backend.Allocproof]
-add_successors [definition, in backend.Kildall]
-add_successors_correct [lemma, in backend.Kildall]
-add_symbol [definition, in backend.Globalenvs]
-add_to_worklist [definition, in backend.Kildall]
-add_to_worklist_1 [lemma, in backend.Kildall]
-add_to_worklist_2 [lemma, in backend.Kildall]
-add_undefs [definition, in backend.Allocation]
-add_undefs_correct [lemma, in backend.Allocproof]
-add_unsigned [lemma, in lib.Integers]
-add_var [definition, in backend.RTLgen]
-add_vars [definition, in backend.RTLgen]
-add_vars_incr [lemma, in backend.RTLgenproof1]
-add_vars_letenv [lemma, in backend.RTLgenproof1]
-add_vars_valid [lemma, in backend.RTLgenproof1]
-add_vars_wf [lemma, in backend.RTLgenproof1]
-add_var_find [lemma, in backend.RTLgenproof1]
-add_var_incr [lemma, in backend.RTLgenproof1]
-add_var_letenv [lemma, in backend.RTLgenproof1]
-add_var_valid [lemma, in backend.RTLgenproof1]
-add_var_wf [lemma, in backend.RTLgenproof1]
-add_zero [lemma, in lib.Integers]
-Aglobal [constructor, in backend.Op]
-agree [inductive, in backend.Stackingproof]
-agree [definition, in backend.Allocproof]
-agree [definition, in backend.PPCgenproof1]
-agree_assign_dead [lemma, in backend.Allocproof]
-agree_assign_live [lemma, in backend.Allocproof]
-agree_call [lemma, in backend.Allocproof]
-agree_eval_reg [lemma, in backend.Stackingproof]
-agree_eval_reg [lemma, in backend.Allocproof]
-agree_eval_regs [lemma, in backend.Stackingproof]
-agree_eval_regs [lemma, in backend.Allocproof]
-agree_exten [lemma, in backend.Allocproof]
-agree_exten_1 [lemma, in backend.PPCgenproof1]
-agree_exten_2 [lemma, in backend.PPCgenproof1]
-agree_increasing [lemma, in backend.Allocproof]
-agree_init_regs [lemma, in backend.Allocproof]
-agree_move_live [lemma, in backend.Allocproof]
-agree_nextinstr [lemma, in backend.PPCgenproof1]
-agree_nextinstr_commut [lemma, in backend.PPCgenproof1]
-agree_parameters [lemma, in backend.Allocproof]
-agree_reg_list_live [lemma, in backend.Allocproof]
-agree_reg_live [lemma, in backend.Allocproof]
-agree_reg_sum_live [lemma, in backend.Allocproof]
-agree_return_regs [lemma, in backend.Stackingproof]
-agree_set_commut [lemma, in backend.PPCgenproof1]
-agree_set_local [lemma, in backend.Stackingproof]
-agree_set_mfreg [lemma, in backend.PPCgenproof1]
-agree_set_mireg [lemma, in backend.PPCgenproof1]
-agree_set_mireg_exten [lemma, in backend.PPCgenproof1]
-agree_set_mireg_twice [lemma, in backend.PPCgenproof1]
-agree_set_mreg [lemma, in backend.PPCgenproof1]
-agree_set_other [lemma, in backend.PPCgenproof1]
-agree_set_outgoing [lemma, in backend.Stackingproof]
-agree_set_reg [lemma, in backend.Stackingproof]
-agree_set_twice_mireg [lemma, in backend.PPCgenproof1]
-Aindexed [constructor, in backend.Op]
-Aindexed2 [constructor, in backend.Op]
-Ainstack [constructor, in backend.Op]
-align [definition, in lib.Coqlib]
-align_le [lemma, in lib.Coqlib]
-align_16_top [definition, in backend.Mach]
-alloc [definition, in backend.Mem]
-Allocation [library]
-Allocproof [library]
-Allocproof_aux [library]
-allocs_write_ok [lemma, in backend.Alloctyping]
-Alloctyping [library]
-Alloctyping_aux [library]
-alloc_extends [lemma, in backend.Mem]
-alloc_mapped_inject [lemma, in backend.Mem]
-alloc_of_coloring [definition, in backend.Coloring]
-alloc_of_coloring_correct_1 [lemma, in backend.Coloringproof]
-alloc_of_coloring_correct_2 [lemma, in backend.Coloringproof]
-alloc_of_coloring_correct_3 [lemma, in backend.Coloringproof]
-alloc_of_coloring_correct_4 [lemma, in backend.Coloringproof]
-alloc_reg [definition, in backend.RTLgen]
-alloc_regs [definition, in backend.RTLgen]
-alloc_regs_fresh_or_in_map [lemma, in backend.RTLgenproof1]
-alloc_regs_incr [lemma, in backend.RTLgenproof1]
-alloc_regs_target_ok [lemma, in backend.RTLgenproof1]
-alloc_regs_valid [lemma, in backend.RTLgenproof1]
-alloc_reg_fresh_or_in_map [lemma, in backend.RTLgenproof1]
-alloc_reg_incr [lemma, in backend.RTLgenproof1]
-alloc_reg_target_ok [lemma, in backend.RTLgenproof1]
-alloc_reg_valid [lemma, in backend.RTLgenproof1]
-alloc_right_inject [lemma, in backend.Mem]
-alloc_type [lemma, in backend.Alloctyping]
-alloc_types [lemma, in backend.Alloctyping]
-alloc_unmapped_inject [lemma, in backend.Mem]
-alloc_variables [inductive, in backend.Csharpminor]
-alloc_variables_cons [constructor, in backend.Csharpminor]
-alloc_variables_list_block [lemma, in backend.Cminorgenproof]
-alloc_variables_nextblock_incr [lemma, in backend.Cminorgenproof]
-alloc_variables_nil [constructor, in backend.Csharpminor]
-alloc_write_ok [lemma, in backend.Alloctyping]
-all_interf_regs [definition, in backend.InterfGraph]
-all_interf_regs_correct_aux_1 [lemma, in backend.InterfGraph]
-all_interf_regs_correct_aux_2 [lemma, in backend.InterfGraph]
-all_interf_regs_correct_aux_3 [lemma, in backend.InterfGraph]
-all_interf_regs_correct_1 [lemma, in backend.InterfGraph]
-all_interf_regs_correct_2 [lemma, in backend.InterfGraph]
-analysis_correct_entry [lemma, in backend.CSEproof]
-analysis_correct_N [lemma, in backend.CSEproof]
-analysis_correct_1 [lemma, in backend.CSEproof]
-analyze [definition, in backend.Allocation]
-analyze [definition, in backend.Constprop]
-analyze [definition, in backend.CSE]
-analyze_correct [lemma, in backend.Allocproof]
-analyze_correct_1 [lemma, in backend.Constpropproof]
-analyze_correct_2 [lemma, in backend.Constpropproof]
-analyze_correct_3 [lemma, in backend.Constpropproof]
-analyze_invariant [lemma, in backend.Kildall]
-analyze_P [lemma, in backend.Kildall]
-and [definition, in lib.Integers]
-and [definition, in backend.Cmconstr]
-and [definition, in backend.Values]
-andimm [definition, in backend.Cmconstr]
-andimm [definition, in backend.PPCgen]
-andimm_correct [lemma, in backend.PPCgenproof1]
-and_assoc [lemma, in backend.Values]
-and_assoc [lemma, in lib.Integers]
-and_commut [lemma, in lib.Integers]
-and_commut [lemma, in backend.Values]
-and_idem [lemma, in lib.Integers]
-and_mone [lemma, in lib.Integers]
-and_or_distrib [lemma, in lib.Integers]
-and_shl [lemma, in lib.Integers]
-and_shru [lemma, in lib.Integers]
-and_xor_distrib [lemma, in lib.Integers]
-and_zero [lemma, in lib.Integers]
-appcons_length [lemma, in backend.Parallelmove]
-append [definition, in lib.Maps]
-append_assoc_0 [lemma, in lib.Maps]
-append_assoc_1 [lemma, in lib.Maps]
-append_injective [lemma, in lib.Maps]
-append_neutral_l [lemma, in lib.Maps]
-append_neutral_r [lemma, in lib.Maps]
-apply_partial [definition, in backend.Main]
-apply_total [definition, in backend.Main]
-apply_total_transf_program [lemma, in backend.Main]
-approx [inductive, in backend.Constprop]
-Approx [module, in backend.Constprop]
-approx_regs [definition, in backend.Constprop]
-approx_regs_val_list [lemma, in backend.Constpropproof]
-app_app [lemma, in backend.Parallelmove]
-app_cons [lemma, in backend.Parallelmove]
-app_nil [lemma, in backend.Parallelmove]
-app_rewrite [lemma, in backend.Parallelmove]
-app_rewriter [lemma, in backend.Parallelmove]
-app_rewrite2 [lemma, in backend.Parallelmove]
-arguments_not_preserved [lemma, in backend.Conventions]
-assign_variable [definition, in backend.Cminorgen]
-assign_variables [definition, in backend.Cminorgen]
-AST [library]
-

B

-BACKWARD_DATAFLOW_SOLVER [module, in backend.Kildall]
-Backward_Dataflow_Solver [module, in backend.Kildall]
-base_case_Pmov_dec [definition, in backend.Parallelmove]
-basic_block_list [definition, in backend.Kildall]
-basic_block_map [definition, in backend.Kildall]
-BBlock_solver [module, in backend.Kildall]
-BBLOCK_SOLVER [module, in backend.Kildall]
-bbmap [definition, in backend.Kildall]
-Bcall [constructor, in backend.LTL]
-Bcond [constructor, in backend.LTL]
-Bgetstack [constructor, in backend.LTL]
-Bgoto [constructor, in backend.LTL]
-bin [inductive, in lib.Inclusion]
-bind [definition, in backend.RTLgen]
-bind [definition, in backend.Cminorgen]
-bind2 [definition, in backend.RTLgen]
-bind_parameters [inductive, in backend.Csharpminor]
-bind_parameters_cons [constructor, in backend.Csharpminor]
-bind_parameters_length [lemma, in backend.Cminorgenproof]
-bind_parameters_nil [constructor, in backend.Csharpminor]
-bin_A [definition, in lib.Inclusion]
-bits_of_Z [definition, in lib.Integers]
-bits_of_Z_above [lemma, in lib.Integers]
-bits_of_Z_below [lemma, in lib.Integers]
-bits_of_Z_mone [lemma, in lib.Integers]
-bits_of_Z_of_bits [lemma, in lib.Integers]
-bits_of_Z_zero [lemma, in lib.Integers]
-bitwise_binop [definition, in lib.Integers]
-bitwise_binop_assoc [lemma, in lib.Integers]
-bitwise_binop_commut [lemma, in lib.Integers]
-bitwise_binop_idem [lemma, in lib.Integers]
-bitwise_binop_rol [lemma, in lib.Integers]
-bitwise_binop_shl [lemma, in lib.Integers]
-bitwise_binop_shru [lemma, in lib.Integers]
-Bload [constructor, in backend.LTL]
-block [inductive, in backend.LTL]
-block [definition, in backend.Values]
-block_agree [definition, in backend.Mem]
-block_agree_refl [lemma, in backend.Mem]
-block_agree_sym [lemma, in backend.Mem]
-block_agree_trans [lemma, in backend.Mem]
-block_contents [inductive, in backend.Mem]
-block_contents_agree [definition, in backend.Mem]
-block_contents_exten [lemma, in backend.Mem]
-block_contents_extends [definition, in backend.Mem]
-block_contents_inject [inductive, in backend.Mem]
-block_contents_inject_incr [lemma, in backend.Mem]
-block_cont_val [lemma, in backend.Mem]
-bool_of_false_val [lemma, in backend.Values]
-bool_of_false_val2 [lemma, in backend.Values]
-bool_of_false_val_inv [lemma, in backend.Values]
-bool_of_true_val [lemma, in backend.Values]
-bool_of_true_val2 [lemma, in backend.Values]
-bool_of_true_val_inv [lemma, in backend.Values]
-bool_of_val [inductive, in backend.Values]
-bool_of_val_int_true [constructor, in backend.Values]
-Bop [constructor, in backend.LTL]
-bot [definition, in lib.Lattice]
-Bot [constructor, in lib.Lattice]
-bot [definition, in lib.Lattice]
-bot [definition, in backend.Constprop]
-bot [definition, in lib.Sets]
-bot [definition, in lib.Lattice]
-Bot_except [constructor, in lib.Lattice]
-bounds [inductive, in backend.Lineartyping]
-bounds_free_block [lemma, in backend.Mem]
-bound_float_callee_save_pos [lemma, in backend.Lineartyping]
-bound_float_local_pos [lemma, in backend.Lineartyping]
-bound_int_callee_save_pos [lemma, in backend.Lineartyping]
-bound_int_local_pos [lemma, in backend.Lineartyping]
-bound_outgoing_pos [lemma, in backend.Lineartyping]
-branch_target [definition, in backend.Tunneling]
-branch_target_characterization [lemma, in backend.Tunnelingproof]
-branch_target_rec [definition, in backend.Tunneling]
-branch_target_rec_1 [lemma, in backend.Tunnelingproof]
-branch_target_rec_2 [lemma, in backend.Tunnelingproof]
-Breturn [constructor, in backend.LTL]
-Bsetstack [constructor, in backend.LTL]
-Bstore [constructor, in backend.LTL]
-build_compilenv [definition, in backend.Cminorgen]
-

C

-callstack [definition, in backend.Machabstr2mach]
-callstack [definition, in backend.Cminorgenproof]
-callstack_dom [inductive, in backend.Machabstr2mach]
-callstack_dom_cons [constructor, in backend.Machabstr2mach]
-callstack_dom_diff [lemma, in backend.Machabstr2mach]
-callstack_dom_incr [lemma, in backend.Machabstr2mach]
-callstack_dom_less [lemma, in backend.Machabstr2mach]
-callstack_dom_nil [constructor, in backend.Machabstr2mach]
-callstack_exten [lemma, in backend.Machabstr2mach]
-callstack_function_entry [lemma, in backend.Machabstr2mach]
-callstack_function_return [lemma, in backend.Machabstr2mach]
-callstack_get_parent [lemma, in backend.Machabstr2mach]
-callstack_get_slot [lemma, in backend.Machabstr2mach]
-callstack_init [lemma, in backend.Machabstr2mach]
-callstack_invariant [inductive, in backend.Machabstr2mach]
-callstack_linked [inductive, in backend.Machabstr2mach]
-callstack_linked_cons [constructor, in backend.Machabstr2mach]
-callstack_linked_nil [constructor, in backend.Machabstr2mach]
-callstack_linked_one [constructor, in backend.Machabstr2mach]
-callstack_load [lemma, in backend.Machabstr2mach]
-callstack_set_slot [lemma, in backend.Machabstr2mach]
-callstack_store [lemma, in backend.Machabstr2mach]
-callstack_store_aux [lemma, in backend.Machabstr2mach]
-callstack_store_ok [lemma, in backend.Machabstr2mach]
-call_regs [definition, in backend.LTL]
-call_regs_param_of_arg [lemma, in backend.Allocproof]
-CARRY [constructor, in backend.PPC]
-cast [definition, in backend.Csharpminor]
-cast16signed [definition, in lib.Integers]
-cast16signed [definition, in backend.Values]
-cast16signed [definition, in backend.Cmconstr]
-cast16unsigned [definition, in backend.Cmconstr]
-cast16unsigned [definition, in backend.Values]
-cast16unsigned [definition, in lib.Integers]
-cast16unsigned_and [lemma, in lib.Integers]
-cast16unsigned_and [lemma, in backend.Values]
-cast16_signed_equal_if_unsigned_equal [lemma, in lib.Integers]
-cast16_signed_idem [lemma, in lib.Integers]
-cast16_unsigned_idem [lemma, in lib.Integers]
-cast16_unsigned_signed [lemma, in lib.Integers]
-cast8signed [definition, in backend.Cmconstr]
-cast8signed [definition, in lib.Integers]
-cast8signed [definition, in backend.Values]
-cast8unsigned [definition, in backend.Cmconstr]
-cast8unsigned [definition, in backend.Values]
-cast8unsigned [definition, in lib.Integers]
-cast8unsigned_and [lemma, in lib.Integers]
-cast8unsigned_and [lemma, in backend.Values]
-cast8_signed_equal_if_unsigned_equal [lemma, in lib.Integers]
-cast8_signed_idem [lemma, in lib.Integers]
-cast8_signed_unsigned [lemma, in lib.Integers]
-cast8_unsigned_idem [lemma, in lib.Integers]
-cast8_unsigned_signed [lemma, in lib.Integers]
-Ccomp [constructor, in backend.Op]
-Ccompf [constructor, in backend.Op]
-Ccompimm [constructor, in backend.Op]
-Ccompu [constructor, in backend.Op]
-Ccompuimm [constructor, in backend.Op]
-CEcond [constructor, in backend.Cminor]
-CEcondition [constructor, in backend.Cminor]
-CEfalse [constructor, in backend.Cminor]
-Ceq [constructor, in backend.AST]
-CEtrue [constructor, in backend.Cminor]
-Cge [constructor, in backend.AST]
-Cgt [constructor, in backend.AST]
-check_all_leaves [definition, in lib.Inclusion]
-check_all_leaves_sound [lemma, in lib.Inclusion]
-check_coloring [definition, in backend.Coloring]
-check_coloring_1 [definition, in backend.Coloring]
-check_coloring_1_correct [lemma, in backend.Coloringproof]
-check_coloring_2 [definition, in backend.Coloring]
-check_coloring_2_correct [lemma, in backend.Coloringproof]
-check_coloring_3 [definition, in backend.Coloring]
-check_coloring_3_correct [lemma, in backend.Coloringproof]
-check_cont [definition, in backend.Mem]
-check_cont_agree [lemma, in backend.Mem]
-check_cont_false [lemma, in backend.Mem]
-check_cont_inject [lemma, in backend.Mem]
-check_cont_inv [lemma, in backend.Mem]
-check_cont_true [lemma, in backend.Mem]
-check_equal_on_range [definition, in lib.Integers]
-check_equal_on_range_correct [lemma, in lib.Integers]
-chunk_of_type [definition, in backend.Mach]
-Cint [constructor, in backend.PPC]
-Cle [constructor, in backend.AST]
-cleanup_code [definition, in backend.Linearize]
-cleanup_code_conservation [lemma, in backend.Linearizetyping]
-cleanup_code_conservation_2 [lemma, in backend.Linearizetyping]
-cleanup_code_correct_1 [lemma, in backend.Linearizeproof]
-cleanup_code_correct_2 [lemma, in backend.Linearizeproof]
-cleanup_function [definition, in backend.Linearize]
-cleanup_function_conservation [lemma, in backend.Linearizetyping]
-cleanup_function_conservation_2 [lemma, in backend.Linearizetyping]
-cleanup_function_correct [lemma, in backend.Linearizeproof]
-Clt [constructor, in backend.AST]
-Cmasknotzero [constructor, in backend.Op]
-Cmaskzero [constructor, in backend.Op]
-Cmconstr [library]
-Cmconstrproof [library]
-Cminor [library]
-Cminorgen [library]
-Cminorgenproof [library]
-cmp [axiom, in lib.Floats]
-cmp [definition, in backend.Cmconstr]
-cmp [definition, in backend.Values]
-cmp [definition, in lib.Integers]
-cmpf [definition, in backend.Cmconstr]
-cmpf [definition, in backend.Values]
-cmpf_ge [lemma, in backend.Values]
-cmpf_is_bool [lemma, in backend.Values]
-cmpf_le [lemma, in backend.Values]
-cmpu [definition, in backend.Values]
-cmpu [definition, in backend.Cmconstr]
-cmpu [definition, in lib.Integers]
-cmpu_is_bool [lemma, in backend.Values]
-cmp_ge_gt_eq [axiom, in lib.Floats]
-cmp_is_bool [lemma, in backend.Values]
-cmp_le_lt_eq [axiom, in lib.Floats]
-cmp_mismatch [definition, in backend.Values]
-cmp_mismatch_is_bool [lemma, in backend.Values]
-cmp_ne_eq [axiom, in lib.Floats]
-Cne [constructor, in backend.AST]
-Cnotcompf [constructor, in backend.Op]
-code [definition, in backend.LTL]
-code [definition, in backend.PPC]
-code [definition, in backend.RTL]
-code [definition, in backend.Linear]
-code [definition, in backend.Mach]
-code_size [definition, in backend.PPCgen]
-code_tail [definition, in backend.PPCgenproof]
-code_tail_next [lemma, in backend.PPCgenproof]
-code_tail_next_int [lemma, in backend.PPCgenproof]
-Coloring [library]
-Coloringproof [library]
-combine [definition, in lib.Maps]
-combine_commut [lemma, in lib.Maps]
-compare [lemma, in lib.Ordered]
-compare [lemma, in lib.Ordered]
-compare [lemma, in lib.Ordered]
-compare_float [definition, in backend.PPC]
-compare_float_spec [lemma, in backend.PPCgenproof1]
-compare_sint [definition, in backend.PPC]
-compare_sint_spec [lemma, in backend.PPCgenproof1]
-compare_uint [definition, in backend.PPC]
-compare_uint_spec [lemma, in backend.PPCgenproof1]
-comparison [inductive, in backend.AST]
-compilenv [definition, in backend.Cminorgen]
-condexpr [inductive, in backend.Cminor]
-condexpr_of_expr [definition, in backend.Cmconstr]
-condition [inductive, in backend.Op]
-conditionalexpr [definition, in backend.Cmconstr]
-cond_strength_reduction [definition, in backend.Constprop]
-cond_strength_reduction_cases [inductive, in backend.Constprop]
-cond_strength_reduction_correct [lemma, in backend.Constpropproof]
-cond_strength_reduction_match [definition, in backend.Constprop]
-consistent [definition, in backend.RTLtyping]
-consistent_not_eq [lemma, in backend.RTLtyping]
-constant [inductive, in backend.PPC]
-Constprop [library]
-Constpropproof [library]
-const_high [definition, in backend.PPC]
-const_low [definition, in backend.PPC]
-cons_replace [lemma, in backend.Parallelmove]
-Cont [constructor, in backend.LTL]
-Cont [constructor, in backend.Mem]
-content [inductive, in backend.Mem]
-contentmap [definition, in backend.Mem]
-contentmap_agree [definition, in backend.Mem]
-contentmap_inject [definition, in backend.Mem]
-contentmap_inject_incr [lemma, in backend.Mem]
-content_inject [inductive, in backend.Mem]
-content_inject_cont [constructor, in backend.Mem]
-content_inject_datum16 [constructor, in backend.Mem]
-content_inject_datum32 [constructor, in backend.Mem]
-content_inject_datum64 [constructor, in backend.Mem]
-content_inject_datum8 [constructor, in backend.Mem]
-content_inject_incr [lemma, in backend.Mem]
-content_inject_undef [constructor, in backend.Mem]
-cont_for_outcome [inductive, in backend.Linearizeproof]
-Conventions [library]
-Coqlib [library]
-correct_alloc_instr [definition, in backend.Coloringproof]
-correct_interf_alloc_instr [lemma, in backend.Coloringproof]
-correct_interf_instr [definition, in backend.Coloringproof]
-correct_interf_instr_incl [lemma, in backend.Coloringproof]
-crbit [inductive, in backend.PPC]
-crbit_for_cond [definition, in backend.PPCgen]
-crbit_for_fcmp [definition, in backend.PPCgen]
-crbit_for_icmp [definition, in backend.PPCgen]
-CRbit_0 [constructor, in backend.PPC]
-CRbit_1 [constructor, in backend.PPC]
-CRbit_2 [constructor, in backend.PPC]
-CRbit_3 [constructor, in backend.PPC]
-CR0_0 [constructor, in backend.PPC]
-CR0_1 [constructor, in backend.PPC]
-CR0_2 [constructor, in backend.PPC]
-CR0_3 [constructor, in backend.PPC]
-CSE [library]
-CSEproof [library]
-Csharpminor [library]
-csr_case1 [constructor, in backend.Constprop]
-csr_case2 [constructor, in backend.Constprop]
-csr_default [constructor, in backend.Constprop]
-Csymbol_high_signed [constructor, in backend.PPC]
-Csymbol_high_unsigned [constructor, in backend.PPC]
-Csymbol_low_signed [constructor, in backend.PPC]
-Csymbol_low_unsigned [constructor, in backend.PPC]
-CTR [constructor, in backend.PPC]
-

D

-D [module, in backend.Constprop]
-Dataflow_Solver [module, in backend.Kildall]
-DATAFLOW_SOLVER [module, in backend.Kildall]
-Datum16 [constructor, in backend.Mem]
-Datum32 [constructor, in backend.Mem]
-Datum64 [constructor, in backend.Mem]
-Datum8 [constructor, in backend.Mem]
-decode [definition, in backend.RTLtyping]
-def [definition, in backend.Parallelmove]
-definite [definition, in backend.RTLtyping]
-definite_included [lemma, in backend.RTLtyping]
-destroyed_at_call [definition, in backend.Conventions]
-destroyed_at_call_regs [definition, in backend.Conventions]
-diff [definition, in backend.Locations]
-diff_dec [definition, in backend.Parallelmove]
-diff_not_eq [lemma, in backend.Locations]
-diff_sym [lemma, in backend.Locations]
-discard_top_worklist_invariant [lemma, in backend.Kildall]
-disc1 [lemma, in backend.Parallelmove]
-disc2 [lemma, in backend.Parallelmove]
-disjoint [definition, in backend.Locations]
-disjoint_cons_left [lemma, in backend.Locations]
-disjoint_cons_right [lemma, in backend.Locations]
-disjoint_notin [lemma, in backend.Locations]
-disjoint_sym [lemma, in backend.Locations]
-disjoint_tmp__noTmp [lemma, in backend.Parallelmove]
-dis_dsttmp1_pnilnil [lemma, in backend.Allocproof_aux]
-dis_srctmp1_pnilnil [lemma, in backend.Allocproof_aux]
-div [axiom, in lib.Floats]
-divf [definition, in backend.Values]
-divf [definition, in backend.Cmconstr]
-divs [definition, in backend.Cmconstr]
-divs [definition, in lib.Integers]
-divs [definition, in backend.Values]
-divs_pow2 [lemma, in lib.Integers]
-divs_pow2 [lemma, in backend.Values]
-divu [definition, in backend.Cmconstr]
-divu [definition, in backend.Values]
-divu [definition, in lib.Integers]
-divu_cases [inductive, in backend.Cmconstr]
-divu_case1 [constructor, in backend.Cmconstr]
-divu_default [constructor, in backend.Cmconstr]
-divu_match [definition, in backend.Cmconstr]
-divu_pow2 [lemma, in backend.Values]
-divu_pow2 [lemma, in lib.Integers]
-Done_notmp1src_inv [lemma, in backend.Allocproof_aux]
-Done_notmp1src_invf [lemma, in backend.Allocproof_aux]
-Done_notmp1src_invpp [lemma, in backend.Allocproof_aux]
-Done_notmp1src_res [lemma, in backend.Allocproof_aux]
-Done_notmp1_inv [lemma, in backend.Allocproof_aux]
-Done_notmp1_invf [lemma, in backend.Allocproof_aux]
-Done_notmp1_invpp [lemma, in backend.Allocproof_aux]
-Done_notmp1_res [lemma, in backend.Allocproof_aux]
-Done_notmp3_inv [lemma, in backend.Allocproof_aux]
-Done_notmp3_invf [lemma, in backend.Allocproof_aux]
-Done_notmp3_invpp [lemma, in backend.Allocproof_aux]
-Done_notmp3_res [lemma, in backend.Allocproof_aux]
-Done_well_formed [definition, in backend.Allocproof_aux]
-drop1 [definition, in backend.Conventions]
-drop2 [definition, in backend.Conventions]
-DS [module, in backend.Kildall]
-DS [module, in backend.Constprop]
-DS [module, in backend.Linearize]
-DS [module, in backend.Allocation]
-dstep [inductive, in backend.Parallelmove]
-dstepp [inductive, in backend.Parallelmove]
-dstepp_refl [constructor, in backend.Parallelmove]
-dstepp_sameExec [lemma, in backend.Parallelmove]
-dstepp_stepp [lemma, in backend.Parallelmove]
-dstepp_trans [constructor, in backend.Parallelmove]
-dstep_inv [lemma, in backend.Parallelmove]
-dstep_inv_getdst [lemma, in backend.Parallelmove]
-dstep_nop [constructor, in backend.Parallelmove]
-dstep_pop [constructor, in backend.Parallelmove]
-dstep_pop_loop [constructor, in backend.Parallelmove]
-dstep_push [constructor, in backend.Parallelmove]
-dstep_start [constructor, in backend.Parallelmove]
-dstep_step [lemma, in backend.Parallelmove]
-dst_tmp2_res [lemma, in backend.Allocproof_aux]
-dst_tmp2_step [lemma, in backend.Allocproof_aux]
-dst_tmp2_stepf [lemma, in backend.Allocproof_aux]
-dst_tmp2_stepp [lemma, in backend.Allocproof_aux]
-

E

-Eaddrof [constructor, in backend.Csharpminor]
-Eassign [constructor, in backend.Cminor]
-Eassign [constructor, in backend.Csharpminor]
-Ecall [constructor, in backend.Csharpminor]
-Ecall [constructor, in backend.Cminor]
-Econdition [constructor, in backend.Csharpminor]
-Econdition [constructor, in backend.Cminor]
-Econs [constructor, in backend.Cminor]
-Econs [constructor, in backend.Csharpminor]
-ELEMENT [module, in lib.union_find]
-elements [definition, in lib.Sets]
-elements [definition, in lib.Maps]
-elements_complete [lemma, in lib.Maps]
-elements_complete [lemma, in lib.Sets]
-elements_correct [lemma, in lib.Maps]
-elements_correct [lemma, in lib.Sets]
-elements_keys_norepet [lemma, in lib.Maps]
-Elet [constructor, in backend.Csharpminor]
-Elet [constructor, in backend.Cminor]
-Eletvar [constructor, in backend.Cminor]
-Eletvar [constructor, in backend.Csharpminor]
-Eload [constructor, in backend.Cminor]
-Eload [constructor, in backend.Csharpminor]
-elt [definition, in lib.Maps]
-elt [definition, in backend.RTLtyping]
-elt [definition, in lib.Sets]
-elt [definition, in lib.union_find]
-elt [definition, in lib.union_find]
-elt [definition, in lib.union_find]
-elt [definition, in lib.Maps]
-elt [definition, in lib.Maps]
-elt [definition, in lib.Maps]
-elt_eq [definition, in lib.Maps]
-elt_eq [definition, in lib.Maps]
-elt_eq [definition, in lib.Maps]
-elt_eq [definition, in lib.Maps]
-EMap [module, in lib.Maps]
-empty [definition, in lib.Sets]
-empty [definition, in lib.Maps]
-empty [definition, in lib.union_find]
-empty [definition, in backend.RTLtyping]
-empty [definition, in backend.Globalenvs]
-empty [definition, in backend.Mem]
-empty_block [definition, in backend.Mem]
-empty_env [definition, in backend.Csharpminor]
-empty_frame [definition, in backend.Machabstr]
-empty_graph [definition, in backend.InterfGraph]
-empty_numbering [definition, in backend.CSE]
-empty_numbering_satisfiable [lemma, in backend.CSE]
-encode [definition, in backend.RTLtyping]
-encode_decode [lemma, in backend.RTLtyping]
-encode_injective [lemma, in backend.RTLtyping]
-Enil [constructor, in backend.Csharpminor]
-Enil [constructor, in backend.Cminor]
-entrypoint_function_translated [lemma, in backend.Allocproof]
-enumerate [definition, in backend.Linearize]
-enumerate_complete [lemma, in backend.Linearizeproof]
-enumerate_head [lemma, in backend.Linearizeproof]
-enumerate_norepet [lemma, in backend.Linearizeproof]
-env [definition, in backend.Csharpminor]
-Env [definition, in backend.Parallelmove]
-env [definition, in backend.Cminor]
-Eop [constructor, in backend.Csharpminor]
-Eop [constructor, in backend.Cminor]
-eq [lemma, in backend.Constprop]
-eq [definition, in backend.Mach]
-eq [definition, in lib.Ordered]
-eq [definition, in backend.RTLtyping]
-eq [lemma, in lib.Lattice]
-eq [lemma, in lib.Sets]
-eq [definition, in backend.CSEproof]
-eq [lemma, in lib.Lattice]
-eq [lemma, in lib.Lattice]
-eq [lemma, in backend.Locations]
-eq [definition, in lib.Maps]
-eq [lemma, in lib.Maps]
-eq [definition, in backend.Locations]
-eq [definition, in lib.Ordered]
-eq [definition, in backend.Registers]
-eq [lemma, in lib.Maps]
-eq [definition, in lib.Ordered]
-eq [definition, in backend.PPC]
-eq [definition, in lib.Integers]
-eqm [definition, in lib.Integers]
-eqmod [definition, in lib.Integers]
-eqmod_add [lemma, in lib.Integers]
-eqmod_mod [lemma, in lib.Integers]
-eqmod_mod_eq [lemma, in lib.Integers]
-eqmod_mult [lemma, in lib.Integers]
-eqmod_neg [lemma, in lib.Integers]
-eqmod_refl [lemma, in lib.Integers]
-eqmod_refl2 [lemma, in lib.Integers]
-eqmod_small_eq [lemma, in lib.Integers]
-eqmod_sub [lemma, in lib.Integers]
-eqmod_sym [lemma, in lib.Integers]
-eqmod_trans [lemma, in lib.Integers]
-eqmod_256_unsigned_repr [lemma, in lib.Integers]
-eqmod_65536_unsigned_repr [lemma, in lib.Integers]
-eqm_add [lemma, in lib.Integers]
-eqm_mult [lemma, in lib.Integers]
-eqm_neg [lemma, in lib.Integers]
-eqm_refl [lemma, in lib.Integers]
-eqm_refl2 [lemma, in lib.Integers]
-eqm_samerepr [lemma, in lib.Integers]
-eqm_signed_unsigned [lemma, in lib.Integers]
-eqm_small_eq [lemma, in lib.Integers]
-eqm_sub [lemma, in lib.Integers]
-eqm_sym [lemma, in lib.Integers]
-eqm_trans [lemma, in lib.Integers]
-eqm_unsigned_repr [lemma, in lib.Integers]
-eqm_unsigned_repr_l [lemma, in lib.Integers]
-eqm_unsigned_repr_r [lemma, in lib.Integers]
-EQUALITY_TYPE [module, in lib.Maps]
-equal_eq [lemma, in backend.RTLtyping]
-equal_on_range [lemma, in lib.Integers]
-equation_evals_to_holds_1 [lemma, in backend.CSEproof]
-equation_evals_to_holds_2 [lemma, in backend.CSEproof]
-equation_holds [definition, in backend.CSE]
-eq_block [definition, in backend.Values]
-eq_dec [lemma, in lib.Integers]
-eq_dec [axiom, in lib.Floats]
-eq_false [lemma, in lib.Integers]
-eq_list_valnum [definition, in backend.CSE]
-eq_refl [lemma, in lib.Ordered]
-eq_refl [lemma, in lib.Ordered]
-eq_refl [lemma, in lib.Ordered]
-eq_rhs [definition, in backend.CSE]
-eq_spec [lemma, in lib.Integers]
-eq_sym [lemma, in lib.Ordered]
-eq_sym [lemma, in lib.Ordered]
-eq_sym [lemma, in lib.Integers]
-eq_sym [lemma, in lib.Ordered]
-eq_trans [lemma, in lib.Ordered]
-eq_trans [lemma, in lib.Ordered]
-eq_trans [lemma, in lib.Ordered]
-eq_true [lemma, in lib.Integers]
-eq_valnum [definition, in backend.CSE]
-eq_zero_false [axiom, in lib.Floats]
-eq_zero_true [axiom, in lib.Floats]
-Error [constructor, in backend.RTLgen]
-error [definition, in backend.RTLtyping]
-error [definition, in backend.RTLgen]
-Error [constructor, in backend.PPC]
-error_inconsistent [lemma, in backend.RTLtyping]
-Estore [constructor, in backend.Cminor]
-Estore [constructor, in backend.Csharpminor]
-eval_absfloat [lemma, in backend.Cmconstrproof]
-eval_add [lemma, in backend.Cmconstrproof]
-eval_addf [lemma, in backend.Cmconstrproof]
-eval_addimm [lemma, in backend.Cmconstrproof]
-eval_addimm_ptr [lemma, in backend.Cmconstrproof]
-eval_addressing [lemma, in backend.Cmconstrproof]
-eval_addressing [definition, in backend.Op]
-eval_addressing_preserved [lemma, in backend.Op]
-eval_addressing_total [definition, in backend.Op]
-eval_addressing_weaken [lemma, in backend.Op]
-eval_add_ptr [lemma, in backend.Cmconstrproof]
-eval_add_ptr_2 [lemma, in backend.Cmconstrproof]
-eval_and [lemma, in backend.Cmconstrproof]
-eval_andimm [lemma, in backend.Cmconstrproof]
-eval_base_condition_of_expr [lemma, in backend.Cmconstrproof]
-eval_cast16signed [lemma, in backend.Cmconstrproof]
-eval_cast16unsigned [lemma, in backend.Cmconstrproof]
-eval_cast8signed [lemma, in backend.Cmconstrproof]
-eval_cast8unsigned [lemma, in backend.Cmconstrproof]
-eval_cmp [lemma, in backend.Cmconstrproof]
-eval_cmpf [lemma, in backend.Cmconstrproof]
-eval_cmpu [lemma, in backend.Cmconstrproof]
-eval_cmp_null_l [lemma, in backend.Cmconstrproof]
-eval_cmp_null_r [lemma, in backend.Cmconstrproof]
-eval_cmp_ptr [lemma, in backend.Cmconstrproof]
-eval_compare_null [definition, in backend.Op]
-eval_compare_null [definition, in backend.Csharpminor]
-eval_compare_null_weaken [lemma, in backend.Op]
-eval_condition [definition, in backend.Op]
-eval_conditionalexpr_false [lemma, in backend.Cmconstrproof]
-eval_conditionalexpr_true [lemma, in backend.Cmconstrproof]
-eval_condition_of_expr [lemma, in backend.Cmconstrproof]
-eval_condition_total [definition, in backend.Op]
-eval_condition_total_is_bool [lemma, in backend.Op]
-eval_condition_weaken [lemma, in backend.Op]
-eval_divf [lemma, in backend.Cmconstrproof]
-eval_divs [lemma, in backend.Cmconstrproof]
-eval_divu [lemma, in backend.Cmconstrproof]
-eval_divu_base [lemma, in backend.Cmconstrproof]
-eval_Evar [constructor, in backend.Csharpminor]
-eval_Evar [constructor, in backend.Cminor]
-eval_expr [inductive, in backend.Csharpminor]
-eval_expr [inductive, in backend.Cminor]
-eval_exprlist_prop [definition, in backend.Cminorgenproof]
-eval_expr_prop [definition, in backend.Cminorgenproof]
-eval_floatofint [lemma, in backend.Cmconstrproof]
-eval_floatofintu [lemma, in backend.Cmconstrproof]
-eval_funcall_prop [definition, in backend.Cminorgenproof]
-eval_intoffloat [lemma, in backend.Cmconstrproof]
-eval_lift [lemma, in backend.Cmconstrproof]
-eval_lift_expr [lemma, in backend.Cmconstrproof]
-eval_load [lemma, in backend.Cmconstrproof]
-eval_mods [lemma, in backend.Cmconstrproof]
-eval_modu [lemma, in backend.Cmconstrproof]
-eval_mod_aux [lemma, in backend.Cmconstrproof]
-eval_mul [lemma, in backend.Cmconstrproof]
-eval_mulf [lemma, in backend.Cmconstrproof]
-eval_mulimm [lemma, in backend.Cmconstrproof]
-eval_mulimm_base [lemma, in backend.Cmconstrproof]
-eval_negate_condition [lemma, in backend.Op]
-eval_negfloat [lemma, in backend.Cmconstrproof]
-eval_negint [lemma, in backend.Cmconstrproof]
-eval_notbool [lemma, in backend.Cmconstrproof]
-eval_notbool_base [lemma, in backend.Cmconstrproof]
-eval_notint [lemma, in backend.Cmconstrproof]
-eval_operation [definition, in backend.Op]
-eval_operation [definition, in backend.Csharpminor]
-eval_operation_preserved [lemma, in backend.Op]
-eval_operation_total [definition, in backend.Op]
-eval_operation_weaken [lemma, in backend.Op]
-eval_or [lemma, in backend.Cmconstrproof]
-eval_rolm [lemma, in backend.Cmconstrproof]
-eval_shl [lemma, in backend.Cmconstrproof]
-eval_shlimm [lemma, in backend.Cmconstrproof]
-eval_shr [lemma, in backend.Cmconstrproof]
-eval_shru [lemma, in backend.Cmconstrproof]
-eval_shruimm [lemma, in backend.Cmconstrproof]
-eval_singleoffloat [lemma, in backend.Cmconstrproof]
-eval_static_condition [definition, in backend.Constprop]
-eval_static_condition_cases [inductive, in backend.Constprop]
-eval_static_condition_case1 [constructor, in backend.Constprop]
-eval_static_condition_case2 [constructor, in backend.Constprop]
-eval_static_condition_case3 [constructor, in backend.Constprop]
-eval_static_condition_case4 [constructor, in backend.Constprop]
-eval_static_condition_case5 [constructor, in backend.Constprop]
-eval_static_condition_case6 [constructor, in backend.Constprop]
-eval_static_condition_case7 [constructor, in backend.Constprop]
-eval_static_condition_case8 [constructor, in backend.Constprop]
-eval_static_condition_correct [lemma, in backend.Constpropproof]
-eval_static_condition_default [constructor, in backend.Constprop]
-eval_static_condition_match [definition, in backend.Constprop]
-eval_static_operation [definition, in backend.Constprop]
-eval_static_operation_cases [inductive, in backend.Constprop]
-eval_static_operation_case1 [constructor, in backend.Constprop]
-eval_static_operation_case11 [constructor, in backend.Constprop]
-eval_static_operation_case12 [constructor, in backend.Constprop]
-eval_static_operation_case13 [constructor, in backend.Constprop]
-eval_static_operation_case14 [constructor, in backend.Constprop]
-eval_static_operation_case15 [constructor, in backend.Constprop]
-eval_static_operation_case16 [constructor, in backend.Constprop]
-eval_static_operation_case17 [constructor, in backend.Constprop]
-eval_static_operation_case18 [constructor, in backend.Constprop]
-eval_static_operation_case19 [constructor, in backend.Constprop]
-eval_static_operation_case2 [constructor, in backend.Constprop]
-eval_static_operation_case20 [constructor, in backend.Constprop]
-eval_static_operation_case21 [constructor, in backend.Constprop]
-eval_static_operation_case22 [constructor, in backend.Constprop]
-eval_static_operation_case23 [constructor, in backend.Constprop]
-eval_static_operation_case24 [constructor, in backend.Constprop]
-eval_static_operation_case25 [constructor, in backend.Constprop]
-eval_static_operation_case26 [constructor, in backend.Constprop]
-eval_static_operation_case27 [constructor, in backend.Constprop]
-eval_static_operation_case28 [constructor, in backend.Constprop]
-eval_static_operation_case29 [constructor, in backend.Constprop]
-eval_static_operation_case3 [constructor, in backend.Constprop]
-eval_static_operation_case30 [constructor, in backend.Constprop]
-eval_static_operation_case31 [constructor, in backend.Constprop]
-eval_static_operation_case32 [constructor, in backend.Constprop]
-eval_static_operation_case33 [constructor, in backend.Constprop]
-eval_static_operation_case34 [constructor, in backend.Constprop]
-eval_static_operation_case35 [constructor, in backend.Constprop]
-eval_static_operation_case36 [constructor, in backend.Constprop]
-eval_static_operation_case37 [constructor, in backend.Constprop]
-eval_static_operation_case38 [constructor, in backend.Constprop]
-eval_static_operation_case39 [constructor, in backend.Constprop]
-eval_static_operation_case4 [constructor, in backend.Constprop]
-eval_static_operation_case40 [constructor, in backend.Constprop]
-eval_static_operation_case41 [constructor, in backend.Constprop]
-eval_static_operation_case42 [constructor, in backend.Constprop]
-eval_static_operation_case43 [constructor, in backend.Constprop]
-eval_static_operation_case44 [constructor, in backend.Constprop]
-eval_static_operation_case45 [constructor, in backend.Constprop]
-eval_static_operation_case46 [constructor, in backend.Constprop]
-eval_static_operation_case47 [constructor, in backend.Constprop]
-eval_static_operation_case6 [constructor, in backend.Constprop]
-eval_static_operation_case7 [constructor, in backend.Constprop]
-eval_static_operation_case8 [constructor, in backend.Constprop]
-eval_static_operation_case9 [constructor, in backend.Constprop]
-eval_static_operation_correct [lemma, in backend.Constpropproof]
-eval_static_operation_default [constructor, in backend.Constprop]
-eval_static_operation_match [definition, in backend.Constprop]
-eval_store [lemma, in backend.Cmconstrproof]
-eval_sub [lemma, in backend.Cmconstrproof]
-eval_subf [lemma, in backend.Cmconstrproof]
-eval_sub_ptr_int [lemma, in backend.Cmconstrproof]
-eval_sub_ptr_ptr [lemma, in backend.Cmconstrproof]
-eval_xor [lemma, in backend.Cmconstrproof]
-Evar [constructor, in backend.Cminor]
-Evar [constructor, in backend.Csharpminor]
-exec [definition, in backend.Parallelmove]
-exec_Bgetstack [constructor, in backend.LTL]
-exec_blocks_Bgoto_inv [lemma, in backend.Tunnelingproof]
-exec_blocks_extends [lemma, in backend.LTL]
-exec_blocks_prop [definition, in backend.Linearizeproof]
-exec_blocks_prop [definition, in backend.Tunnelingproof]
-exec_blocks_valid_outcome [lemma, in backend.Linearizeproof]
-exec_block_Bgoto_inv [lemma, in backend.Tunnelingproof]
-exec_block_prop [definition, in backend.Linearizeproof]
-exec_block_prop [definition, in backend.Tunnelingproof]
-exec_function_body_prop [definition, in backend.Machabstr2mach]
-exec_function_body_prop [definition, in backend.PPCgenproof]
-exec_function_body_prop [definition, in backend.Machtyping]
-exec_function_body_prop_ [lemma, in backend.PPCgenproof]
-exec_function_equiv [lemma, in backend.Machabstr2mach]
-exec_function_prop [definition, in backend.Stackingproof]
-exec_function_prop [definition, in backend.Machtyping]
-exec_function_prop [definition, in backend.PPCgenproof]
-exec_function_prop [definition, in backend.Constpropproof]
-exec_function_prop [definition, in backend.Linearizeproof]
-exec_function_prop [definition, in backend.Machabstr2mach]
-exec_function_prop [definition, in backend.CSEproof]
-exec_function_prop [definition, in backend.Tunnelingproof]
-exec_function_prop [definition, in backend.Allocproof]
-exec_function_prop_ [lemma, in backend.PPCgenproof]
-exec_function_subject_reduction [definition, in backend.RTLtyping]
-exec_ifthenelse_false [lemma, in backend.Cmconstrproof]
-exec_ifthenelse_true [lemma, in backend.Cmconstrproof]
-exec_Iload [constructor, in backend.RTL]
-exec_Iload' [lemma, in backend.RTL]
-exec_Inop [constructor, in backend.RTL]
-exec_instr [inductive, in backend.Machabstr]
-exec_instr [inductive, in backend.RTL]
-exec_instr [inductive, in backend.LTL]
-exec_instr [inductive, in backend.Linear]
-exec_instr [inductive, in backend.Mach]
-exec_instr [definition, in backend.PPC]
-exec_instrs_Bgoto_inv [lemma, in backend.Tunnelingproof]
-exec_instrs_extends [lemma, in backend.RTLgenproof1]
-exec_instrs_extends_rec [lemma, in backend.RTLgenproof1]
-exec_instrs_incl [lemma, in backend.Stackingproof]
-exec_instrs_incl [lemma, in backend.PPCgenproof]
-exec_instrs_incr [lemma, in backend.RTLgenproof1]
-exec_instrs_link_invariant [lemma, in backend.Machtyping]
-exec_instrs_pmov [lemma, in backend.Allocproof_aux]
-exec_instrs_present [lemma, in backend.RTL]
-exec_instrs_prop [definition, in backend.Allocproof]
-exec_instrs_prop [definition, in backend.Tunnelingproof]
-exec_instrs_prop [definition, in backend.Machabstr2mach]
-exec_instrs_prop [definition, in backend.CSEproof]
-exec_instrs_prop [definition, in backend.Constpropproof]
-exec_instrs_prop [definition, in backend.Linearizeproof]
-exec_instr_extends [lemma, in backend.RTLgenproof1]
-exec_instr_extends_rec [lemma, in backend.RTLgenproof1]
-exec_instr_incl [lemma, in backend.PPCgenproof]
-exec_instr_incl [lemma, in backend.Stackingproof]
-exec_instr_incr [lemma, in backend.RTLgenproof1]
-exec_instr_in_s2 [lemma, in backend.RTLgenproof1]
-exec_instr_link_invariant [lemma, in backend.Machtyping]
-exec_instr_not_halt [lemma, in backend.RTLgenproof1]
-exec_instr_present [lemma, in backend.RTL]
-exec_instr_prop [definition, in backend.Allocproof]
-exec_instr_prop [definition, in backend.Machabstr2mach]
-exec_instr_prop [definition, in backend.Machtyping]
-exec_instr_prop [definition, in backend.Constpropproof]
-exec_instr_prop [definition, in backend.CSEproof]
-exec_instr_prop [definition, in backend.Tunnelingproof]
-exec_instr_prop [definition, in backend.Stackingproof]
-exec_instr_prop [definition, in backend.Linearizeproof]
-exec_instr_prop [definition, in backend.PPCgenproof]
-exec_instr_subject_reduction [definition, in backend.RTLtyping]
-exec_instr_update [lemma, in backend.Allocproof_aux]
-exec_Iop [constructor, in backend.RTL]
-exec_Iop' [lemma, in backend.RTL]
-exec_Lgetstack [constructor, in backend.Linear]
-exec_Mcall_prop [lemma, in backend.PPCgenproof]
-exec_Mcond_false_prop [lemma, in backend.PPCgenproof]
-exec_Mcond_true_prop [lemma, in backend.PPCgenproof]
-exec_Mgetparam [constructor, in backend.Mach]
-exec_Mgetparam_prop [lemma, in backend.PPCgenproof]
-exec_Mgetstack [constructor, in backend.Mach]
-exec_Mgetstack [constructor, in backend.Machabstr]
-exec_Mgetstack' [lemma, in backend.Stackingproof]
-exec_Mgetstack_prop [lemma, in backend.PPCgenproof]
-exec_Mgoto_prop [lemma, in backend.PPCgenproof]
-exec_Mlabel [constructor, in backend.Mach]
-exec_Mlabel [constructor, in backend.Machabstr]
-exec_Mlabel_prop [lemma, in backend.PPCgenproof]
-exec_Mload_prop [lemma, in backend.PPCgenproof]
-exec_Mop_prop [lemma, in backend.PPCgenproof]
-exec_Msetstack [constructor, in backend.Mach]
-exec_Msetstack' [lemma, in backend.Stackingproof]
-exec_Msetstack_prop [lemma, in backend.PPCgenproof]
-exec_Mstore_prop [lemma, in backend.PPCgenproof]
-exec_mutual_induction [lemma, in backend.Machabstr]
-exec_one [constructor, in backend.PPC]
-exec_one_prop [lemma, in backend.PPCgenproof]
-exec_program [definition, in backend.Csharpminor]
-exec_program [definition, in backend.LTL]
-exec_program [definition, in backend.Cminor]
-exec_program [definition, in backend.RTL]
-exec_program [definition, in backend.Mach]
-exec_program [definition, in backend.Machabstr]
-exec_program [definition, in backend.Linear]
-exec_program [definition, in backend.PPC]
-exec_program_equiv [lemma, in backend.Machabstr2mach]
-exec_refl [constructor, in backend.PPC]
-exec_refl_prop [lemma, in backend.PPCgenproof]
-exec_step [lemma, in backend.RTL]
-exec_step [inductive, in backend.PPC]
-exec_steps [inductive, in backend.PPC]
-exec_step_intro [constructor, in backend.PPC]
-exec_stmtlist_prop [definition, in backend.Cminorgenproof]
-exec_stmt_prop [definition, in backend.Cminorgenproof]
-exec_straight [inductive, in backend.PPCgenproof1]
-exec_straight_exec_prop [lemma, in backend.PPCgenproof]
-exec_straight_one [lemma, in backend.PPCgenproof1]
-exec_straight_refl [constructor, in backend.PPCgenproof1]
-exec_straight_step [constructor, in backend.PPCgenproof1]
-exec_straight_steps [lemma, in backend.PPCgenproof]
-exec_straight_steps_1 [lemma, in backend.PPCgenproof]
-exec_straight_steps_2 [lemma, in backend.PPCgenproof]
-exec_straight_three [lemma, in backend.PPCgenproof1]
-exec_straight_trans [lemma, in backend.PPCgenproof1]
-exec_straight_two [lemma, in backend.PPCgenproof1]
-exec_trans [constructor, in backend.PPC]
-exec_trans_prop [lemma, in backend.PPCgenproof]
-expr [inductive, in backend.Csharpminor]
-expr [inductive, in backend.Cminor]
-exprlist [inductive, in backend.Csharpminor]
-exprlist [inductive, in backend.Cminor]
-expr_condexpr_exprlist_ind [lemma, in backend.RTLgenproof1]
-exten [lemma, in lib.Maps]
-extends [definition, in backend.Mem]
-extends_refl [lemma, in backend.Mem]
-extend_inject [definition, in backend.Mem]
-extend_inject_incr [lemma, in backend.Mem]
-extensionality [axiom, in lib.Coqlib]
-

F

-find_funct [definition, in backend.Globalenvs]
-find_function [definition, in backend.LTL]
-find_function [definition, in backend.Mach]
-find_function [definition, in backend.RTL]
-find_function [definition, in backend.Linear]
-find_function2 [definition, in backend.Allocproof]
-find_funct_find_funct_ptr [lemma, in backend.Globalenvs]
-find_funct_inv [lemma, in backend.Globalenvs]
-find_funct_prop [lemma, in backend.Globalenvs]
-find_funct_ptr [definition, in backend.Globalenvs]
-find_funct_ptr_inv [lemma, in backend.Globalenvs]
-find_funct_ptr_prop [lemma, in backend.Globalenvs]
-find_funct_ptr_transf [lemma, in backend.Globalenvs]
-find_funct_ptr_transf_partial [lemma, in backend.Globalenvs]
-find_funct_transf [lemma, in backend.Globalenvs]
-find_funct_transf_partial [lemma, in backend.Globalenvs]
-find_instr [definition, in backend.PPC]
-find_instr_in [lemma, in backend.PPCgenproof]
-find_instr_tail [lemma, in backend.PPCgenproof]
-find_label [definition, in backend.Mach]
-find_label [definition, in backend.PPCgenproof]
-find_label [definition, in backend.Linear]
-find_label_cleanup_code [lemma, in backend.Linearizeproof]
-find_label_goto_label [lemma, in backend.PPCgenproof]
-find_label_incl [lemma, in backend.Stackingproof]
-find_label_lin [lemma, in backend.Linearizeproof]
-find_label_lin_block [lemma, in backend.Linearizeproof]
-find_label_lin_rec [lemma, in backend.Linearizeproof]
-find_label_transl_code [lemma, in backend.Stackingproof]
-find_label_unique [lemma, in backend.Linearizeproof]
-find_letvar [definition, in backend.RTLgen]
-find_letvar_incr [lemma, in backend.RTLgenproof1]
-find_letvar_in_map [lemma, in backend.RTLgenproof1]
-find_letvar_not_mutated [lemma, in backend.RTLgenproof1]
-find_letvar_valid [lemma, in backend.RTLgenproof1]
-find_load [definition, in backend.CSE]
-find_load_correct [lemma, in backend.CSEproof]
-find_op [definition, in backend.CSE]
-find_op_correct [lemma, in backend.CSEproof]
-find_rhs [definition, in backend.CSE]
-find_rhs_correct [lemma, in backend.CSEproof]
-find_symbol [definition, in backend.Globalenvs]
-find_symbol_inv [lemma, in backend.Globalenvs]
-find_symbol_offset [definition, in backend.Op]
-find_symbol_transf [lemma, in backend.Globalenvs]
-find_symbol_transf_partial [lemma, in backend.Globalenvs]
-find_valnum_rhs [definition, in backend.CSE]
-find_valnum_rhs_correct [lemma, in backend.CSEproof]
-find_var [definition, in backend.RTLgen]
-find_var_incr [lemma, in backend.RTLgenproof1]
-find_var_in_map [lemma, in backend.RTLgenproof1]
-find_var_not_mutated [lemma, in backend.RTLgenproof1]
-find_var_valid [lemma, in backend.RTLgenproof1]
-fixpoint [definition, in backend.Kildall]
-fixpoint [definition, in backend.Kildall]
-fixpoint [definition, in backend.Kildall]
-fixpoint_entry [lemma, in backend.Kildall]
-fixpoint_entry [lemma, in backend.Kildall]
-fixpoint_entry [lemma, in backend.Kildall]
-fixpoint_incr [lemma, in backend.Kildall]
-fixpoint_invariant [lemma, in backend.Kildall]
-fixpoint_solution [lemma, in backend.Kildall]
-fixpoint_solution [lemma, in backend.Kildall]
-fixpoint_solution [lemma, in backend.Kildall]
-FI_arg [constructor, in backend.Stacking]
-FI_local [constructor, in backend.Stacking]
-FI_saved_float [constructor, in backend.Stacking]
-FI_saved_int [constructor, in backend.Stacking]
-flatten [definition, in lib.Inclusion]
-flatten_aux [definition, in lib.Inclusion]
-flatten_aux_valid_A [lemma, in lib.Inclusion]
-flatten_valid_A [lemma, in lib.Inclusion]
-float [axiom, in lib.Floats]
-Float [module, in lib.Floats]
-floatcomp [definition, in backend.PPCgen]
-floatcomp_correct [lemma, in backend.PPCgenproof1]
-floatofint [definition, in backend.Values]
-floatofint [axiom, in lib.Floats]
-floatofint [definition, in backend.Cmconstr]
-floatofintu [definition, in backend.Cmconstr]
-floatofintu [definition, in backend.Values]
-floatofintu [axiom, in lib.Floats]
-Floats [library]
-float_callee_save [definition, in backend.Lineartyping]
-float_callee_save_bound [lemma, in backend.Linearizetyping]
-float_callee_save_norepet [lemma, in backend.Conventions]
-float_callee_save_not_destroyed [lemma, in backend.Conventions]
-float_callee_save_regs [definition, in backend.Conventions]
-float_callee_save_type [lemma, in backend.Conventions]
-float_local [definition, in backend.Lineartyping]
-float_local_slot_bound [lemma, in backend.Linearizetyping]
-float_param_regs [definition, in backend.Conventions]
-fn_params_names [definition, in backend.Csharpminor]
-fn_variables [definition, in backend.Csharpminor]
-fn_vars_names [definition, in backend.Csharpminor]
-fold [definition, in lib.Sets]
-fold [definition, in lib.Maps]
-fold2 [definition, in backend.RTLtyping]
-fold_spec [lemma, in lib.Maps]
-fold_spec [lemma, in lib.Sets]
-for_all [definition, in lib.Sets]
-for_all_spec [lemma, in lib.Sets]
-Fpmov_correct [lemma, in backend.Parallelmove]
-Fpmov_correctMoves [lemma, in backend.Parallelmove]
-Fpmov_correct1 [lemma, in backend.Parallelmove]
-Fpmov_correct2 [lemma, in backend.Parallelmove]
-Fpmov_correct_ext [lemma, in backend.Parallelmove]
-Fpmov_correct_IT3 [lemma, in backend.Parallelmove]
-Fpmov_correct_map [lemma, in backend.Parallelmove]
-FPR0 [constructor, in backend.PPC]
-FPR1 [constructor, in backend.PPC]
-FPR10 [constructor, in backend.PPC]
-FPR11 [constructor, in backend.PPC]
-FPR12 [constructor, in backend.PPC]
-FPR13 [constructor, in backend.PPC]
-FPR14 [constructor, in backend.PPC]
-FPR15 [constructor, in backend.PPC]
-FPR16 [constructor, in backend.PPC]
-FPR17 [constructor, in backend.PPC]
-FPR18 [constructor, in backend.PPC]
-FPR19 [constructor, in backend.PPC]
-FPR2 [constructor, in backend.PPC]
-FPR20 [constructor, in backend.PPC]
-FPR21 [constructor, in backend.PPC]
-FPR22 [constructor, in backend.PPC]
-FPR23 [constructor, in backend.PPC]
-FPR24 [constructor, in backend.PPC]
-FPR25 [constructor, in backend.PPC]
-FPR26 [constructor, in backend.PPC]
-FPR27 [constructor, in backend.PPC]
-FPR28 [constructor, in backend.PPC]
-FPR29 [constructor, in backend.PPC]
-FPR3 [constructor, in backend.PPC]
-FPR30 [constructor, in backend.PPC]
-FPR31 [constructor, in backend.PPC]
-FPR4 [constructor, in backend.PPC]
-FPR5 [constructor, in backend.PPC]
-FPR6 [constructor, in backend.PPC]
-FPR7 [constructor, in backend.PPC]
-FPR8 [constructor, in backend.PPC]
-FPR9 [constructor, in backend.PPC]
-FR [constructor, in backend.PPC]
-frame [inductive, in backend.Cminorgenproof]
-frame [definition, in backend.Machabstr]
-frame_env [inductive, in backend.Stacking]
-frame_index [inductive, in backend.Stacking]
-frame_match [inductive, in backend.Machabstr2mach]
-frame_match_alloc [lemma, in backend.Machabstr2mach]
-frame_match_exten [lemma, in backend.Machabstr2mach]
-frame_match_free [lemma, in backend.Machabstr2mach]
-frame_match_get_slot [lemma, in backend.Machabstr2mach]
-frame_match_intro [constructor, in backend.Machabstr2mach]
-frame_match_load [lemma, in backend.Machabstr2mach]
-frame_match_new [lemma, in backend.Machabstr2mach]
-frame_match_set_slot [lemma, in backend.Machabstr2mach]
-frame_match_store [lemma, in backend.Machabstr2mach]
-frame_match_store_ok [lemma, in backend.Machabstr2mach]
-frame_match_store_stack_other [lemma, in backend.Machabstr2mach]
-free [definition, in backend.Mem]
-free_empty_bounds [lemma, in backend.Mem]
-free_extends [lemma, in backend.Mem]
-free_first_inject [lemma, in backend.Mem]
-free_first_list_inject [lemma, in backend.Mem]
-free_inject [lemma, in backend.Mem]
-free_list [definition, in backend.Mem]
-free_snd_inject [lemma, in backend.Mem]
-freg [inductive, in backend.PPC]
-freg_eq [lemma, in backend.PPC]
-freg_of [definition, in backend.PPCgen]
-freg_of_is_data_reg [lemma, in backend.PPCgenproof1]
-freg_of_not_FPR13 [lemma, in backend.PPCgenproof1]
-freg_val [lemma, in backend.PPCgenproof1]
-fresh_block_alloc [lemma, in backend.Mem]
-FT1 [constructor, in backend.Locations]
-FT2 [constructor, in backend.Locations]
-FT3 [constructor, in backend.Locations]
-function [inductive, in backend.Mach]
-function [inductive, in backend.Csharpminor]
-function [inductive, in backend.RTL]
-function [inductive, in backend.LTL]
-function [inductive, in backend.Cminor]
-function [inductive, in backend.Linear]
-functions_globalenv [lemma, in backend.Globalenvs]
-functions_translated [lemma, in backend.Constpropproof]
-functions_translated [lemma, in backend.Tunnelingproof]
-functions_translated [lemma, in backend.PPCgenproof]
-functions_translated [lemma, in backend.Allocproof]
-functions_translated [lemma, in backend.Linearizeproof]
-functions_translated [lemma, in backend.Stackingproof]
-functions_translated [lemma, in backend.CSEproof]
-functions_translated [lemma, in backend.Cminorgenproof]
-functions_translated [lemma, in backend.RTLgenproof]
-functions_translated_no_overflow [lemma, in backend.PPCgenproof]
-functions_translated_2 [lemma, in backend.PPCgenproof]
-function_bounds [definition, in backend.Lineartyping]
-function_entry_ok [lemma, in backend.Cminorgenproof]
-function_ptr_translated [lemma, in backend.Linearizeproof]
-function_ptr_translated [lemma, in backend.Allocproof]
-function_ptr_translated [lemma, in backend.Stackingproof]
-function_ptr_translated [lemma, in backend.Cminorgenproof]
-function_ptr_translated [lemma, in backend.RTLgenproof]
-function_ptr_translated [lemma, in backend.Constpropproof]
-function_ptr_translated [lemma, in backend.Tunnelingproof]
-funct_ptr_translated [lemma, in backend.CSEproof]
-F1 [constructor, in backend.Locations]
-F10 [constructor, in backend.Locations]
-F14 [constructor, in backend.Locations]
-F15 [constructor, in backend.Locations]
-F16 [constructor, in backend.Locations]
-F17 [constructor, in backend.Locations]
-F18 [constructor, in backend.Locations]
-F19 [constructor, in backend.Locations]
-F2 [constructor, in backend.Locations]
-f2ind [lemma, in backend.Parallelmove]
-f2ind' [lemma, in backend.Parallelmove]
-F20 [constructor, in backend.Locations]
-F21 [constructor, in backend.Locations]
-F22 [constructor, in backend.Locations]
-F23 [constructor, in backend.Locations]
-F24 [constructor, in backend.Locations]
-F25 [constructor, in backend.Locations]
-F26 [constructor, in backend.Locations]
-F27 [constructor, in backend.Locations]
-F28 [constructor, in backend.Locations]
-F29 [constructor, in backend.Locations]
-F3 [constructor, in backend.Locations]
-F30 [constructor, in backend.Locations]
-F31 [constructor, in backend.Locations]
-F4 [constructor, in backend.Locations]
-F5 [constructor, in backend.Locations]
-F6 [constructor, in backend.Locations]
-F7 [constructor, in backend.Locations]
-F8 [constructor, in backend.Locations]
-F9 [constructor, in backend.Locations]
-

G

-gcombine [lemma, in lib.Maps]
-ge [definition, in lib.Lattice]
-ge [definition, in backend.CSE]
-ge [definition, in lib.Lattice]
-ge [definition, in backend.Constprop]
-ge [definition, in lib.Lattice]
-ge [definition, in lib.Sets]
-gempty [lemma, in lib.Maps]
-genv [definition, in backend.Cminor]
-genv [definition, in backend.LTL]
-Genv [module, in backend.Globalenvs]
-genv [definition, in backend.PPC]
-GENV [module, in backend.Globalenvs]
-genv [definition, in backend.Csharpminor]
-genv [inductive, in backend.Globalenvs]
-genv [definition, in backend.RTL]
-genv [definition, in backend.Mach]
-genv [definition, in backend.Linear]
-get [definition, in lib.Maps]
-get [definition, in lib.Maps]
-get [definition, in lib.Maps]
-Get [definition, in backend.Parallelmove]
-get [definition, in backend.Locations]
-get [definition, in lib.Lattice]
-get [definition, in lib.Maps]
-get [definition, in backend.Parallelmove]
-get [definition, in backend.RTLtyping]
-getdst [definition, in backend.Parallelmove]
-getdst_add [lemma, in backend.Parallelmove]
-getdst_app [lemma, in backend.Parallelmove]
-getdst_f [lemma, in backend.Alloctyping_aux]
-getdst_lists2moves [lemma, in backend.Allocproof_aux]
-getdst_map [lemma, in backend.Parallelmove]
-getN [definition, in backend.Mem]
-getN_agree [lemma, in backend.Mem]
-getN_init [lemma, in backend.Mem]
-getN_inject [lemma, in backend.Mem]
-getN_setN_mismatch [lemma, in backend.Mem]
-getN_setN_other [lemma, in backend.Mem]
-getN_setN_overlap [lemma, in backend.Mem]
-getN_setN_same [lemma, in backend.Mem]
-getsrc [definition, in backend.Parallelmove]
-getsrcdst_app [lemma, in backend.Allocproof_aux]
-getsrc_add [lemma, in backend.Parallelmove]
-getsrc_add1 [lemma, in backend.Parallelmove]
-getsrc_app [lemma, in backend.Parallelmove]
-getsrc_f [lemma, in backend.Alloctyping_aux]
-getsrc_map [lemma, in backend.Parallelmove]
-get_add_1 [lemma, in backend.RTLtyping]
-get_add_2 [lemma, in backend.RTLtyping]
-get_bot [lemma, in lib.Lattice]
-get_empty [lemma, in backend.RTLtyping]
-get_noWrite [lemma, in backend.Parallelmove]
-get_pexec_id_noWrite [lemma, in backend.Parallelmove]
-get_slot [inductive, in backend.Machabstr]
-get_slot_index [lemma, in backend.Stackingproof]
-get_slot_intro [constructor, in backend.Machabstr]
-get_slot_ok [lemma, in backend.Stackingproof]
-get_top [lemma, in lib.Lattice]
-get_update [lemma, in backend.Parallelmove]
-get_update_diff [lemma, in backend.Parallelmove]
-get_update_id [lemma, in backend.Parallelmove]
-get_update_ndiff [lemma, in backend.Parallelmove]
-get_xget_h [lemma, in lib.Maps]
-ge_bot [lemma, in lib.Lattice]
-ge_bot [lemma, in lib.Lattice]
-ge_bot [lemma, in lib.Sets]
-ge_bot [lemma, in lib.Lattice]
-ge_bot [lemma, in backend.Constprop]
-ge_lub_left [lemma, in lib.Lattice]
-ge_lub_left [lemma, in lib.Sets]
-ge_lub_left [lemma, in backend.Constprop]
-ge_lub_left [lemma, in lib.Lattice]
-ge_lub_left [lemma, in lib.Lattice]
-ge_lub_right [lemma, in lib.Sets]
-ge_refl [lemma, in lib.Lattice]
-ge_refl [lemma, in lib.Sets]
-ge_refl [lemma, in lib.Lattice]
-ge_refl [lemma, in lib.Lattice]
-ge_refl [lemma, in backend.Constprop]
-ge_top [lemma, in lib.Lattice]
-ge_top [lemma, in backend.Constprop]
-ge_top [lemma, in lib.Lattice]
-ge_top [lemma, in lib.Lattice]
-ge_trans [lemma, in lib.Lattice]
-ge_trans [lemma, in backend.Constprop]
-ge_trans [lemma, in lib.Sets]
-ge_trans [lemma, in lib.Lattice]
-ge_trans [lemma, in lib.Lattice]
-gi [lemma, in lib.Maps]
-gi [lemma, in lib.Maps]
-gi [lemma, in lib.Maps]
-gleaf [lemma, in lib.Maps]
-globalenv [definition, in backend.Globalenvs]
-Globalenvs [library]
-globalenv_initmem [definition, in backend.Globalenvs]
-gmap [lemma, in lib.Maps]
-gmap [lemma, in lib.Maps]
-gmap [lemma, in lib.Maps]
-gmap [lemma, in lib.Maps]
-good_state [definition, in backend.Kildall]
-goto_label [definition, in backend.PPC]
-GPR0 [constructor, in backend.PPC]
-GPR1 [constructor, in backend.PPC]
-GPR10 [constructor, in backend.PPC]
-GPR11 [constructor, in backend.PPC]
-GPR12 [constructor, in backend.PPC]
-GPR13 [constructor, in backend.PPC]
-GPR14 [constructor, in backend.PPC]
-GPR15 [constructor, in backend.PPC]
-GPR16 [constructor, in backend.PPC]
-GPR17 [constructor, in backend.PPC]
-GPR18 [constructor, in backend.PPC]
-GPR19 [constructor, in backend.PPC]
-GPR2 [constructor, in backend.PPC]
-GPR20 [constructor, in backend.PPC]
-GPR21 [constructor, in backend.PPC]
-GPR22 [constructor, in backend.PPC]
-GPR23 [constructor, in backend.PPC]
-GPR24 [constructor, in backend.PPC]
-GPR25 [constructor, in backend.PPC]
-GPR26 [constructor, in backend.PPC]
-GPR27 [constructor, in backend.PPC]
-GPR28 [constructor, in backend.PPC]
-GPR29 [constructor, in backend.PPC]
-GPR3 [constructor, in backend.PPC]
-GPR30 [constructor, in backend.PPC]
-GPR31 [constructor, in backend.PPC]
-GPR4 [constructor, in backend.PPC]
-GPR5 [constructor, in backend.PPC]
-GPR6 [constructor, in backend.PPC]
-GPR7 [constructor, in backend.PPC]
-GPR8 [constructor, in backend.PPC]
-GPR9 [constructor, in backend.PPC]
-gpr_or_zero [definition, in backend.PPC]
-gpr_or_zero_not_zero [lemma, in backend.PPCgenproof1]
-gpr_or_zero_zero [lemma, in backend.PPCgenproof1]
-graph [inductive, in backend.InterfGraph]
-graph_coloring [axiom, in backend.Coloring]
-graph_incl [definition, in backend.InterfGraph]
-graph_incl_refl [lemma, in backend.Coloringproof]
-graph_incl_trans [lemma, in backend.InterfGraph]
-gro [lemma, in lib.Maps]
-grs [lemma, in lib.Maps]
-gsident [lemma, in lib.Maps]
-gsident [lemma, in lib.Maps]
-gsident [lemma, in lib.Maps]
-gso [lemma, in lib.Maps]
-gso [lemma, in backend.Locations]
-gso [lemma, in lib.Maps]
-gso [lemma, in lib.Maps]
-gso [lemma, in lib.Lattice]
-gso [lemma, in lib.Maps]
-gss [lemma, in lib.Maps]
-gss [lemma, in lib.Maps]
-gss [lemma, in backend.Locations]
-gss [lemma, in lib.Maps]
-gss [lemma, in lib.Lattice]
-gss [lemma, in lib.Maps]
-gsspec [lemma, in lib.Maps]
-gsspec [lemma, in lib.Maps]
-gsspec [lemma, in lib.Maps]
-gsspec [lemma, in lib.Maps]
-

H

-half_modulus [definition, in lib.Integers]
-has_type [definition, in backend.Values]
-has_type_list [definition, in backend.Values]
-head_but_last [definition, in backend.Parallelmove]
-high_bound [definition, in backend.Mem]
-high_bound_alloc [lemma, in backend.Mem]
-high_bound_free [lemma, in backend.Mem]
-high_bound_store [lemma, in backend.Mem]
-high_half_signed [axiom, in backend.PPC]
-high_half_signed_type [axiom, in backend.PPC]
-high_half_signed_zero [lemma, in backend.PPCgenproof1]
-high_half_unsigned [axiom, in backend.PPC]
-high_half_unsigned_type [axiom, in backend.PPC]
-high_half_unsigned_zero [lemma, in backend.PPCgenproof1]
-high_s [definition, in backend.PPCgen]
-high_u [definition, in backend.PPCgen]
-

I

-ident [definition, in backend.AST]
-identify [definition, in lib.union_find]
-identify_aux_decomp [lemma, in lib.union_find]
-identify_base [definition, in lib.union_find]
-identify_base_a_maps_to_b [lemma, in lib.union_find]
-identify_base_b_canon [lemma, in lib.union_find]
-identify_base_order_wf [lemma, in lib.union_find]
-identify_base_repr [lemma, in lib.union_find]
-identify_base_repr_order [lemma, in lib.union_find]
-identify_base_sameclass_1 [lemma, in lib.union_find]
-identify_base_sameclass_2 [lemma, in lib.union_find]
-Identset [module, in backend.Cminorgen]
-ident_eq [definition, in backend.AST]
-ifthenelse [definition, in backend.Cmconstr]
-IMap [module, in lib.Maps]
-immediate [inductive, in backend.PPC]
-immediate [inductive, in backend.PPC]
-immediate [inductive, in backend.PPC]
-immediate [inductive, in backend.PPC]
-immediate [inductive, in backend.PPC]
-immediate [inductive, in backend.PPC]
-included [definition, in backend.RTLtyping]
-included_consistent [lemma, in backend.RTLtyping]
-included_identify [lemma, in backend.RTLtyping]
-included_mapped [lemma, in backend.RTLtyping]
-included_mapped_forall [lemma, in backend.RTLtyping]
-included_refl [lemma, in backend.RTLtyping]
-included_trans [lemma, in backend.RTLtyping]
-Inclusion [library]
-inclusion_theorem [lemma, in lib.Inclusion]
-incl_app_inv_l [lemma, in lib.Coqlib]
-incl_app_inv_r [lemma, in lib.Coqlib]
-incl_cons_inv [lemma, in lib.Coqlib]
-incl_dst [lemma, in backend.Alloctyping_aux]
-incl_find_label [lemma, in backend.Machtyping]
-incl_nil [lemma, in backend.Alloctyping_aux]
-incl_same_head [lemma, in lib.Coqlib]
-incl_src [lemma, in backend.Alloctyping_aux]
-Incoming [constructor, in backend.Locations]
-Incoming [inductive, in backend.LTLtyping]
-Incoming [inductive, in backend.Lineartyping]
-index [definition, in backend.Locations]
-index [definition, in lib.Maps]
-index [definition, in lib.Maps]
-IndexedMreg [module, in backend.Locations]
-INDEXED_TYPE [module, in lib.Maps]
-index_arg_valid [lemma, in backend.Stackingproof]
-index_diff [definition, in backend.Stackingproof]
-index_float_callee_save [definition, in backend.Conventions]
-index_float_callee_save_inj [lemma, in backend.Conventions]
-index_float_callee_save_pos [lemma, in backend.Conventions]
-index_float_callee_save_pos2 [lemma, in backend.Conventions]
-index_inj [lemma, in lib.Maps]
-index_inj [lemma, in backend.Locations]
-index_inj [lemma, in lib.Maps]
-index_int_callee_save [definition, in backend.Conventions]
-index_int_callee_save_inj [lemma, in backend.Conventions]
-index_int_callee_save_pos [lemma, in backend.Conventions]
-index_int_callee_save_pos2 [lemma, in backend.Conventions]
-index_local_valid [lemma, in backend.Stackingproof]
-index_saved_float_valid [lemma, in backend.Stackingproof]
-index_saved_int_valid [lemma, in backend.Stackingproof]
-index_val [definition, in backend.Stackingproof]
-index_valid [definition, in backend.Stackingproof]
-index_val_init_frame [lemma, in backend.Stackingproof]
-Indst_noOverlap_aux [lemma, in backend.Parallelmove]
-Ingetsrc_swap [lemma, in backend.Parallelmove]
-Ingetsrc_swap2 [lemma, in backend.Parallelmove]
-init [definition, in lib.Maps]
-init [definition, in backend.Locations]
-init [definition, in lib.Maps]
-init [definition, in lib.Maps]
-initial_state_invariant [lemma, in backend.Kildall]
-initmem_nullptr [lemma, in backend.Globalenvs]
-initmem_undef [lemma, in backend.Globalenvs]
-init_frame [definition, in backend.Machabstr]
-init_mapping [definition, in backend.RTLgen]
-init_mapping_wf [lemma, in backend.RTLgenproof1]
-init_mem [definition, in backend.Globalenvs]
-init_mem_transf [lemma, in backend.Globalenvs]
-init_mem_transf_partial [lemma, in backend.Globalenvs]
-init_regs [definition, in backend.RTL]
-init_state [definition, in backend.RTLgen]
-init_state_wf [lemma, in backend.RTLgen]
-Inj [constructor, in lib.Lattice]
-inject_incr [definition, in backend.Mem]
-inject_incr_refl [lemma, in backend.Mem]
-inject_incr_trans [lemma, in backend.Mem]
-Inop [constructor, in backend.RTL]
-insert_bin [definition, in lib.Inclusion]
-insert_bin_included [lemma, in lib.Inclusion]
-insert_lenv [inductive, in backend.Cmconstrproof]
-insert_lenv_lookup1 [lemma, in backend.Cmconstrproof]
-insert_lenv_lookup2 [lemma, in backend.Cmconstrproof]
-insert_lenv_S [constructor, in backend.Cmconstrproof]
-insert_lenv_0 [constructor, in backend.Cmconstrproof]
-instruction [inductive, in backend.Linear]
-instruction [inductive, in backend.PPC]
-instruction [inductive, in backend.RTL]
-instruction [inductive, in backend.Mach]
-instr_at_incr [lemma, in backend.RTLgenproof1]
-int [inductive, in lib.Integers]
-Int [module, in lib.Integers]
-Integers [library]
-interfere [definition, in backend.InterfGraph]
-interfere_incl [lemma, in backend.Coloringproof]
-interfere_mreg [definition, in backend.InterfGraph]
-interfere_mreg_incl [lemma, in backend.Coloringproof]
-interfere_sym [lemma, in backend.InterfGraph]
-InterfGraph [library]
-interf_graph [definition, in backend.Coloring]
-interf_graph_correct_1 [lemma, in backend.Coloringproof]
-interf_graph_correct_2 [lemma, in backend.Coloringproof]
-interf_graph_correct_3 [lemma, in backend.Coloringproof]
-intoffloat [definition, in backend.Cmconstr]
-intoffloat [axiom, in lib.Floats]
-intoffloat [definition, in backend.Values]
-intval [definition, in backend.Constprop]
-intval_correct [lemma, in backend.Constpropproof]
-int_add_no_overflow [lemma, in backend.Machabstr2mach]
-int_callee_save [definition, in backend.Lineartyping]
-int_callee_save_bound [lemma, in backend.Linearizetyping]
-int_callee_save_norepet [lemma, in backend.Conventions]
-int_callee_save_not_destroyed [lemma, in backend.Conventions]
-int_callee_save_regs [definition, in backend.Conventions]
-int_callee_save_type [lemma, in backend.Conventions]
-int_float_callee_save_disjoint [lemma, in backend.Conventions]
-int_local [definition, in backend.Lineartyping]
-int_local_slot_bound [lemma, in backend.Linearizetyping]
-int_of_one_bits [definition, in lib.Integers]
-int_param_regs [definition, in backend.Conventions]
-inv_eval_Eop_0 [lemma, in backend.Cmconstrproof]
-inv_eval_Eop_1 [lemma, in backend.Cmconstrproof]
-inv_eval_Eop_2 [lemma, in backend.Cmconstrproof]
-in_bounds [definition, in backend.Mem]
-in_bounds_exten [lemma, in backend.Mem]
-in_bounds_holds [lemma, in backend.Mem]
-in_bounds_inject [lemma, in backend.Mem]
-in_cons_noteq [lemma, in backend.Allocproof_aux]
-in_incr [definition, in backend.Kildall]
-in_incr_refl [lemma, in backend.Kildall]
-in_incr_trans [lemma, in backend.Kildall]
-In_Indst [lemma, in backend.Parallelmove]
-in_move__in_srcdst [lemma, in backend.Alloctyping_aux]
-In_norepet [lemma, in backend.Allocproof_aux]
-in_notin_diff [lemma, in backend.Locations]
-In_noTmp_notempo [lemma, in backend.Parallelmove]
-in_or_insert_bin [lemma, in lib.Inclusion]
-in_or_notin_callstack [lemma, in backend.Machabstr2mach]
-In_permute_app_head [lemma, in lib.Inclusion]
-in_range [definition, in lib.Integers]
-in_range_range [lemma, in lib.Integers]
-in_remove_head [lemma, in lib.Inclusion]
-In_SD_diff [lemma, in backend.Parallelmove]
-In_SD_diff' [lemma, in backend.Parallelmove]
-In_SD_no_o [lemma, in backend.Parallelmove]
-in_split_move [lemma, in backend.Alloctyping_aux]
-in_xelements [lemma, in lib.Maps]
-in_xkeys [lemma, in lib.Maps]
-IR [constructor, in backend.PPC]
-ireg [inductive, in backend.PPC]
-ireg_eq [lemma, in backend.PPC]
-ireg_of [definition, in backend.PPCgen]
-ireg_of_is_data_reg [lemma, in backend.PPCgenproof1]
-ireg_of_not_GPR1 [lemma, in backend.PPCgenproof1]
-ireg_of_not_GPR2 [lemma, in backend.PPCgenproof1]
-ireg_val [lemma, in backend.PPCgenproof1]
-isfalse_not_istrue [lemma, in backend.Values]
-istrue_not_isfalse [lemma, in backend.Values]
-is_basic_block_head [definition, in backend.Kildall]
-is_bool [definition, in backend.Values]
-is_data_reg [definition, in backend.PPCgenproof1]
-is_false [definition, in lib.Integers]
-is_false [definition, in backend.Values]
-is_goto_block [definition, in backend.Tunneling]
-is_goto_block_correct [lemma, in backend.Tunnelingproof]
-is_label [definition, in backend.PPC]
-is_label [definition, in backend.Mach]
-is_label [definition, in backend.Linear]
-is_label_correct [lemma, in backend.PPC]
-is_label_correct [lemma, in backend.Mach]
-is_label_correct [lemma, in backend.Linear]
-is_move_operation [definition, in backend.Op]
-is_move_operation_correct [lemma, in backend.Op]
-is_power2 [definition, in lib.Integers]
-is_power2_correct [lemma, in lib.Integers]
-is_power2_range [lemma, in lib.Integers]
-is_power2_rng [lemma, in lib.Integers]
-is_rlw_mask [definition, in lib.Integers]
-is_rlw_mask_rec [definition, in lib.Integers]
-is_tail [inductive, in backend.Linearizeproof]
-is_tail_cons [constructor, in backend.Linearizeproof]
-is_tail_cons_left [lemma, in backend.Linearizeproof]
-is_tail_exec_instr [lemma, in backend.Linearizeproof]
-is_tail_exec_instrs [lemma, in backend.Linearizeproof]
-is_tail_find_label [lemma, in backend.Linearizeproof]
-is_tail_in [lemma, in backend.Linearizeproof]
-is_tail_refl [constructor, in backend.Linearizeproof]
-is_trivial_op [definition, in backend.CSE]
-is_true [definition, in lib.Integers]
-is_true [definition, in backend.Values]
-iterate [definition, in backend.Kildall]
-iterate_base [lemma, in backend.Kildall]
-iterate_incr [lemma, in backend.Kildall]
-iterate_solution [lemma, in backend.Kildall]
-iterate_step [lemma, in backend.Kildall]
-iter_step [definition, in backend.Kildall]
-IT1 [constructor, in backend.Locations]
-IT2 [constructor, in backend.Locations]
-IT3 [constructor, in backend.Locations]
-

K

-Kildall [library]
-kill_loads [definition, in backend.CSE]
-kill_load_eqs [definition, in backend.CSE]
-kill_load_eqs_incl [lemma, in backend.CSEproof]
-kill_load_eqs_ops [lemma, in backend.CSEproof]
-kill_load_satisfiable [lemma, in backend.CSEproof]
-

L

-L [module, in backend.Kildall]
-L [module, in backend.Kildall]
-L [module, in backend.Kildall]
-L [module, in backend.Kildall]
-L [module, in backend.Kildall]
-L [module, in backend.Kildall]
-L [module, in backend.Kildall]
-L [module, in backend.Kildall]
-L [module, in backend.Kildall]
-label [definition, in backend.Linear]
-label [definition, in backend.PPC]
-label [definition, in backend.Mach]
-label_in_lin_block [lemma, in backend.Linearizeproof]
-label_in_lin_rec [lemma, in backend.Linearizeproof]
-label_pos [definition, in backend.PPC]
-label_pos_code_tail [lemma, in backend.PPCgenproof]
-last [definition, in backend.Parallelmove]
-last_app [lemma, in backend.Parallelmove]
-last_cons [lemma, in backend.Parallelmove]
-last_replace [lemma, in backend.Parallelmove]
-Lattice [library]
-lbl [definition, in backend.Linearize]
-lbl [definition, in backend.Linearize]
-LBoolean [module, in lib.Lattice]
-Lcall [constructor, in backend.Linear]
-Lcond [constructor, in backend.Linear]
-Leaf [constructor, in lib.Maps]
-leaf [definition, in lib.Inclusion]
-leaf [constructor, in lib.Inclusion]
-leaf [definition, in lib.Inclusion]
-leaf [definition, in lib.Inclusion]
-length_addr_args [lemma, in backend.Allocproof]
-length_app [lemma, in backend.Parallelmove]
-length_cond_args [lemma, in backend.Allocproof]
-length_op_args [lemma, in backend.Allocproof]
-length_replace [lemma, in backend.Parallelmove]
-letenv [definition, in backend.Cminor]
-letenv [definition, in backend.Csharpminor]
-let_fold_args_res [lemma, in backend.RTLtyping]
-LFlat [module, in lib.Lattice]
-Lgetstack [constructor, in backend.Linear]
-Lgoto [constructor, in backend.Linear]
-lift [definition, in backend.Cmconstr]
-lift_condexpr [definition, in backend.Cmconstr]
-lift_expr [definition, in backend.Cmconstr]
-lift_exprlist [definition, in backend.Cmconstr]
-Linear [library]
-Linearize [library]
-Linearizeproof [library]
-Linearizetyping [library]
-linearize_block [definition, in backend.Linearize]
-linearize_block_incl [lemma, in backend.Linearizetyping]
-linearize_body [definition, in backend.Linearize]
-linearize_function [definition, in backend.Linearize]
-Lineartyping [library]
-link_invariant [definition, in backend.Machtyping]
-listsLoc2Moves [definition, in backend.Parallelmove]
-listsLoc2Moves [definition, in backend.Allocation]
-list_append_map [lemma, in lib.Coqlib]
-list_disjoint [definition, in lib.Coqlib]
-list_disjoint_cons_left [lemma, in lib.Coqlib]
-list_disjoint_cons_right [lemma, in lib.Coqlib]
-list_disjoint_notin [lemma, in lib.Coqlib]
-list_disjoint_sym [lemma, in lib.Coqlib]
-list_forall2 [inductive, in lib.Coqlib]
-list_forall2_cons [constructor, in lib.Coqlib]
-list_forall2_imply [lemma, in lib.Coqlib]
-list_forall2_nil [constructor, in lib.Coqlib]
-list_in_map_inv [lemma, in lib.Coqlib]
-list_length_map [lemma, in lib.Coqlib]
-list_map_compose [lemma, in lib.Coqlib]
-list_map_exten [lemma, in lib.Coqlib]
-list_map_norepet [lemma, in lib.Coqlib]
-list_map_nth [lemma, in lib.Coqlib]
-list_norepet [inductive, in lib.Coqlib]
-list_norepet_append [lemma, in lib.Coqlib]
-list_norepet_append_left [lemma, in lib.Coqlib]
-list_norepet_append_right [lemma, in lib.Coqlib]
-list_norepet_cons [constructor, in lib.Coqlib]
-list_norepet_dec [lemma, in lib.Coqlib]
-list_norepet_nil [constructor, in lib.Coqlib]
-live0 [definition, in backend.Allocproof]
-Llabel [constructor, in backend.Linear]
-Lload [constructor, in backend.Linear]
-load [definition, in backend.Mem]
-load [definition, in backend.Cmconstr]
-Load [constructor, in backend.CSE]
-loadimm [definition, in backend.PPCgen]
-loadimm_correct [lemma, in backend.PPCgenproof1]
-loadind [definition, in backend.PPCgen]
-loadind_aux [definition, in backend.PPCgen]
-loadind_aux_correct [lemma, in backend.PPCgenproof1]
-loadind_correct [lemma, in backend.PPCgenproof1]
-loadv [definition, in backend.Mem]
-loadv_inject [lemma, in backend.Mem]
-loadv_8_signed_unsigned [lemma, in backend.PPCgenproof]
-load1 [definition, in backend.PPC]
-load2 [definition, in backend.PPC]
-load_agree [lemma, in backend.Mem]
-load_alloc_other [lemma, in backend.Mem]
-load_alloc_same [lemma, in backend.Mem]
-load_contentmap_agree [lemma, in backend.Mem]
-load_contents [definition, in backend.Mem]
-load_contents_init [lemma, in backend.Mem]
-load_contents_inject [lemma, in backend.Mem]
-load_extends [lemma, in backend.Mem]
-load_free [lemma, in backend.Mem]
-load_freelist [lemma, in backend.Cminorgenproof]
-load_from_alloc_is_undef [lemma, in backend.Cminorgenproof]
-load_inject [lemma, in backend.Mem]
-load_inv [lemma, in backend.Mem]
-load_in_bounds [lemma, in backend.Mem]
-load_result [definition, in backend.Values]
-load_result_idem [lemma, in backend.Cminorgenproof]
-load_result_inject [lemma, in backend.Mem]
-load_result_normalized [lemma, in backend.Cminorgenproof]
-load_result_ty [lemma, in backend.Machabstr2mach]
-load_stack [definition, in backend.Mach]
-load_store_contents_mismatch [lemma, in backend.Mem]
-load_store_contents_other [lemma, in backend.Mem]
-load_store_contents_overlap [lemma, in backend.Mem]
-load_store_contents_same [lemma, in backend.Mem]
-load_store_other [lemma, in backend.Mem]
-load_store_same [lemma, in backend.Mem]
-loc [inductive, in backend.Locations]
-Loc [module, in backend.Locations]
-Local [constructor, in backend.Locations]
-local_variable [inductive, in backend.Csharpminor]
-Locations [library]
-Locmap [module, in backend.Locations]
-locset [definition, in backend.LTL]
-locset [definition, in backend.Linear]
-locs_acceptable [definition, in backend.Conventions]
-locs_acceptable_disj_temporaries [lemma, in backend.Conventions]
-locs_read_ok [definition, in backend.Alloctyping]
-locs_write_ok [definition, in backend.Alloctyping]
-loc_acceptable [definition, in backend.Conventions]
-loc_acceptable_noteq_diff [lemma, in backend.Allocproof]
-loc_acceptable_notin_notin [lemma, in backend.Allocproof]
-loc_arguments [definition, in backend.Conventions]
-loc_arguments_acceptable [lemma, in backend.Conventions]
-loc_arguments_bounded [lemma, in backend.Conventions]
-loc_arguments_length [lemma, in backend.Conventions]
-loc_arguments_norepet [lemma, in backend.Conventions]
-loc_arguments_not_temporaries [lemma, in backend.Conventions]
-loc_arguments_rec [definition, in backend.Conventions]
-loc_arguments_type [lemma, in backend.Conventions]
-loc_argument_acceptable [definition, in backend.Conventions]
-loc_is_acceptable [definition, in backend.Coloring]
-loc_is_acceptable_correct [lemma, in backend.Coloringproof]
-loc_parameters [definition, in backend.Conventions]
-loc_parameters_not_temporaries [lemma, in backend.Conventions]
-loc_parameters_type [lemma, in backend.Conventions]
-loc_read_ok [definition, in backend.Alloctyping]
-loc_result [definition, in backend.Conventions]
-loc_result_acceptable [lemma, in backend.Conventions]
-loc_result_type [lemma, in backend.Conventions]
-loc_write_ok [definition, in backend.Alloctyping]
-Lop [constructor, in backend.Linear]
-low_bound [definition, in backend.Mem]
-low_bound_alloc [lemma, in backend.Mem]
-low_bound_free [lemma, in backend.Mem]
-low_bound_store [lemma, in backend.Mem]
-low_half_signed [axiom, in backend.PPC]
-low_half_signed_type [axiom, in backend.PPC]
-low_half_unsigned [axiom, in backend.PPC]
-low_half_unsigned_type [axiom, in backend.PPC]
-low_high_half_signed [axiom, in backend.PPC]
-low_high_half_unsigned [axiom, in backend.PPC]
-low_high_s [lemma, in backend.PPCgenproof1]
-low_high_u [lemma, in backend.PPCgenproof1]
-low_high_u_xor [lemma, in backend.PPCgenproof1]
-low_s [definition, in backend.PPCgen]
-low_u [definition, in backend.PPCgen]
-LPMap [module, in lib.Lattice]
-LR [constructor, in backend.PPC]
-Lreturn [constructor, in backend.Linear]
-Lsetstack [constructor, in backend.Linear]
-Lstore [constructor, in backend.Linear]
-lt [definition, in lib.Integers]
-lt [definition, in lib.Ordered]
-lt [definition, in lib.Ordered]
-lt [definition, in lib.Ordered]
-LTL [library]
-LTLtyping [library]
-ltu [definition, in lib.Integers]
-lt_not_eq [lemma, in lib.Ordered]
-lt_not_eq [lemma, in lib.Ordered]
-lt_not_eq [lemma, in lib.Ordered]
-lt_trans [lemma, in lib.Ordered]
-lt_trans [lemma, in lib.Ordered]
-lt_trans [lemma, in lib.Ordered]
-lub [definition, in lib.Lattice]
-lub [definition, in lib.Lattice]
-lub [definition, in lib.Sets]
-lub [definition, in lib.Lattice]
-lub [definition, in backend.Constprop]
-lub_commut [lemma, in lib.Lattice]
-lub_commut [lemma, in backend.Constprop]
-lub_commut [lemma, in lib.Lattice]
-lub_commut [lemma, in lib.Sets]
-lub_commut [lemma, in lib.Lattice]
-LVarray [constructor, in backend.Csharpminor]
-LVscalar [constructor, in backend.Csharpminor]
-

M

-Mach [library]
-Machabstr [library]
-Machabstr2mach [library]
-Machtyping [library]
-Main [library]
-MakeSet [module, in lib.Sets]
-make_addimm [definition, in backend.Constprop]
-make_addimm_correct [lemma, in backend.Constpropproof]
-make_andimm [definition, in backend.Constprop]
-make_andimm_correct [lemma, in backend.Constpropproof]
-make_cast [definition, in backend.Cminorgen]
-make_cast_correct [lemma, in backend.Cminorgenproof]
-make_env [definition, in backend.Stacking]
-make_load [definition, in backend.Cminorgen]
-make_load_correct [lemma, in backend.Cminorgenproof]
-make_mulimm [definition, in backend.Constprop]
-make_mulimm_correct [lemma, in backend.Constpropproof]
-make_op [definition, in backend.Cminorgen]
-make_op_correct [lemma, in backend.Cminorgenproof]
-make_orimm [definition, in backend.Constprop]
-make_orimm_correct [lemma, in backend.Constpropproof]
-make_predecessors [definition, in backend.Kildall]
-make_predecessors_correct [lemma, in backend.Kildall]
-make_shlimm [definition, in backend.Constprop]
-make_shlimm_correct [lemma, in backend.Constpropproof]
-make_shrimm [definition, in backend.Constprop]
-make_shrimm_correct [lemma, in backend.Constpropproof]
-make_shruimm [definition, in backend.Constprop]
-make_shruimm_correct [lemma, in backend.Constpropproof]
-make_stackaddr [definition, in backend.Cminorgen]
-make_stackaddr_correct [lemma, in backend.Cminorgenproof]
-make_store [definition, in backend.Cminorgen]
-make_store_correct [lemma, in backend.Cminorgenproof]
-make_xorimm [definition, in backend.Constprop]
-make_xorimm_correct [lemma, in backend.Constpropproof]
-map [definition, in lib.Maps]
-map [definition, in lib.Maps]
-map [definition, in lib.Maps]
-map [definition, in lib.Maps]
-MAP [module, in lib.Maps]
-MAP [module, in lib.union_find]
-mapped [definition, in backend.RTLtyping]
-mapped_included_consistent [lemma, in backend.RTLtyping]
-mapped_list_included [lemma, in backend.RTLtyping]
-mapping [inductive, in backend.RTLgen]
-Maps [library]
-map_f_getsrc_getdst [lemma, in backend.Alloctyping_aux]
-map_inv [lemma, in backend.Allocproof_aux]
-map_wf [inductive, in backend.RTLgenproof1]
-map_wf_incr [lemma, in backend.RTLgenproof1]
-match_callstack [inductive, in backend.Cminorgenproof]
-match_callstack_alloc_left [lemma, in backend.Cminorgenproof]
-match_callstack_alloc_other [lemma, in backend.Cminorgenproof]
-match_callstack_alloc_right [lemma, in backend.Cminorgenproof]
-match_callstack_alloc_variables [lemma, in backend.Cminorgenproof]
-match_callstack_alloc_variables_rec [lemma, in backend.Cminorgenproof]
-match_callstack_freelist [lemma, in backend.Cminorgenproof]
-match_callstack_freelist_rec [lemma, in backend.Cminorgenproof]
-match_callstack_incr_bound [lemma, in backend.Cminorgenproof]
-match_callstack_mapped [lemma, in backend.Cminorgenproof]
-match_callstack_match_globalenvs [lemma, in backend.Cminorgenproof]
-match_callstack_store_above [lemma, in backend.Cminorgenproof]
-match_callstack_store_local [lemma, in backend.Cminorgenproof]
-match_callstack_store_local_unchanged [lemma, in backend.Cminorgenproof]
-match_env [inductive, in backend.Cminorgenproof]
-match_env [inductive, in backend.RTLgenproof1]
-match_env_alloc_other [lemma, in backend.Cminorgenproof]
-match_env_alloc_same [lemma, in backend.Cminorgenproof]
-match_env_empty [lemma, in backend.RTLgenproof1]
-match_env_exten [lemma, in backend.RTLgenproof1]
-match_env_extensional [lemma, in backend.Cminorgenproof]
-match_env_find_reg [lemma, in backend.RTLgenproof1]
-match_env_freelist [lemma, in backend.Cminorgenproof]
-match_env_invariant [lemma, in backend.RTLgenproof1]
-match_env_letvar [lemma, in backend.RTLgenproof1]
-match_env_store_above [lemma, in backend.Cminorgenproof]
-match_env_store_local [lemma, in backend.Cminorgenproof]
-match_env_store_mapped [lemma, in backend.Cminorgenproof]
-match_env_update_temp [lemma, in backend.RTLgenproof1]
-match_env_update_var [lemma, in backend.RTLgenproof1]
-match_globalenvs [inductive, in backend.Cminorgenproof]
-match_globalenvs_init [lemma, in backend.Cminorgenproof]
-match_init_env_init_reg [lemma, in backend.RTLgenproof1]
-match_return_outcome [definition, in backend.RTLgenproof]
-match_return_reg [definition, in backend.RTLgenproof]
-match_set_locals [lemma, in backend.RTLgenproof1]
-match_set_params_init_regs [lemma, in backend.RTLgenproof1]
-match_var [inductive, in backend.Cminorgenproof]
-max_over_instrs [definition, in backend.Lineartyping]
-max_over_instrs_bound [lemma, in backend.Linearizetyping]
-max_over_list [definition, in backend.Lineartyping]
-max_over_list_bound [lemma, in backend.Linearizetyping]
-max_over_list_pos [lemma, in backend.Lineartyping]
-max_over_regs_of_funct [definition, in backend.Lineartyping]
-max_over_regs_of_funct_bound [lemma, in backend.Linearizetyping]
-max_over_regs_of_funct_pos [lemma, in backend.Lineartyping]
-max_over_regs_of_instr [definition, in backend.Lineartyping]
-max_over_slots_of_funct [definition, in backend.Lineartyping]
-max_over_slots_of_funct_bound [lemma, in backend.Linearizetyping]
-max_over_slots_of_funct_pos [lemma, in backend.Lineartyping]
-max_over_slots_of_instr [definition, in backend.Lineartyping]
-max_signed [definition, in lib.Integers]
-max_unsigned [definition, in lib.Integers]
-Mcall [constructor, in backend.Mach]
-Mcond [constructor, in backend.Mach]
-mcs_cons [constructor, in backend.Cminorgenproof]
-mcs_nil [constructor, in backend.Cminorgenproof]
-mem [inductive, in backend.Mem]
-mem [definition, in lib.Sets]
-Mem [library]
-member [definition, in backend.RTLtyping]
-member_correct [lemma, in backend.RTLtyping]
-meminj [definition, in backend.Mem]
-memory_chunk [inductive, in backend.AST]
-memory_size [inductive, in backend.Mem]
-mem_add_globals_transf [lemma, in backend.Globalenvs]
-mem_add_other [lemma, in lib.Sets]
-mem_add_same [lemma, in lib.Sets]
-mem_add_tail [lemma, in backend.InterfGraph]
-mem_chunk [definition, in backend.Mem]
-mem_empty [lemma, in lib.Sets]
-mem_exten [lemma, in backend.Mem]
-mem_inject [inductive, in backend.Mem]
-mem_remove_other [lemma, in lib.Sets]
-mem_remove_same [lemma, in lib.Sets]
-mem_type [definition, in backend.Machabstr]
-mem_union [lemma, in lib.Sets]
-mesure [definition, in backend.Parallelmove]
-Mfloat32 [constructor, in backend.AST]
-Mfloat64 [constructor, in backend.AST]
-Mgetparam [constructor, in backend.Mach]
-Mgetstack [constructor, in backend.Mach]
-Mgoto [constructor, in backend.Mach]
-Mint16signed [constructor, in backend.AST]
-Mint16unsigned [constructor, in backend.AST]
-Mint32 [constructor, in backend.AST]
-Mint8signed [constructor, in backend.AST]
-Mint8unsigned [constructor, in backend.AST]
-min_signed [definition, in lib.Integers]
-mkint_eq [lemma, in lib.Integers]
-mk_env [definition, in backend.RTLtyping]
-Mlabel [constructor, in backend.Mach]
-Mload [constructor, in backend.Mach]
-mods [definition, in lib.Integers]
-mods [definition, in backend.Cmconstr]
-mods [definition, in backend.Values]
-mods_divs [lemma, in lib.Integers]
-mods_divs [lemma, in backend.Values]
-modu [definition, in lib.Integers]
-modu [definition, in backend.Values]
-modu [definition, in backend.Cmconstr]
-modulus [definition, in lib.Integers]
-modulus_pos [lemma, in lib.Integers]
-modu_and [lemma, in lib.Integers]
-modu_divu [lemma, in lib.Integers]
-modu_divu [lemma, in backend.Values]
-modu_divu_Euclid [lemma, in lib.Integers]
-modu_pow2 [lemma, in backend.Values]
-mod_aux [definition, in backend.Cmconstr]
-mod_in_range [lemma, in lib.Integers]
-mon [definition, in backend.RTLgen]
-mone [definition, in lib.Integers]
-mone_max_unsigned [lemma, in lib.Integers]
-Mop [constructor, in backend.Mach]
-more_likely [axiom, in backend.RTLgen]
-Move [definition, in backend.Parallelmove]
-Moves [definition, in backend.Parallelmove]
-move_types_res [lemma, in backend.Alloctyping_aux]
-move_types_stepf [lemma, in backend.Alloctyping_aux]
-mreg [inductive, in backend.Locations]
-mreg_bounded [definition, in backend.Lineartyping]
-mreg_eq [lemma, in backend.Locations]
-mreg_is_bounded [lemma, in backend.Linearizetyping]
-mreg_type [definition, in backend.Locations]
-Mreturn [constructor, in backend.Mach]
-Msetstack [constructor, in backend.Mach]
-Mstore [constructor, in backend.Mach]
-mul [axiom, in lib.Floats]
-mul [definition, in lib.Integers]
-mul [definition, in backend.Cmconstr]
-mul [definition, in backend.Values]
-mulf [definition, in backend.Cmconstr]
-mulf [definition, in backend.Values]
-mulimm [definition, in backend.Cmconstr]
-mulimm_base [definition, in backend.Cmconstr]
-mulimm_cases [inductive, in backend.Cmconstr]
-mulimm_case1 [constructor, in backend.Cmconstr]
-mulimm_case2 [constructor, in backend.Cmconstr]
-mulimm_default [constructor, in backend.Cmconstr]
-mulimm_match [definition, in backend.Cmconstr]
-multiple_predecessors [lemma, in backend.Kildall]
-mul_add_distr_l [lemma, in lib.Integers]
-mul_add_distr_l [lemma, in backend.Values]
-mul_add_distr_r [lemma, in lib.Integers]
-mul_add_distr_r [lemma, in backend.Values]
-mul_assoc [lemma, in lib.Integers]
-mul_assoc [lemma, in backend.Values]
-mul_cases [inductive, in backend.Cmconstr]
-mul_case1 [constructor, in backend.Cmconstr]
-mul_case2 [constructor, in backend.Cmconstr]
-mul_commut [lemma, in backend.Values]
-mul_commut [lemma, in lib.Integers]
-mul_default [constructor, in backend.Cmconstr]
-mul_match [definition, in backend.Cmconstr]
-mul_match_aux [definition, in backend.Cmconstr]
-mul_one [lemma, in lib.Integers]
-mul_pow2 [lemma, in lib.Integers]
-mul_pow2 [lemma, in backend.Values]
-mul_zero [lemma, in lib.Integers]
-mutated_condexpr [definition, in backend.RTLgen]
-mutated_expr [definition, in backend.RTLgen]
-mutated_exprlist [definition, in backend.RTLgen]
-mutated_reg [definition, in backend.RTLgenproof1]
-mutated_reg_in_map [lemma, in backend.RTLgenproof1]
-mymap [module, in backend.RTLtyping]
-myreg [module, in backend.RTLtyping]
-myT [inductive, in backend.RTLtyping]
-

N

-n [constructor, in backend.Op]
-nat_le_bool [definition, in lib.Inclusion]
-neg [definition, in backend.Values]
-neg [definition, in lib.Integers]
-neg [axiom, in lib.Floats]
-negate_cmp [lemma, in backend.Values]
-negate_cmp [lemma, in lib.Integers]
-negate_cmpf_eq [lemma, in backend.Values]
-negate_cmpu [lemma, in lib.Integers]
-negate_cmpu [lemma, in backend.Values]
-negate_cmp_mismatch [lemma, in backend.Values]
-negate_comparison [definition, in backend.AST]
-negate_condition [definition, in backend.Op]
-negf [definition, in backend.Values]
-negfloat [definition, in backend.Cmconstr]
-negint [definition, in backend.Cmconstr]
-neg_add_distr [lemma, in backend.Values]
-neg_add_distr [lemma, in lib.Integers]
-neg_mul_distr_l [axiom, in lib.Integers]
-neg_mul_distr_r [axiom, in lib.Integers]
-neg_repr [lemma, in lib.Integers]
-neg_zero [lemma, in lib.Integers]
-neg_zero [lemma, in backend.Values]
-neq_is_neq [lemma, in backend.Parallelmove]
-new_reg [definition, in backend.RTLgen]
-new_reg_fresh [lemma, in backend.RTLgenproof1]
-new_reg_incr [lemma, in backend.RTLgenproof1]
-new_reg_not_in_map [lemma, in backend.RTLgenproof1]
-new_reg_not_mutated [lemma, in backend.RTLgenproof1]
-new_reg_return_ok [lemma, in backend.RTLgenproof1]
-new_reg_valid [lemma, in backend.RTLgenproof1]
-nextinstr [definition, in backend.PPC]
-nextinstr_inv [lemma, in backend.PPCgenproof1]
-nextinstr_set_preg [lemma, in backend.PPCgenproof1]
-nil [definition, in backend.Parallelmove]
-nil [definition, in backend.Parallelmove]
-nil [definition, in backend.Parallelmove]
-nil [definition, in backend.Parallelmove]
-nil [definition, in backend.Parallelmove]
-nil [definition, in backend.Parallelmove]
-nil [definition, in backend.Parallelmove]
-nil [definition, in backend.Parallelmove]
-nil [definition, in backend.Parallelmove]
-nil [definition, in backend.Parallelmove]
-nil [definition, in backend.Allocproof_aux]
-nil [definition, in backend.Parallelmove]
-nil [definition, in backend.Parallelmove]
-nil [definition, in backend.Parallelmove]
-nil [definition, in backend.Parallelmove]
-nil [definition, in backend.Parallelmove]
-nil [definition, in backend.Parallelmove]
-nil [definition, in backend.Parallelmove]
-NIndexed [module, in lib.Maps]
-NMap [module, in lib.Maps]
-Node [constructor, in lib.Maps]
-node [definition, in backend.RTL]
-node [definition, in backend.LTL]
-node [constructor, in lib.Inclusion]
-non_overlap_diff [lemma, in backend.Locations]
-NoOverlap [definition, in backend.Parallelmove]
-noOverlap [definition, in backend.Parallelmove]
-noOverlapaux_insert [lemma, in backend.Parallelmove]
-noOverlapaux_swap2 [lemma, in backend.Parallelmove]
-noOverlap_aux [definition, in backend.Parallelmove]
-noOverlap_auxpop [lemma, in backend.Parallelmove]
-noOverlap_auxPop [lemma, in backend.Parallelmove]
-noOverlap_aux_app [lemma, in backend.Parallelmove]
-noOverlap_Front0 [lemma, in backend.Parallelmove]
-noOverlap_head [lemma, in backend.Parallelmove]
-noOverlap_insert [lemma, in backend.Parallelmove]
-noOverlap_movBack [lemma, in backend.Parallelmove]
-noOverlap_movBack0 [lemma, in backend.Parallelmove]
-noOverlap_movFront [lemma, in backend.Parallelmove]
-noOverlap_nil [lemma, in backend.Parallelmove]
-noOverlap_Pop [lemma, in backend.Parallelmove]
-noOverlap_pop [lemma, in backend.Parallelmove]
-noOverlap_right [lemma, in backend.Parallelmove]
-noOverlap_swap [lemma, in backend.Parallelmove]
-noO_diff [lemma, in backend.Parallelmove]
-noO_list_pnilnil [lemma, in backend.Allocproof_aux]
-noRead [definition, in backend.Parallelmove]
-noRead_app [lemma, in backend.Parallelmove]
-noRead_by_path [lemma, in backend.Parallelmove]
-norepet [inductive, in backend.Locations]
-norepet_cons [constructor, in backend.Locations]
-norepet_nil [constructor, in backend.Locations]
-norepet_SD [lemma, in backend.Allocproof_aux]
-not [definition, in lib.Integers]
-notbool [definition, in backend.Values]
-notbool [definition, in backend.Cmconstr]
-notbool [definition, in lib.Integers]
-notbool_base [definition, in backend.Cmconstr]
-notbool_idem2 [lemma, in backend.Values]
-notbool_idem3 [lemma, in backend.Values]
-notbool_isfalse_istrue [lemma, in lib.Integers]
-notbool_istrue_isfalse [lemma, in lib.Integers]
-notbool_is_bool [lemma, in backend.Values]
-notbool_negb_1 [lemma, in backend.Values]
-notbool_negb_2 [lemma, in backend.Values]
-notbool_xor [lemma, in backend.Values]
-notemporary [definition, in backend.Parallelmove]
-notin [definition, in backend.Locations]
-notindst_nW [lemma, in backend.Parallelmove]
-notint [definition, in backend.Values]
-notint [definition, in backend.Cmconstr]
-notint_cases [inductive, in backend.Cmconstr]
-notint_case1 [constructor, in backend.Cmconstr]
-notint_case2 [constructor, in backend.Cmconstr]
-notint_case3 [constructor, in backend.Cmconstr]
-notint_default [constructor, in backend.Cmconstr]
-notint_match [definition, in backend.Cmconstr]
-notin_callstack [inductive, in backend.Machabstr2mach]
-notin_callstack_cons [constructor, in backend.Machabstr2mach]
-notin_callstack_nil [constructor, in backend.Machabstr2mach]
-notin_disjoint [lemma, in backend.Locations]
-notin_not_in [lemma, in backend.Locations]
-noTmp [definition, in backend.Parallelmove]
-noTmpLast [definition, in backend.Parallelmove]
-noTmpLast_lastnoTmp [lemma, in backend.Parallelmove]
-noTmpLast_Pop [lemma, in backend.Parallelmove]
-noTmpLast_pop [lemma, in backend.Parallelmove]
-noTmpLast_popBack [lemma, in backend.Parallelmove]
-noTmpLast_push [lemma, in backend.Parallelmove]
-noTmpLast_tmpLast [lemma, in backend.Parallelmove]
-noTmpL_diff [lemma, in backend.Parallelmove]
-noTmp_app [lemma, in backend.Parallelmove]
-noTmp_append [lemma, in backend.Parallelmove]
-noTmP_noOverlap_aux [lemma, in backend.Parallelmove]
-noTmp_noReadTmp [lemma, in backend.Parallelmove]
-noTmp_noTmpLast [lemma, in backend.Parallelmove]
-noTmp_pop [lemma, in backend.Parallelmove]
-Novalue [constructor, in backend.Constprop]
-noWrite [definition, in backend.Parallelmove]
-noWrite_in [lemma, in backend.Parallelmove]
-noWrite_insert [lemma, in backend.Parallelmove]
-noWrite_movFront [lemma, in backend.Parallelmove]
-noWrite_pop [lemma, in backend.Parallelmove]
-noWrite_swap [lemma, in backend.Parallelmove]
-noWrite_tmpLast [lemma, in backend.Parallelmove]
-no_overlap [definition, in backend.Parallelmove]
-no_overlap [definition, in backend.Locations]
-no_overlapD_inv [lemma, in backend.Allocproof_aux]
-no_overlapD_invf [lemma, in backend.Allocproof_aux]
-no_overlapD_invpp [lemma, in backend.Allocproof_aux]
-no_overlapD_res [lemma, in backend.Allocproof_aux]
-no_overlap_arguments [lemma, in backend.Conventions]
-no_overlap_list [definition, in backend.Parallelmove]
-no_overlap_list_pop [lemma, in backend.Allocproof_aux]
-no_overlap_noOverlap [lemma, in backend.Parallelmove]
-no_overlap_parameters [lemma, in backend.Conventions]
-no_overlap_state [definition, in backend.Parallelmove]
-no_overlap_stateD [definition, in backend.Allocproof_aux]
-no_overlap_temp [lemma, in backend.Allocproof_aux]
-no_self_loop [lemma, in backend.Kildall]
-no_tmp13_state [definition, in backend.Allocproof_aux]
-nth_error_in [lemma, in lib.Coqlib]
-nth_error_nil [lemma, in lib.Coqlib]
-nullptr [definition, in backend.Mem]
-Numbering [module, in backend.CSE]
-numbering [inductive, in backend.CSE]
-numbering_holds [definition, in backend.CSE]
-numbering_holds_exten [lemma, in backend.CSEproof]
-numbering_satisfiable [definition, in backend.CSE]
-num_iterations [definition, in backend.Kildall]
-

O

-Oabsf [constructor, in backend.Op]
-Oabsf [constructor, in backend.Csharpminor]
-Oadd [constructor, in backend.Csharpminor]
-Oadd [constructor, in backend.Op]
-Oaddf [constructor, in backend.Csharpminor]
-Oaddf [constructor, in backend.Op]
-Oaddimm [constructor, in backend.Op]
-Oaddrstack [constructor, in backend.Op]
-Oaddrsymbol [constructor, in backend.Op]
-Oand [constructor, in backend.Op]
-Oand [constructor, in backend.Csharpminor]
-Oandimm [constructor, in backend.Op]
-Ocast16signed [constructor, in backend.Csharpminor]
-Ocast16signed [constructor, in backend.Op]
-Ocast16unsigned [constructor, in backend.Csharpminor]
-Ocast8signed [constructor, in backend.Csharpminor]
-Ocast8signed [constructor, in backend.Op]
-Ocast8unsigned [constructor, in backend.Csharpminor]
-Ocmp [constructor, in backend.Op]
-Ocmp [constructor, in backend.Csharpminor]
-Ocmpf [constructor, in backend.Csharpminor]
-Ocmpu [constructor, in backend.Csharpminor]
-Odiv [constructor, in backend.Op]
-Odiv [constructor, in backend.Csharpminor]
-Odivf [constructor, in backend.Op]
-Odivf [constructor, in backend.Csharpminor]
-Odivu [constructor, in backend.Csharpminor]
-Odivu [constructor, in backend.Op]
-offset_of_index [definition, in backend.Stacking]
-offset_of_index_disj [lemma, in backend.Stackingproof]
-offset_of_index_no_overflow [lemma, in backend.Stackingproof]
-offset_of_index_valid [lemma, in backend.Stackingproof]
-offset_sp [definition, in backend.Op]
-Ofloatconst [constructor, in backend.Op]
-Ofloatconst [constructor, in backend.Csharpminor]
-Ofloatofint [constructor, in backend.Op]
-Ofloatofint [constructor, in backend.Csharpminor]
-Ofloatofintu [constructor, in backend.Csharpminor]
-Ofloatofintu [constructor, in backend.Op]
-of_bool [definition, in backend.Values]
-of_bool_is_bool [lemma, in backend.Values]
-Ointconst [constructor, in backend.Csharpminor]
-Ointconst [constructor, in backend.Op]
-Ointoffloat [constructor, in backend.Csharpminor]
-Ointoffloat [constructor, in backend.Op]
-OK [constructor, in backend.RTLgen]
-OK [constructor, in backend.PPC]
-Omod [constructor, in backend.Csharpminor]
-Omodu [constructor, in backend.Csharpminor]
-Omove [constructor, in backend.Op]
-Omul [constructor, in backend.Csharpminor]
-Omul [constructor, in backend.Op]
-Omuladdf [constructor, in backend.Op]
-Omulf [constructor, in backend.Op]
-Omulf [constructor, in backend.Csharpminor]
-Omulimm [constructor, in backend.Op]
-Omulsubf [constructor, in backend.Op]
-Onand [constructor, in backend.Op]
-one [definition, in lib.Integers]
-one [axiom, in lib.Floats]
-Onegf [constructor, in backend.Csharpminor]
-Onegf [constructor, in backend.Op]
-one_bits [definition, in lib.Integers]
-one_bits_decomp [lemma, in lib.Integers]
-one_bits_range [lemma, in lib.Integers]
-one_not_zero [lemma, in lib.Integers]
-Onor [constructor, in backend.Op]
-Onotint [constructor, in backend.Csharpminor]
-Onxor [constructor, in backend.Op]
-Oor [constructor, in backend.Op]
-Oor [constructor, in backend.Csharpminor]
-Oorimm [constructor, in backend.Op]
-Op [constructor, in backend.CSE]
-Op [library]
-operation [inductive, in backend.Csharpminor]
-operation [inductive, in backend.Op]
-option_fold2 [definition, in backend.RTLtyping]
-option_map [definition, in lib.Coqlib]
-option_sum [lemma, in lib.union_find]
-op_strength_reduction [definition, in backend.Constprop]
-op_strength_reduction_cases [inductive, in backend.Constprop]
-op_strength_reduction_case1 [constructor, in backend.Constprop]
-op_strength_reduction_case10 [constructor, in backend.Constprop]
-op_strength_reduction_case11 [constructor, in backend.Constprop]
-op_strength_reduction_case12 [constructor, in backend.Constprop]
-op_strength_reduction_case2 [constructor, in backend.Constprop]
-op_strength_reduction_case3 [constructor, in backend.Constprop]
-op_strength_reduction_case4 [constructor, in backend.Constprop]
-op_strength_reduction_case5 [constructor, in backend.Constprop]
-op_strength_reduction_case6 [constructor, in backend.Constprop]
-op_strength_reduction_case7 [constructor, in backend.Constprop]
-op_strength_reduction_case8 [constructor, in backend.Constprop]
-op_strength_reduction_case9 [constructor, in backend.Constprop]
-op_strength_reduction_correct [lemma, in backend.Constpropproof]
-op_strength_reduction_default [constructor, in backend.Constprop]
-op_strength_reduction_match [definition, in backend.Constprop]
-or [definition, in lib.Integers]
-or [definition, in backend.Values]
-or [definition, in backend.Cmconstr]
-Ordered [library]
-OrderedIndexed [module, in lib.Ordered]
-OrderedMreg [module, in backend.InterfGraph]
-OrderedPair [module, in lib.Ordered]
-OrderedPositive [module, in lib.Ordered]
-OrderedReg [module, in backend.InterfGraph]
-OrderedRegMreg [module, in backend.InterfGraph]
-OrderedRegReg [module, in backend.InterfGraph]
-ordered_pair [definition, in backend.InterfGraph]
-ordered_pair_charact [lemma, in backend.InterfGraph]
-ordered_pair_sym [lemma, in backend.InterfGraph]
-ORDERED_TYPE_WITH_TOP [module, in backend.Kildall]
-orimm [definition, in backend.PPCgen]
-orimm_correct [lemma, in backend.PPCgenproof1]
-Orolm [constructor, in backend.Op]
-or_assoc [lemma, in lib.Integers]
-or_assoc [lemma, in backend.Values]
-or_cases [inductive, in backend.Cmconstr]
-or_case1 [constructor, in backend.Cmconstr]
-or_commut [lemma, in lib.Integers]
-or_commut [lemma, in backend.Values]
-or_default [constructor, in backend.Cmconstr]
-or_idem [lemma, in lib.Integers]
-or_match [definition, in backend.Cmconstr]
-or_mone [lemma, in lib.Integers]
-or_of_bool [lemma, in backend.Values]
-or_rolm [lemma, in lib.Integers]
-or_rolm [lemma, in backend.Values]
-or_zero [lemma, in lib.Integers]
-Oshl [constructor, in backend.Csharpminor]
-Oshl [constructor, in backend.Op]
-Oshr [constructor, in backend.Op]
-Oshr [constructor, in backend.Csharpminor]
-Oshrimm [constructor, in backend.Op]
-Oshru [constructor, in backend.Op]
-Oshru [constructor, in backend.Csharpminor]
-Oshrximm [constructor, in backend.Op]
-Osingleoffloat [constructor, in backend.Op]
-Osingleoffloat [constructor, in backend.Csharpminor]
-Osub [constructor, in backend.Csharpminor]
-Osub [constructor, in backend.Op]
-Osubf [constructor, in backend.Csharpminor]
-Osubf [constructor, in backend.Op]
-Osubimm [constructor, in backend.Op]
-Oundef [constructor, in backend.Op]
-outcome [inductive, in backend.Cminor]
-outcome [inductive, in backend.LTL]
-outcome [inductive, in backend.PPC]
-outcome [inductive, in backend.Csharpminor]
-outcome_block [definition, in backend.Csharpminor]
-outcome_block [definition, in backend.Cminor]
-outcome_inject [inductive, in backend.Cminorgenproof]
-outcome_node [definition, in backend.RTLgenproof]
-outcome_result_value [definition, in backend.Cminor]
-outcome_result_value [definition, in backend.Csharpminor]
-Outgoing [constructor, in backend.Locations]
-outgoing_slot [definition, in backend.Lineartyping]
-outgoing_slot_bound [lemma, in backend.Linearizetyping]
-outgoing_space [definition, in backend.Lineartyping]
-Out_exit [constructor, in backend.Csharpminor]
-Out_exit [constructor, in backend.Cminor]
-Out_normal [constructor, in backend.Cminor]
-Out_normal [constructor, in backend.Csharpminor]
-Out_return [constructor, in backend.Cminor]
-Out_return [constructor, in backend.Csharpminor]
-overlap [definition, in backend.Locations]
-overlap_aux [definition, in backend.Locations]
-overlap_aux_false_1 [lemma, in backend.Locations]
-overlap_aux_true_1 [lemma, in backend.Locations]
-overlap_aux_true_2 [lemma, in backend.Locations]
-overlap_not_diff [lemma, in backend.Locations]
-Oxor [constructor, in backend.Op]
-Oxor [constructor, in backend.Csharpminor]
-Oxorimm [constructor, in backend.Op]
-

P

-Padd [constructor, in backend.PPC]
-Paddi [constructor, in backend.PPC]
-Paddis [constructor, in backend.PPC]
-Paddze [constructor, in backend.PPC]
-Pallocframe [constructor, in backend.PPC]
-Pandc [constructor, in backend.PPC]
-Pandis_ [constructor, in backend.PPC]
-Pandi_ [constructor, in backend.PPC]
-Pand_ [constructor, in backend.PPC]
-Parallelmove [library]
-parallel_move [definition, in backend.Allocation]
-parallel_move_correct [lemma, in backend.Allocproof]
-parallel_move_correctX [lemma, in backend.Allocproof_aux]
-parallel_move_correct' [lemma, in backend.Allocproof_aux]
-parallel_move_order [definition, in backend.Allocation]
-parameter_of_argument [definition, in backend.Conventions]
-path [definition, in backend.Parallelmove]
-path_pop [lemma, in backend.Parallelmove]
-path_tmpLast [lemma, in backend.Parallelmove]
-Pb [constructor, in backend.PPC]
-Pbctr [constructor, in backend.PPC]
-Pbctrl [constructor, in backend.PPC]
-Pbf [constructor, in backend.PPC]
-Pbl [constructor, in backend.PPC]
-Pblr [constructor, in backend.PPC]
-Pbt [constructor, in backend.PPC]
-PC [constructor, in backend.PPC]
-Pcmplw [constructor, in backend.PPC]
-Pcmplwi [constructor, in backend.PPC]
-Pcmpw [constructor, in backend.PPC]
-Pcmpwi [constructor, in backend.PPC]
-Pcror [constructor, in backend.PPC]
-Pdivw [constructor, in backend.PPC]
-Pdivwu [constructor, in backend.PPC]
-peq [definition, in lib.Coqlib]
-Peqv [constructor, in backend.PPC]
-peq_false [lemma, in lib.Coqlib]
-peq_true [lemma, in lib.Coqlib]
-pexec [definition, in backend.Parallelmove]
-pexec_add [lemma, in backend.Parallelmove]
-pexec_correct [lemma, in backend.Parallelmove]
-pexec_mov [lemma, in backend.Parallelmove]
-pexec_movBack [lemma, in backend.Parallelmove]
-pexec_movFront [lemma, in backend.Parallelmove]
-pexec_nop [lemma, in backend.Parallelmove]
-pexec_push [lemma, in backend.Parallelmove]
-pexec_swap [lemma, in backend.Parallelmove]
-pexec_update [lemma, in backend.Parallelmove]
-Pextsb [constructor, in backend.PPC]
-Pextsh [constructor, in backend.PPC]
-Pfabs [constructor, in backend.PPC]
-Pfadd [constructor, in backend.PPC]
-Pfcmpu [constructor, in backend.PPC]
-Pfcti [constructor, in backend.PPC]
-Pfdiv [constructor, in backend.PPC]
-Pfmadd [constructor, in backend.PPC]
-Pfmr [constructor, in backend.PPC]
-Pfmsub [constructor, in backend.PPC]
-Pfmul [constructor, in backend.PPC]
-Pfneg [constructor, in backend.PPC]
-Pfreeframe [constructor, in backend.PPC]
-Pfrsp [constructor, in backend.PPC]
-Pfsub [constructor, in backend.PPC]
-Pfundef [constructor, in backend.PPC]
-Pictf [constructor, in backend.PPC]
-Piuctf [constructor, in backend.PPC]
-Piundef [constructor, in backend.PPC]
-Plabel [constructor, in backend.PPC]
-Plbz [constructor, in backend.PPC]
-Plbzx [constructor, in backend.PPC]
-Ple [definition, in lib.Coqlib]
-Ple_refl [lemma, in lib.Coqlib]
-Ple_succ [lemma, in lib.Coqlib]
-Ple_trans [lemma, in lib.Coqlib]
-Plfd [constructor, in backend.PPC]
-Plfdx [constructor, in backend.PPC]
-Plfi [constructor, in backend.PPC]
-Plfs [constructor, in backend.PPC]
-Plfsx [constructor, in backend.PPC]
-Plha [constructor, in backend.PPC]
-Plhax [constructor, in backend.PPC]
-Plhz [constructor, in backend.PPC]
-Plhzx [constructor, in backend.PPC]
-Plt [definition, in lib.Coqlib]
-plt [definition, in lib.Coqlib]
-Plt_ne [lemma, in lib.Coqlib]
-Plt_Ple [lemma, in lib.Coqlib]
-Plt_Ple_trans [lemma, in lib.Coqlib]
-Plt_strict [lemma, in lib.Coqlib]
-Plt_succ [lemma, in lib.Coqlib]
-Plt_succ_inv [lemma, in lib.Coqlib]
-Plt_trans [lemma, in lib.Coqlib]
-Plt_trans_succ [lemma, in lib.Coqlib]
-Plt_wf [lemma, in lib.Coqlib]
-Plwz [constructor, in backend.PPC]
-Plwzx [constructor, in backend.PPC]
-PMap [module, in lib.Maps]
-Pmfcrbit [constructor, in backend.PPC]
-Pmflr [constructor, in backend.PPC]
-Pmov [definition, in backend.Parallelmove]
-Pmov_equation [lemma, in backend.Parallelmove]
-Pmr [constructor, in backend.PPC]
-Pmtctr [constructor, in backend.PPC]
-Pmtlr [constructor, in backend.PPC]
-Pmulli [constructor, in backend.PPC]
-Pmullw [constructor, in backend.PPC]
-Pnand [constructor, in backend.PPC]
-Pnor [constructor, in backend.PPC]
-Por [constructor, in backend.PPC]
-Porc [constructor, in backend.PPC]
-Pori [constructor, in backend.PPC]
-Poris [constructor, in backend.PPC]
-positive_Peano_ind [lemma, in lib.Coqlib]
-positive_rec [definition, in lib.Coqlib]
-positive_rec_base [lemma, in lib.Coqlib]
-positive_rec_succ [lemma, in lib.Coqlib]
-powerserie [definition, in lib.Integers]
-PPC [library]
-PPCgen [library]
-PPCgenproof [library]
-PPCgenproof1 [library]
-Ppred_Plt [lemma, in lib.Coqlib]
-predecessors [definition, in backend.Kildall]
-predecessors_correct [lemma, in backend.Kildall]
-preg [inductive, in backend.PPC]
-PregEq [module, in backend.PPC]
-Pregmap [module, in backend.PPC]
-preg_eq [lemma, in backend.PPC]
-preg_of [definition, in backend.PPCgenproof1]
-preg_of_injective [lemma, in backend.PPCgenproof1]
-preg_of_is_data_reg [lemma, in backend.PPCgenproof1]
-preg_of_not [lemma, in backend.PPCgenproof1]
-preg_of_not_GPR1 [lemma, in backend.PPCgenproof1]
-preg_val [lemma, in backend.PPCgenproof1]
-Prlwinm [constructor, in backend.PPC]
-program [definition, in backend.LTL]
-program [definition, in backend.Cminor]
-program [definition, in backend.Linear]
-program [inductive, in backend.AST]
-program [definition, in backend.RTL]
-program [definition, in backend.Csharpminor]
-program [definition, in backend.PPC]
-program [definition, in backend.Mach]
-program_typing_preserved [lemma, in backend.Tunnelingtyping]
-program_typing_preserved [lemma, in backend.Linearizetyping]
-program_typing_preserved [lemma, in backend.Alloctyping]
-program_typing_preserved [lemma, in backend.Stackingtyping]
-prog_funct_transf_OK [lemma, in backend.Globalenvs]
-proof_irrelevance [axiom, in lib.Coqlib]
-propagate_succ [definition, in backend.Kildall]
-propagate_successors [definition, in backend.Kildall]
-propagate_successors_charact1 [lemma, in backend.Kildall]
-propagate_successors_charact2 [lemma, in backend.Kildall]
-propagate_successors_invariant [lemma, in backend.Kildall]
-propagate_successors_P [lemma, in backend.Kildall]
-propagate_succ_charact [lemma, in backend.Kildall]
-propagate_succ_incr [lemma, in backend.Kildall]
-propagate_succ_incr_worklist [lemma, in backend.Kildall]
-propagate_succ_list [definition, in backend.Kildall]
-propagate_succ_list_charact [lemma, in backend.Kildall]
-propagate_succ_list_incr [lemma, in backend.Kildall]
-propagate_succ_list_incr_worklist [lemma, in backend.Kildall]
-propagate_succ_list_records_changes [lemma, in backend.Kildall]
-propagate_succ_records_changes [lemma, in backend.Kildall]
-Pslw [constructor, in backend.PPC]
-Psraw [constructor, in backend.PPC]
-Psrawi [constructor, in backend.PPC]
-Psrw [constructor, in backend.PPC]
-Pstate [definition, in backend.Kildall]
-Pstb [constructor, in backend.PPC]
-Pstbx [constructor, in backend.PPC]
-Pstfd [constructor, in backend.PPC]
-Pstfdx [constructor, in backend.PPC]
-Pstfs [constructor, in backend.PPC]
-Pstfsx [constructor, in backend.PPC]
-Psth [constructor, in backend.PPC]
-Psthx [constructor, in backend.PPC]
-Pstw [constructor, in backend.PPC]
-Pstwx [constructor, in backend.PPC]
-Psubfc [constructor, in backend.PPC]
-Psubfic [constructor, in backend.PPC]
-PTree [module, in lib.Maps]
-Pxor [constructor, in backend.PPC]
-Pxori [constructor, in backend.PPC]
-Pxoris [constructor, in backend.PPC]
-p_move [definition, in backend.Allocproof_aux]
-P_move [definition, in backend.Parallelmove]
-

R

-R [constructor, in backend.Locations]
-R [definition, in backend.Coloring]
-reachable [definition, in backend.Linearize]
-reachable_aux [definition, in backend.Linearize]
-reachable_correct_1 [lemma, in backend.Linearizeproof]
-reachable_correct_2 [lemma, in backend.Linearizeproof]
-reachable_entrypoint [lemma, in backend.Linearizeproof]
-reachable_successors [lemma, in backend.Linearizeproof]
-rebuild_l [lemma, in backend.Parallelmove]
-refl_ge [lemma, in backend.CSE]
-Reg [module, in backend.Registers]
-reg [definition, in backend.Registers]
-Reg [definition, in backend.Parallelmove]
-regalloc [definition, in backend.Coloring]
-regalloc_acceptable [lemma, in backend.Coloringproof]
-regalloc_correct_1 [lemma, in backend.Coloringproof]
-regalloc_correct_2 [lemma, in backend.Coloringproof]
-regalloc_correct_3 [lemma, in backend.Coloringproof]
-regalloc_disj_temporaries [lemma, in backend.Allocproof]
-regalloc_norepet_norepet [lemma, in backend.Allocproof]
-regalloc_noteq_diff [lemma, in backend.Allocproof]
-regalloc_notin_notin [lemma, in backend.Allocproof]
-regalloc_not_temporary [lemma, in backend.Allocproof]
-regalloc_ok [lemma, in backend.Coloringproof]
-regalloc_preserves_types [lemma, in backend.Coloringproof]
-regenv [definition, in backend.RTLtyping]
-RegEq [module, in backend.Mach]
-Registers [library]
-register_classification [lemma, in backend.Conventions]
-reglist [definition, in backend.LTL]
-Regmap [module, in backend.Mach]
-Regmap [module, in backend.Registers]
-regmap_optget [definition, in backend.Registers]
-regmap_optset [definition, in backend.Registers]
-regsalloc_acceptable [lemma, in backend.Coloringproof]
-regset [definition, in backend.Mach]
-regset [definition, in backend.RTL]
-regset [definition, in backend.PPC]
-Regset [module, in backend.Registers]
-regs_for [definition, in backend.Allocation]
-regs_for_rec [definition, in backend.Allocation]
-regs_match_approx [definition, in backend.Constpropproof]
-regs_match_approx_increasing [lemma, in backend.Constpropproof]
-regs_match_approx_update [lemma, in backend.Constpropproof]
-regs_of_instr [definition, in backend.Lineartyping]
-reg_for [definition, in backend.Allocation]
-reg_for_spec [lemma, in backend.Allocproof]
-reg_fresh [definition, in backend.RTLgenproof1]
-reg_fresh_decr [lemma, in backend.RTLgenproof1]
-reg_in_map [definition, in backend.RTLgenproof1]
-reg_in_map_valid [lemma, in backend.RTLgenproof1]
-reg_list_dead [definition, in backend.Allocation]
-reg_list_live [definition, in backend.Allocation]
-reg_of_crbit [definition, in backend.PPC]
-reg_option_live [definition, in backend.Allocation]
-reg_sum_live [definition, in backend.Allocation]
-reg_valid [definition, in backend.RTLgenproof1]
-reg_valid_incr [lemma, in backend.RTLgenproof1]
-reg_valnum [definition, in backend.CSE]
-reg_valnum_correct [lemma, in backend.CSEproof]
-remove [definition, in lib.Sets]
-remove [definition, in lib.Maps]
-remove_all_leaves [definition, in lib.Inclusion]
-remove_all_leaves_sound [lemma, in lib.Inclusion]
-repet [definition, in backend.RTLtyping]
-repet_correct [lemma, in backend.RTLtyping]
-replace_last_id [lemma, in backend.Parallelmove]
-replace_last_s [definition, in backend.Parallelmove]
-repr [definition, in lib.union_find]
-repr [definition, in lib.Integers]
-repr_aux [definition, in lib.union_find]
-repr_aux_canon [lemma, in lib.union_find]
-repr_aux_none [lemma, in lib.union_find]
-repr_aux_some [lemma, in lib.union_find]
-repr_empty [lemma, in lib.union_find]
-repr_order [definition, in lib.union_find]
-repr_rec [definition, in lib.union_find]
-repr_rec_ext [lemma, in lib.union_find]
-repr_repr [lemma, in lib.union_find]
-repr_signed [lemma, in lib.Integers]
-repr_unsigned [lemma, in lib.Integers]
-res [inductive, in backend.RTLgen]
-reserve_instr [definition, in backend.RTLgen]
-reserve_instr_incr [lemma, in backend.RTLgenproof1]
-reserve_instr_wf [lemma, in backend.RTLgen]
-restore_callee_save [definition, in backend.Stacking]
-restore_callee_save_correct [lemma, in backend.Stackingproof]
-restore_float_callee_save [definition, in backend.Stacking]
-restore_float_callee_save_correct [lemma, in backend.Stackingproof]
-restore_float_callee_save_correct_rec [lemma, in backend.Stackingproof]
-restore_int_callee_save [definition, in backend.Stacking]
-restore_int_callee_save_correct [lemma, in backend.Stackingproof]
-restore_int_callee_save_correct_rec [lemma, in backend.Stackingproof]
-result [definition, in backend.Kildall]
-reswellFormed [definition, in backend.Allocproof_aux]
-ret [definition, in backend.RTLgen]
-Return [constructor, in backend.LTL]
-return_regs [definition, in backend.LTL]
-return_regs_not_destroyed [lemma, in backend.Allocproof]
-return_regs_result [lemma, in backend.Allocproof]
-return_reg_ok [inductive, in backend.RTLgenproof1]
-return_reg_ok_incr [lemma, in backend.RTLgenproof1]
-return_reg_ok_none [constructor, in backend.RTLgenproof1]
-return_reg_ok_some [constructor, in backend.RTLgenproof1]
-ret_reg [definition, in backend.RTLgen]
-rhs [inductive, in backend.CSE]
-rhs_evals_to [definition, in backend.CSEproof]
-right [definition, in backend.Parallelmove]
-rleaf [lemma, in lib.Maps]
-rlw_accepting [definition, in lib.Integers]
-RLW_Sbad [constructor, in lib.Integers]
-rlw_state [inductive, in lib.Integers]
-RLW_S0 [constructor, in lib.Integers]
-RLW_S1 [constructor, in lib.Integers]
-RLW_S2 [constructor, in lib.Integers]
-RLW_S3 [constructor, in lib.Integers]
-RLW_S4 [constructor, in lib.Integers]
-RLW_S5 [constructor, in lib.Integers]
-RLW_S6 [constructor, in lib.Integers]
-rlw_transition [definition, in lib.Integers]
-rol [definition, in lib.Integers]
-rolm [definition, in backend.Values]
-rolm [definition, in backend.Cmconstr]
-rolm [definition, in lib.Integers]
-rolm_cases [inductive, in backend.Cmconstr]
-rolm_case1 [constructor, in backend.Cmconstr]
-rolm_case2 [constructor, in backend.Cmconstr]
-rolm_default [constructor, in backend.Cmconstr]
-rolm_match [definition, in backend.Cmconstr]
-rolm_rolm [lemma, in lib.Integers]
-rolm_rolm [lemma, in backend.Values]
-rolm_zero [lemma, in lib.Integers]
-rolm_zero [lemma, in backend.Values]
-rol_and [lemma, in lib.Integers]
-rol_or [lemma, in lib.Integers]
-rol_rol [lemma, in lib.Integers]
-rol_zero [lemma, in lib.Integers]
-RTL [library]
-RTLgen [library]
-RTLgenproof [library]
-RTLgenproof1 [library]
-RTLtyping [library]
-R10 [constructor, in backend.Locations]
-R13 [constructor, in backend.Locations]
-R14 [constructor, in backend.Locations]
-R15 [constructor, in backend.Locations]
-R16 [constructor, in backend.Locations]
-R17 [constructor, in backend.Locations]
-R18 [constructor, in backend.Locations]
-R19 [constructor, in backend.Locations]
-r2 [constructor, in backend.Op]
-r2 [constructor, in backend.Op]
-R20 [constructor, in backend.Locations]
-R21 [constructor, in backend.Locations]
-R22 [constructor, in backend.Locations]
-R23 [constructor, in backend.Locations]
-R24 [constructor, in backend.Locations]
-R25 [constructor, in backend.Locations]
-R26 [constructor, in backend.Locations]
-R27 [constructor, in backend.Locations]
-R28 [constructor, in backend.Locations]
-R29 [constructor, in backend.Locations]
-R3 [constructor, in backend.Locations]
-R30 [constructor, in backend.Locations]
-R31 [constructor, in backend.Locations]
-R4 [constructor, in backend.Locations]
-R5 [constructor, in backend.Locations]
-R6 [constructor, in backend.Locations]
-R7 [constructor, in backend.Locations]
-R8 [constructor, in backend.Locations]
-R9 [constructor, in backend.Locations]
-

S

-S [constructor, in backend.Locations]
-sameclass [definition, in lib.union_find]
-sameclass [definition, in lib.union_find]
-sameclass_empty [lemma, in lib.union_find]
-sameclass_identify_1 [lemma, in lib.union_find]
-sameclass_identify_2 [lemma, in lib.union_find]
-sameclass_refl [lemma, in lib.union_find]
-sameclass_repr [lemma, in lib.union_find]
-sameclass_sym [lemma, in lib.union_find]
-sameclass_trans [lemma, in lib.union_find]
-sameEnv [definition, in backend.Parallelmove]
-sameExec [definition, in backend.Parallelmove]
-sameExec_reflexive [lemma, in backend.Parallelmove]
-sameExec_transitive [lemma, in backend.Parallelmove]
-same_expr_pure [definition, in backend.Cmconstr]
-same_not_diff [lemma, in backend.Locations]
-same_typ [definition, in backend.Coloring]
-same_typ_correct [lemma, in backend.Coloringproof]
-save_callee_save [definition, in backend.Stacking]
-save_callee_save_correct [lemma, in backend.Stackingproof]
-save_float_callee_save [definition, in backend.Stacking]
-save_float_callee_save_correct [lemma, in backend.Stackingproof]
-save_float_callee_save_correct_rec [lemma, in backend.Stackingproof]
-save_int_callee_save [definition, in backend.Stacking]
-save_int_callee_save_correct [lemma, in backend.Stackingproof]
-save_int_callee_save_correct_rec [lemma, in backend.Stackingproof]
-Sblock [constructor, in backend.Cminor]
-Sblock [constructor, in backend.Csharpminor]
-SB_Pmov [lemma, in backend.Parallelmove]
-Scons [constructor, in backend.Cminor]
-Scons [constructor, in backend.Csharpminor]
-SDone_Pmov [lemma, in backend.Allocproof_aux]
-SDone_stepf [lemma, in backend.Allocproof_aux]
-sD_nW [lemma, in backend.Parallelmove]
-sD_pexec [lemma, in backend.Parallelmove]
-SEMILATTICE [module, in lib.Lattice]
-SEMILATTICE_WITH_TOP [module, in lib.Lattice]
-set [definition, in lib.Maps]
-set [definition, in backend.Locations]
-set [definition, in lib.Maps]
-set [definition, in lib.Maps]
-set [definition, in lib.Lattice]
-set [definition, in lib.Maps]
-SetDepRegMreg [module, in backend.InterfGraph]
-SetDepRegReg [module, in backend.InterfGraph]
-setN [definition, in backend.Mem]
-setN_agree [lemma, in backend.Mem]
-setN_inject [lemma, in backend.Mem]
-setN_outside_agree [lemma, in backend.Mem]
-setN_outside_inject [lemma, in backend.Mem]
-SetRegMreg [module, in backend.InterfGraph]
-SetRegReg [module, in backend.InterfGraph]
-Sets [library]
-set_cont [definition, in backend.Mem]
-set_cont_agree [lemma, in backend.Mem]
-set_cont_inject [lemma, in backend.Mem]
-set_cont_inside [lemma, in backend.Mem]
-set_cont_outside [lemma, in backend.Mem]
-set_cont_outside1 [lemma, in backend.Mem]
-set_cont_outside_agree [lemma, in backend.Mem]
-set_cont_outside_inject [lemma, in backend.Mem]
-set_locals [definition, in backend.Cminor]
-set_locals_defined [lemma, in backend.Cminorgenproof]
-set_locals_params_defined [lemma, in backend.Cminorgenproof]
-set_params [definition, in backend.Cminor]
-set_params_defined [lemma, in backend.Cminorgenproof]
-set_slot [inductive, in backend.Machabstr]
-set_slot_index [lemma, in backend.Stackingproof]
-set_slot_intro [constructor, in backend.Machabstr]
-set_slot_link_invariant [lemma, in backend.Machtyping]
-set_slot_ok [lemma, in backend.Stackingproof]
-Sexec [definition, in backend.Parallelmove]
-sexec [definition, in backend.Parallelmove]
-Sexit [constructor, in backend.Cminor]
-Sexit [constructor, in backend.Csharpminor]
-Sexpr [constructor, in backend.Cminor]
-Sexpr [constructor, in backend.Csharpminor]
-shift_cases [inductive, in backend.Cmconstr]
-shift_case1 [constructor, in backend.Cmconstr]
-shift_default [constructor, in backend.Cmconstr]
-shift_eval_addressing [lemma, in backend.Stackingproof]
-shift_eval_operation [lemma, in backend.Stackingproof]
-shift_match [definition, in backend.Cmconstr]
-shift_sp [definition, in backend.Stackingproof]
-shl [definition, in lib.Integers]
-shl [definition, in backend.Cmconstr]
-shl [definition, in backend.Values]
-shlimm [definition, in backend.Cmconstr]
-shl_mul [lemma, in backend.Values]
-shl_mul [lemma, in lib.Integers]
-shl_mul_two_p [lemma, in lib.Integers]
-shl_rolm [lemma, in lib.Integers]
-shl_rolm [lemma, in backend.Values]
-shl_zero [lemma, in lib.Integers]
-shr [definition, in lib.Integers]
-shr [definition, in backend.Cmconstr]
-shr [definition, in backend.Values]
-shru [definition, in backend.Cmconstr]
-shru [definition, in lib.Integers]
-shru [definition, in backend.Values]
-shruimm [definition, in backend.Cmconstr]
-shru_div_two_p [lemma, in lib.Integers]
-shru_rolm [lemma, in backend.Values]
-shru_rolm [lemma, in lib.Integers]
-shru_zero [lemma, in lib.Integers]
-shrx [definition, in lib.Integers]
-shrx [definition, in backend.Values]
-shrx_carry [lemma, in backend.Values]
-shrx_carry [lemma, in lib.Integers]
-shr_carry [definition, in backend.Values]
-shr_carry [definition, in lib.Integers]
-shr_zero [lemma, in lib.Integers]
-Sifthenelse [constructor, in backend.Csharpminor]
-Sifthenelse [constructor, in backend.Cminor]
-signature [inductive, in backend.AST]
-signed [definition, in lib.Integers]
-signed_range [lemma, in lib.Integers]
-signed_repr [lemma, in lib.Integers]
-sig_function_translated [lemma, in backend.Allocproof]
-sig_transl_function [lemma, in backend.Cminorgenproof]
-simpleDest [definition, in backend.Parallelmove]
-simpleDest_insert [lemma, in backend.Parallelmove]
-simpleDest_movBack [lemma, in backend.Parallelmove]
-simpleDest_movFront [lemma, in backend.Parallelmove]
-simpleDest_Pop [lemma, in backend.Parallelmove]
-simpleDest_pop [lemma, in backend.Parallelmove]
-simpleDest_pop2 [lemma, in backend.Parallelmove]
-simpleDest_right [lemma, in backend.Parallelmove]
-simpleDest_swap [lemma, in backend.Parallelmove]
-simpleDest_swap_app [lemma, in backend.Parallelmove]
-simpleDest_tmpLast [lemma, in backend.Parallelmove]
-singleoffloat [definition, in backend.Values]
-singleoffloat [definition, in backend.Cmconstr]
-singleoffloat [axiom, in lib.Floats]
-singleoffloat_idem [axiom, in lib.Floats]
-sizeof [definition, in backend.Csharpminor]
-Size16 [constructor, in backend.Mem]
-Size32 [constructor, in backend.Mem]
-Size64 [constructor, in backend.Mem]
-Size8 [constructor, in backend.Mem]
-size_arguments [definition, in backend.Conventions]
-size_arguments_bound [lemma, in backend.Linearizetyping]
-size_arguments_rec [definition, in backend.Conventions]
-size_chunk [definition, in backend.Mem]
-size_chunk_pos [lemma, in backend.Mem]
-size_mem [definition, in backend.Mem]
-size_mem_pos [lemma, in backend.Mem]
-size_no_overflow [lemma, in backend.Stackingproof]
-size_pos [lemma, in backend.Stackingproof]
-Sloop [constructor, in backend.Csharpminor]
-Sloop [constructor, in backend.Cminor]
-slot [inductive, in backend.Locations]
-slots_of_instr [definition, in backend.Lineartyping]
-slot_bounded [definition, in backend.Lineartyping]
-slot_bounded [definition, in backend.LTLtyping]
-slot_eq [lemma, in backend.Locations]
-slot_gi [lemma, in backend.Stackingproof]
-slot_gso [lemma, in backend.Stackingproof]
-slot_gss [lemma, in backend.Stackingproof]
-slot_iso [lemma, in backend.Stackingproof]
-slot_iss [lemma, in backend.Stackingproof]
-slot_is_bounded [lemma, in backend.Linearizetyping]
-slot_type [definition, in backend.Locations]
-Snil [constructor, in backend.Csharpminor]
-Snil [constructor, in backend.Cminor]
-Solver [module, in backend.CSE]
-Some [definition, in backend.Parallelmove]
-sort_bin [definition, in lib.Inclusion]
-sort_included [lemma, in lib.Inclusion]
-sort_included2 [lemma, in lib.Inclusion]
-splitNone [lemma, in backend.Parallelmove]
-splitSome [lemma, in backend.Parallelmove]
-split_length [lemma, in backend.Parallelmove]
-split_move [definition, in backend.Parallelmove]
-split_move' [definition, in backend.Parallelmove]
-split_move_incl [lemma, in backend.Alloctyping_aux]
-sp_val [lemma, in backend.PPCgenproof1]
-srcdst_tmp2_stepf [lemma, in backend.Alloctyping_aux]
-src_tmp2_res [lemma, in backend.Alloctyping_aux]
-Sreturn [constructor, in backend.Csharpminor]
-Sreturn [constructor, in backend.Cminor]
-Stacking [library]
-Stackingproof [library]
-Stackingtyping [library]
-starts_with [definition, in backend.Linearize]
-starts_with_correct [lemma, in backend.Linearizeproof]
-start_state [definition, in backend.Kildall]
-start_state_good [lemma, in backend.Kildall]
-start_state_in [definition, in backend.Kildall]
-start_state_in_entry [lemma, in backend.Kildall]
-start_state_wrk [definition, in backend.Kildall]
-state [inductive, in backend.Kildall]
-State [definition, in backend.Parallelmove]
-state [inductive, in backend.RTLgen]
-state [inductive, in backend.Kildall]
-StateBeing [definition, in backend.Parallelmove]
-StateDone [definition, in backend.Parallelmove]
-StateToMove [definition, in backend.Parallelmove]
-state_extends [definition, in backend.RTLgenproof1]
-state_incr [inductive, in backend.RTLgenproof1]
-state_incr_extends [lemma, in backend.RTLgenproof1]
-state_incr_intro [constructor, in backend.RTLgenproof1]
-state_incr_refl [lemma, in backend.RTLgenproof1]
-state_incr_trans [lemma, in backend.RTLgenproof1]
-state_incr_trans2 [lemma, in backend.RTLgenproof1]
-state_incr_trans3 [lemma, in backend.RTLgenproof1]
-state_incr_trans4 [lemma, in backend.RTLgenproof1]
-state_incr_trans5 [lemma, in backend.RTLgenproof1]
-state_incr_trans6 [lemma, in backend.RTLgenproof1]
-state_invariant [definition, in backend.Kildall]
-step [definition, in backend.Kildall]
-step [inductive, in backend.Parallelmove]
-step [definition, in backend.Kildall]
-stepf [definition, in backend.Parallelmove]
-stepf' [definition, in backend.Parallelmove]
-stepf1_dec [lemma, in backend.Parallelmove]
-stepf_dec [lemma, in backend.Parallelmove]
-stepf_dec0 [lemma, in backend.Parallelmove]
-stepf_dec0' [lemma, in backend.Parallelmove]
-stepf_pop [lemma, in backend.Parallelmove]
-stepf_popLoop [lemma, in backend.Parallelmove]
-stepInv [definition, in backend.Parallelmove]
-stepInv_pnilnil [lemma, in backend.Allocproof_aux]
-stepp [inductive, in backend.Parallelmove]
-stepp_inv [lemma, in backend.Parallelmove]
-stepp_refl [constructor, in backend.Parallelmove]
-stepp_sameExec [lemma, in backend.Parallelmove]
-stepp_trans [constructor, in backend.Parallelmove]
-stepp_transitive [lemma, in backend.Parallelmove]
-step1 [lemma, in backend.RTLtyping]
-step2 [lemma, in backend.RTLtyping]
-step3 [lemma, in backend.RTLtyping]
-step4 [lemma, in backend.RTLtyping]
-step_dec [lemma, in backend.Parallelmove]
-step_dec0 [lemma, in backend.Parallelmove]
-step_inv [lemma, in backend.Parallelmove]
-step_inv_getdst [lemma, in backend.Parallelmove]
-step_inv_loop [lemma, in backend.Parallelmove]
-step_inv_loop_aux [lemma, in backend.Parallelmove]
-step_inv_noOverlap [lemma, in backend.Parallelmove]
-step_inv_NoOverlap [lemma, in backend.Parallelmove]
-step_inv_noTmp [lemma, in backend.Parallelmove]
-step_inv_noTmpLast [lemma, in backend.Parallelmove]
-step_inv_path [lemma, in backend.Parallelmove]
-step_inv_simpleDest [lemma, in backend.Parallelmove]
-step_loop [constructor, in backend.Parallelmove]
-step_NF [definition, in backend.Parallelmove]
-step_nop [constructor, in backend.Parallelmove]
-step_pop [constructor, in backend.Parallelmove]
-step_push [constructor, in backend.Parallelmove]
-step_sameExec [lemma, in backend.Parallelmove]
-step_start [constructor, in backend.Parallelmove]
-step_state_good [lemma, in backend.Kildall]
-step_stepp [lemma, in backend.Parallelmove]
-stmt [inductive, in backend.Csharpminor]
-stmt [inductive, in backend.Cminor]
-stmtlist [inductive, in backend.Csharpminor]
-stmtlist [inductive, in backend.Cminor]
-stmt_stmtlist_ind [lemma, in backend.RTLgenproof1]
-STM_Pmov [lemma, in backend.Parallelmove]
-store [definition, in backend.Cmconstr]
-store [definition, in backend.Mem]
-storeind [definition, in backend.PPCgen]
-storeind_aux [definition, in backend.PPCgen]
-storeind_aux_correct [lemma, in backend.PPCgenproof1]
-storeind_correct [lemma, in backend.PPCgenproof1]
-storev [definition, in backend.Mem]
-storev_mapped_inject [lemma, in backend.Mem]
-storev_mapped_inject_1 [lemma, in backend.Mem]
-storev_16_signed_unsigned [lemma, in backend.PPCgenproof]
-storev_8_signed_unsigned [lemma, in backend.PPCgenproof]
-store1 [definition, in backend.PPC]
-store2 [definition, in backend.PPC]
-store_agree [lemma, in backend.Mem]
-store_alloc [lemma, in backend.Mem]
-store_contentmap_agree [lemma, in backend.Mem]
-store_contentmap_outside_agree [lemma, in backend.Mem]
-store_contents [definition, in backend.Mem]
-store_contents_inject [lemma, in backend.Mem]
-store_contents_outside_inject [lemma, in backend.Mem]
-store_inv [lemma, in backend.Mem]
-store_in_bounds [lemma, in backend.Mem]
-store_is_in_bounds [lemma, in backend.Mem]
-store_mapped_inject [lemma, in backend.Mem]
-store_mapped_inject_1 [lemma, in backend.Mem]
-store_outside_agree [lemma, in backend.Mem]
-store_outside_extends [lemma, in backend.Mem]
-store_parameters [definition, in backend.Cminorgen]
-store_parameters_correct [lemma, in backend.Cminorgenproof]
-store_stack [definition, in backend.Mach]
-store_unmapped_inject [lemma, in backend.Mem]
-store_within_extends [lemma, in backend.Mem]
-sub [axiom, in lib.Floats]
-sub [definition, in backend.Values]
-sub [definition, in lib.Integers]
-sub [definition, in backend.Cmconstr]
-subf [definition, in backend.Values]
-subf [definition, in backend.Cmconstr]
-subf_addf_opp [axiom, in lib.Floats]
-subf_cases [inductive, in backend.Cmconstr]
-subf_case1 [constructor, in backend.Cmconstr]
-subf_default [constructor, in backend.Cmconstr]
-subf_match [definition, in backend.Cmconstr]
-subject_reduction [lemma, in backend.Machtyping]
-subject_reduction [lemma, in backend.RTLtyping]
-subject_reduction_function [lemma, in backend.Machtyping]
-subject_reduction_instr [lemma, in backend.Machtyping]
-subject_reduction_instrs [lemma, in backend.Machtyping]
-sub_add_l [lemma, in backend.Values]
-sub_add_l [lemma, in lib.Integers]
-sub_add_opp [lemma, in lib.Integers]
-sub_add_opp [lemma, in backend.Values]
-sub_add_r [lemma, in backend.Values]
-sub_add_r [lemma, in lib.Integers]
-sub_cases [inductive, in backend.Cmconstr]
-sub_case1 [constructor, in backend.Cmconstr]
-sub_case2 [constructor, in backend.Cmconstr]
-sub_case3 [constructor, in backend.Cmconstr]
-sub_case4 [constructor, in backend.Cmconstr]
-sub_default [constructor, in backend.Cmconstr]
-sub_idem [lemma, in lib.Integers]
-sub_match [definition, in backend.Cmconstr]
-sub_match_aux [definition, in backend.Cmconstr]
-sub_shifted [lemma, in lib.Integers]
-sub_zero_l [lemma, in lib.Integers]
-sub_zero_r [lemma, in backend.Values]
-sub_zero_r [lemma, in lib.Integers]
-successors [definition, in backend.LTL]
-successors [definition, in backend.RTL]
-successors_aux [definition, in backend.LTL]
-successors_aux_invariant [lemma, in backend.LTL]
-successors_correct [lemma, in backend.LTL]
-successors_correct [lemma, in backend.RTL]
-sum_left_map [definition, in lib.Coqlib]
-swap_cmp [lemma, in lib.Integers]
-swap_cmp [lemma, in backend.Values]
-swap_cmpu [lemma, in backend.Values]
-swap_cmpu [lemma, in lib.Integers]
-swap_cmp_mismatch [lemma, in backend.Values]
-swap_comparison [definition, in backend.AST]
-symbols_add_globals_transf [lemma, in backend.Globalenvs]
-symbols_init_transf [lemma, in backend.Globalenvs]
-symbols_preserved [lemma, in backend.Tunnelingproof]
-symbols_preserved [lemma, in backend.Allocproof]
-symbols_preserved [lemma, in backend.Cminorgenproof]
-symbols_preserved [lemma, in backend.Constpropproof]
-symbols_preserved [lemma, in backend.PPCgenproof]
-symbols_preserved [lemma, in backend.RTLgenproof]
-symbols_preserved [lemma, in backend.Linearizeproof]
-symbols_preserved [lemma, in backend.CSEproof]
-symbols_preserved [lemma, in backend.Stackingproof]
-symbol_offset [definition, in backend.PPC]
-s1 [definition, in backend.Linearize]
-

T

-t [definition, in backend.PPC]
-t [definition, in lib.Ordered]
-t [definition, in lib.Maps]
-t [definition, in lib.Maps]
-t [definition, in lib.Lattice]
-t [definition, in backend.Locations]
-t [definition, in backend.Constprop]
-t [definition, in lib.Ordered]
-t [definition, in backend.Globalenvs]
-t [definition, in lib.Lattice]
-T [definition, in backend.RTLtyping]
-T [definition, in lib.union_find]
-t [definition, in backend.CSEproof]
-t [definition, in backend.Locations]
-t [definition, in lib.Maps]
-T [definition, in backend.Parallelmove]
-t [definition, in lib.Maps]
-T [definition, in backend.RTLtyping]
-t [definition, in backend.InterfGraph]
-t [definition, in lib.Maps]
-t [definition, in lib.Ordered]
-t [definition, in lib.Lattice]
-t [definition, in backend.Mach]
-t [definition, in lib.Sets]
-t [definition, in lib.Maps]
-t [definition, in backend.CSE]
-target_regs_cons [constructor, in backend.RTLgenproof1]
-target_regs_nil [constructor, in backend.RTLgenproof1]
-target_regs_not_mutated [lemma, in backend.RTLgenproof1]
-target_regs_ok [inductive, in backend.RTLgenproof1]
-target_regs_ok_incr [lemma, in backend.RTLgenproof1]
-target_regs_valid [lemma, in backend.RTLgenproof1]
-target_reg_immut_var [constructor, in backend.RTLgenproof1]
-target_reg_not_mutated [lemma, in backend.RTLgenproof1]
-target_reg_ok [inductive, in backend.RTLgenproof1]
-target_reg_ok_incr [lemma, in backend.RTLgenproof1]
-target_reg_valid [lemma, in backend.RTLgenproof1]
-temporaries [definition, in backend.Conventions]
-temporaries1 [definition, in backend.Allocproof_aux]
-temporaries1_3 [definition, in backend.Allocproof_aux]
-temporaries2 [definition, in backend.Allocproof_aux]
-temporaries_not_acceptable [lemma, in backend.Conventions]
-teq [definition, in backend.RTLtyping]
-teq_correct [lemma, in backend.RTLtyping]
-test_inclusion [definition, in lib.Inclusion]
-test_inclusion_sound [lemma, in lib.Inclusion]
-Tfloat [constructor, in backend.AST]
-Tint [definition, in backend.Allocation]
-Tint [constructor, in backend.AST]
-top [definition, in lib.Lattice]
-top [definition, in lib.Lattice]
-top [definition, in backend.CSE]
-top [definition, in backend.Constprop]
-top [definition, in lib.Lattice]
-top_ge [lemma, in backend.CSE]
-transfer [definition, in backend.Allocation]
-transfer [definition, in backend.Constprop]
-transfer [definition, in backend.CSE]
-transfer_correct [lemma, in backend.Constpropproof]
-transfer_correct [lemma, in backend.CSEproof]
-transform_partial_program [definition, in backend.AST]
-transform_partial_program_compose [lemma, in backend.Main]
-transform_partial_program_function [lemma, in backend.AST]
-transform_partial_program_main [lemma, in backend.AST]
-transform_program [definition, in backend.AST]
-transform_program_function [lemma, in backend.AST]
-transform_program_partial_total [lemma, in backend.Main]
-transform_program_transform_partial_program [lemma, in backend.Globalenvs]
-transf_cminor_function [definition, in backend.Main]
-transf_cminor_program [definition, in backend.Main]
-transf_cminor_program2 [definition, in backend.Main]
-transf_cminor_program2_correct [lemma, in backend.Main]
-transf_cminor_program_correct [lemma, in backend.Main]
-transf_cminor_program_equiv [lemma, in backend.Main]
-transf_code [definition, in backend.Constprop]
-transf_code [definition, in backend.CSE]
-transf_code_wf [lemma, in backend.CSE]
-transf_code_wf [lemma, in backend.Constprop]
-transf_code_wf [lemma, in backend.RTL]
-transf_csharpminor_function [definition, in backend.Main]
-transf_csharpminor_program [definition, in backend.Main]
-transf_csharpminor_program2 [definition, in backend.Main]
-transf_csharpminor_program2_correct [lemma, in backend.Main]
-transf_csharpminor_program_correct [lemma, in backend.Main]
-transf_csharpminor_program_equiv [lemma, in backend.Main]
-transf_entrypoint [definition, in backend.Allocation]
-transf_entrypoint_correct [lemma, in backend.Allocproof]
-transf_entrypoint_wf [lemma, in backend.Allocation]
-transf_function [definition, in backend.Linearize]
-transf_function [definition, in backend.Allocation]
-transf_function [definition, in backend.CSE]
-transf_function [definition, in backend.RTL]
-transf_function [definition, in backend.PPCgen]
-transf_function [definition, in backend.Stacking]
-transf_function [definition, in backend.Constprop]
-transf_function_correct [lemma, in backend.Linearizeproof]
-transf_function_correct [lemma, in backend.PPCgenproof]
-transf_function_correct [lemma, in backend.Stackingproof]
-transf_function_correct [lemma, in backend.CSEproof]
-transf_funct_correct [lemma, in backend.Constpropproof]
-transf_instr [definition, in backend.Allocation]
-transf_instr [definition, in backend.Constprop]
-transf_instr [definition, in backend.CSE]
-transf_partial [definition, in backend.Globalenvs]
-transf_partial_program [definition, in backend.AST]
-transf_partial_program_compose [lemma, in backend.Main]
-transf_program [definition, in backend.CSE]
-transf_program [definition, in backend.PPCgen]
-transf_program [definition, in backend.Stacking]
-transf_program [definition, in backend.Constprop]
-transf_program [definition, in backend.Allocation]
-transf_program [definition, in backend.Linearize]
-transf_program [definition, in backend.AST]
-transf_program_correct [lemma, in backend.Linearizeproof]
-transf_program_correct [lemma, in backend.Tunnelingproof]
-transf_program_correct [lemma, in backend.Constpropproof]
-transf_program_correct [lemma, in backend.PPCgenproof]
-transf_program_correct [lemma, in backend.CSEproof]
-transf_program_partial_total [lemma, in backend.Main]
-transf_program_transf_partial_program [lemma, in backend.Globalenvs]
-translate_cmp [lemma, in lib.Integers]
-translate_eq [lemma, in lib.Integers]
-translate_lt [lemma, in lib.Integers]
-transl_addr [definition, in backend.Stacking]
-transl_body [definition, in backend.Stacking]
-transl_code [definition, in backend.PPCgen]
-transl_code [definition, in backend.Stacking]
-transl_code_at_pc [inductive, in backend.PPCgenproof]
-transl_code_label [lemma, in backend.PPCgenproof]
-transl_cond [definition, in backend.PPCgen]
-transl_condition_CEcondition_correct [lemma, in backend.RTLgenproof]
-transl_condition_CEcond_correct [lemma, in backend.RTLgenproof]
-transl_condition_CEfalse_correct [lemma, in backend.RTLgenproof]
-transl_condition_CEtrue_correct [lemma, in backend.RTLgenproof]
-transl_condition_correct [definition, in backend.RTLgenproof]
-transl_condition_incr [lemma, in backend.RTLgenproof1]
-transl_condition_incr_pred [definition, in backend.RTLgenproof1]
-transl_cond_correct [lemma, in backend.PPCgenproof1]
-transl_cond_correct_aux [lemma, in backend.PPCgenproof1]
-transl_expr [definition, in backend.RTLgen]
-transl_expr [definition, in backend.Cminorgen]
-transl_exprlist_correct [definition, in backend.RTLgenproof]
-transl_exprlist_Econs_correct [lemma, in backend.Cminorgenproof]
-transl_exprlist_Econs_correct [lemma, in backend.RTLgenproof]
-transl_exprlist_Enil_correct [lemma, in backend.RTLgenproof]
-transl_exprlist_Enil_correct [lemma, in backend.Cminorgenproof]
-transl_exprlist_incr [lemma, in backend.RTLgenproof1]
-transl_exprlist_incr_pred [definition, in backend.RTLgenproof1]
-transl_expr_condition_exprlist_incr [lemma, in backend.RTLgenproof1]
-transl_expr_correct [definition, in backend.RTLgenproof]
-transl_expr_Eaddrof_global_correct [lemma, in backend.Cminorgenproof]
-transl_expr_Eaddrof_local_correct [lemma, in backend.Cminorgenproof]
-transl_expr_Eassign_correct [lemma, in backend.Cminorgenproof]
-transl_expr_Eassign_correct [lemma, in backend.RTLgenproof]
-transl_expr_Ecall_correct [lemma, in backend.RTLgenproof]
-transl_expr_Ecall_correct [lemma, in backend.Cminorgenproof]
-transl_expr_Econdition_correct [lemma, in backend.RTLgenproof]
-transl_expr_Econdition_false_correct [lemma, in backend.Cminorgenproof]
-transl_expr_Econdition_true_correct [lemma, in backend.Cminorgenproof]
-transl_expr_Eletvar_correct [lemma, in backend.RTLgenproof]
-transl_expr_Eletvar_correct [lemma, in backend.Cminorgenproof]
-transl_expr_Elet_correct [lemma, in backend.Cminorgenproof]
-transl_expr_Elet_correct [lemma, in backend.RTLgenproof]
-transl_expr_Eload_correct [lemma, in backend.RTLgenproof]
-transl_expr_Eload_correct [lemma, in backend.Cminorgenproof]
-transl_expr_Eop_correct [lemma, in backend.RTLgenproof]
-transl_expr_Eop_correct [lemma, in backend.Cminorgenproof]
-transl_expr_Estore_correct [lemma, in backend.RTLgenproof]
-transl_expr_Estore_correct [lemma, in backend.Cminorgenproof]
-transl_expr_Evar_correct [lemma, in backend.Cminorgenproof]
-transl_expr_Evar_correct [lemma, in backend.RTLgenproof]
-transl_expr_incr [lemma, in backend.RTLgenproof1]
-transl_expr_incr_pred [definition, in backend.RTLgenproof1]
-transl_find_label [lemma, in backend.PPCgenproof]
-transl_find_label [lemma, in backend.Stackingproof]
-transl_fun [definition, in backend.RTLgen]
-transl_funcall_correct [lemma, in backend.Cminorgenproof]
-transl_funcall_correct [lemma, in backend.RTLgenproof]
-transl_function [definition, in backend.Cminorgen]
-transl_function [definition, in backend.PPCgen]
-transl_function [definition, in backend.RTLgen]
-transl_function_correct [definition, in backend.RTLgenproof]
-transl_function_correct [lemma, in backend.Allocproof]
-transl_function_correct [lemma, in backend.Cminorgenproof]
-transl_function_correctness [lemma, in backend.Allocproof]
-transl_function_correctness [lemma, in backend.RTLgenproof]
-transl_Icall_correct [lemma, in backend.Allocproof]
-transl_Icond_false_correct [lemma, in backend.Allocproof]
-transl_Icond_true_correct [lemma, in backend.Allocproof]
-transl_Iload_correct [lemma, in backend.Allocproof]
-transl_Inop_correct [lemma, in backend.Allocproof]
-transl_instr [definition, in backend.PPCgen]
-transl_instr [definition, in backend.Stacking]
-transl_instr_label [lemma, in backend.PPCgenproof]
-transl_Iop_correct [lemma, in backend.Allocproof]
-transl_Istore_correct [lemma, in backend.Allocproof]
-transl_load_correct [lemma, in backend.PPCgenproof1]
-transl_load_store [definition, in backend.PPCgen]
-transl_load_store_correct [lemma, in backend.PPCgenproof1]
-transl_one_correct [lemma, in backend.Allocproof]
-transl_op [definition, in backend.Stacking]
-transl_op [definition, in backend.PPCgen]
-transl_op_correct [lemma, in backend.PPCgenproof1]
-transl_program [definition, in backend.RTLgen]
-transl_program [definition, in backend.Cminorgen]
-transl_program_correct [lemma, in backend.RTLgenproof]
-transl_program_correct [lemma, in backend.Stackingproof]
-transl_program_correct [lemma, in backend.Allocproof]
-transl_program_correct [lemma, in backend.Cminorgenproof]
-transl_refl_correct [lemma, in backend.Allocproof]
-transl_stmt [definition, in backend.Cminorgen]
-transl_stmt [definition, in backend.RTLgen]
-transl_stmtlist_correct [definition, in backend.RTLgenproof]
-transl_stmtlist_incr [lemma, in backend.RTLgenproof1]
-transl_stmtlist_incr_pred [definition, in backend.RTLgenproof1]
-transl_stmtlist_Scons_continue_correct [lemma, in backend.RTLgenproof]
-transl_stmtlist_Scons_stop_correct [lemma, in backend.RTLgenproof]
-transl_stmtlist_Scons_1_correct [lemma, in backend.Cminorgenproof]
-transl_stmtlist_Scons_2_correct [lemma, in backend.Cminorgenproof]
-transl_stmtlist_Snil_correct [lemma, in backend.RTLgenproof]
-transl_stmtlist_Snil_correct [lemma, in backend.Cminorgenproof]
-transl_stmt_correct [definition, in backend.RTLgenproof]
-transl_stmt_incr [lemma, in backend.RTLgenproof1]
-transl_stmt_incr_pred [definition, in backend.RTLgenproof1]
-transl_stmt_Sblock_correct [lemma, in backend.RTLgenproof]
-transl_stmt_Sblock_correct [lemma, in backend.Cminorgenproof]
-transl_stmt_Sexit_correct [lemma, in backend.RTLgenproof]
-transl_stmt_Sexit_correct [lemma, in backend.Cminorgenproof]
-transl_stmt_Sexpr_correct [lemma, in backend.RTLgenproof]
-transl_stmt_Sexpr_correct [lemma, in backend.Cminorgenproof]
-transl_stmt_Sifthenelse_correct [lemma, in backend.RTLgenproof]
-transl_stmt_Sifthenelse_false_correct [lemma, in backend.Cminorgenproof]
-transl_stmt_Sifthenelse_true_correct [lemma, in backend.Cminorgenproof]
-transl_stmt_Sloop_exit_correct [lemma, in backend.Cminorgenproof]
-transl_stmt_Sloop_loop_correct [lemma, in backend.Cminorgenproof]
-transl_stmt_Sloop_loop_correct [lemma, in backend.RTLgenproof]
-transl_stmt_Sloop_stop_correct [lemma, in backend.RTLgenproof]
-transl_stmt_Sreturn_none_correct [lemma, in backend.Cminorgenproof]
-transl_stmt_Sreturn_none_correct [lemma, in backend.RTLgenproof]
-transl_stmt_Sreturn_some_correct [lemma, in backend.RTLgenproof]
-transl_stmt_Sreturn_some_correct [lemma, in backend.Cminorgenproof]
-transl_stmt_stmtlist_incr [lemma, in backend.RTLgenproof1]
-transl_store_correct [lemma, in backend.PPCgenproof1]
-transl_trans_correct [lemma, in backend.Allocproof]
-tree [inductive, in lib.Maps]
-TREE [module, in lib.Maps]
-tReg [constructor, in backend.RTLtyping]
-tTy [constructor, in backend.RTLtyping]
-tunneled_code [definition, in backend.Tunnelingproof]
-Tunneling [library]
-Tunnelingproof [library]
-Tunnelingtyping [library]
-tunnel_block [definition, in backend.Tunneling]
-tunnel_function [definition, in backend.Tunneling]
-tunnel_function_correct [lemma, in backend.Tunnelingproof]
-tunnel_outcome [definition, in backend.Tunnelingproof]
-tunnel_program [definition, in backend.Tunneling]
-two_power_nat_O [lemma, in lib.Coqlib]
-two_power_nat_pos [lemma, in lib.Coqlib]
-typ [inductive, in backend.AST]
-type [definition, in backend.Locations]
-typenv [definition, in backend.Registers]
-typesize [definition, in backend.AST]
-typesize [definition, in backend.Locations]
-typesize_pos [lemma, in backend.Locations]
-type_args_complete [lemma, in backend.RTLtyping]
-type_args_correct [lemma, in backend.RTLtyping]
-type_args_extends [lemma, in backend.RTLtyping]
-type_args_included [lemma, in backend.RTLtyping]
-type_args_mapped [lemma, in backend.RTLtyping]
-type_args_res_complete [lemma, in backend.RTLtyping]
-type_args_res_included [lemma, in backend.RTLtyping]
-type_args_res_ros_included [lemma, in backend.RTLtyping]
-type_arg_complete [lemma, in backend.RTLtyping]
-type_arg_correct [lemma, in backend.RTLtyping]
-type_arg_correct_1 [lemma, in backend.RTLtyping]
-type_arg_extends [lemma, in backend.RTLtyping]
-type_arg_included [lemma, in backend.RTLtyping]
-type_arg_mapped [lemma, in backend.RTLtyping]
-type_instrs_extends [lemma, in backend.RTLtyping]
-type_instrs_included [lemma, in backend.RTLtyping]
-type_instr_included [lemma, in backend.RTLtyping]
-type_of_addressing [definition, in backend.Op]
-type_of_chunk [definition, in backend.Op]
-type_of_chunk_correct [lemma, in backend.Op]
-type_of_condition [definition, in backend.Op]
-type_of_index [definition, in backend.Stackingproof]
-type_of_operation [definition, in backend.Op]
-type_of_operation_sound [lemma, in backend.Op]
-type_of_sig_res [definition, in backend.RTLtyping]
-type_res_complete [lemma, in backend.RTLtyping]
-type_res_correct [lemma, in backend.RTLtyping]
-type_ros_complete [lemma, in backend.RTLtyping]
-type_ros_correct [lemma, in backend.RTLtyping]
-type_rtl_arg [definition, in backend.RTLtyping]
-type_rtl_function [definition, in backend.RTLtyping]
-type_rtl_function_correct [lemma, in backend.RTLtyping]
-type_rtl_function_instrs [lemma, in backend.RTLtyping]
-type_rtl_function_norepet [lemma, in backend.RTLtyping]
-type_rtl_function_params [lemma, in backend.RTLtyping]
-type_rtl_instr [definition, in backend.RTLtyping]
-type_rtl_ros [definition, in backend.RTLtyping]
-t_ [inductive, in lib.Lattice]
-t_ [inductive, in lib.Lattice]
-T_type [lemma, in backend.Alloctyping_aux]
-

U

-Uf [module, in backend.RTLtyping]
-unchecked_store [definition, in backend.Mem]
-Undef [constructor, in backend.Mem]
-undef_is_bool [lemma, in backend.Values]
-unfold_transf_function [lemma, in backend.Stackingproof]
-union [definition, in lib.Sets]
-UNIONFIND [module, in lib.union_find]
-unionfind [inductive, in lib.union_find]
-Unionfind [module, in lib.union_find]
-union_find [library]
-unique_labels [definition, in backend.Linearizeproof]
-unique_labels_lin_block [lemma, in backend.Linearizeproof]
-unique_labels_lin_function [lemma, in backend.Linearizeproof]
-unique_labels_lin_rec [lemma, in backend.Linearizeproof]
-unroll_positive_rec [lemma, in lib.Coqlib]
-unsigned [definition, in lib.Integers]
-unsigned_range [lemma, in lib.Integers]
-unsigned_range_2 [lemma, in lib.Integers]
-unsigned_repr [lemma, in lib.Integers]
-unsplit_move [lemma, in backend.Parallelmove]
-update [definition, in backend.Mem]
-update [definition, in backend.Parallelmove]
-update_instr [definition, in backend.RTLgen]
-update_instr_extends [lemma, in backend.RTLgenproof1]
-update_instr_incr [lemma, in backend.RTLgenproof1]
-update_instr_wf [lemma, in backend.RTLgen]
-update_o [lemma, in backend.Mem]
-update_s [lemma, in backend.Mem]
-

V

-Val [module, in backend.Values]
-val [inductive, in backend.Values]
-valid_block [definition, in backend.Mem]
-valid_block_alloc [lemma, in backend.Mem]
-valid_block_free [lemma, in backend.Mem]
-valid_block_store [lemma, in backend.Mem]
-valid_fresh_absurd [lemma, in backend.RTLgenproof1]
-valid_fresh_different [lemma, in backend.RTLgenproof1]
-valid_new_block [lemma, in backend.Mem]
-valid_not_valid_diff [lemma, in backend.Mem]
-valid_outcome [definition, in backend.Linearizeproof]
-valid_pointer [definition, in backend.Mem]
-valid_pointer_inject_no_overflow [lemma, in backend.Mem]
-valnum [definition, in backend.CSE]
-ValnumEq [module, in backend.CSEproof]
-valnum_reg [definition, in backend.CSE]
-valnum_regs [definition, in backend.CSE]
-valnum_regs_holds [lemma, in backend.CSEproof]
-valnum_reg_holds [lemma, in backend.CSEproof]
-Value [definition, in backend.Parallelmove]
-Values [library]
-valu_agree [definition, in backend.CSEproof]
-valu_agree_list [lemma, in backend.CSEproof]
-valu_agree_refl [lemma, in backend.CSEproof]
-valu_agree_trans [lemma, in backend.CSEproof]
-val_cond_reg [definition, in backend.PPC]
-val_cons_inject [constructor, in backend.Mem]
-val_content_inject [inductive, in backend.Mem]
-val_content_inject_base [constructor, in backend.Mem]
-val_content_inject_cast [lemma, in backend.Cminorgenproof]
-val_content_inject_incr [lemma, in backend.Mem]
-val_content_inject_8 [constructor, in backend.Mem]
-val_inject [inductive, in backend.Mem]
-val_inject_float [constructor, in backend.Mem]
-val_inject_incr [lemma, in backend.Mem]
-val_inject_int [constructor, in backend.Mem]
-val_inject_ptr [constructor, in backend.Mem]
-val_list_inject [inductive, in backend.Mem]
-val_list_inject_incr [lemma, in backend.Mem]
-val_list_match_approx [inductive, in backend.Constpropproof]
-val_match_approx [definition, in backend.Constpropproof]
-val_match_approx_increasing [lemma, in backend.Constpropproof]
-val_nil_inject [constructor, in backend.Mem]
-val_normalized [definition, in backend.Cminorgenproof]
-vars_vals_cons [constructor, in backend.Cminorgenproof]
-vars_vals_match [inductive, in backend.Cminorgenproof]
-vars_vals_match_extensional [lemma, in backend.Cminorgenproof]
-vars_vals_match_holds [lemma, in backend.Cminorgenproof]
-vars_vals_match_holds_1 [lemma, in backend.Cminorgenproof]
-vars_vals_nil [constructor, in backend.Cminorgenproof]
-var_addr [definition, in backend.Cminorgen]
-var_addr_global_correct [lemma, in backend.Cminorgenproof]
-var_addr_local_correct [lemma, in backend.Cminorgenproof]
-var_get [definition, in backend.Cminorgen]
-var_get_correct [lemma, in backend.Cminorgenproof]
-Var_global [constructor, in backend.Cminorgen]
-var_info [inductive, in backend.Cminorgen]
-Var_local [constructor, in backend.Cminorgen]
-var_set [definition, in backend.Cminorgen]
-var_set_correct [lemma, in backend.Cminorgenproof]
-Var_stack_array [constructor, in backend.Cminorgen]
-Var_stack_scalar [constructor, in backend.Cminorgen]
-Vfalse [definition, in backend.Values]
-Vfloat [constructor, in backend.Values]
-Vint [constructor, in backend.Values]
-vlma_cons [constructor, in backend.Constpropproof]
-vlma_nil [constructor, in backend.Constpropproof]
-VMap [module, in backend.CSEproof]
-Vmone [definition, in backend.Values]
-Vone [definition, in backend.Values]
-Vptr [constructor, in backend.Values]
-Vtrue [definition, in backend.Values]
-Vundef [constructor, in backend.Values]
-Vzero [definition, in backend.Values]
-

W

-wf_add_load [lemma, in backend.CSEproof]
-wf_add_op [lemma, in backend.CSEproof]
-wf_add_rhs [lemma, in backend.CSEproof]
-wf_analyze [lemma, in backend.CSEproof]
-wf_empty [lemma, in lib.union_find]
-wf_empty_numbering [lemma, in backend.CSEproof]
-wf_equation [definition, in backend.CSEproof]
-wf_equation_increasing [lemma, in backend.CSEproof]
-wf_kill_loads [lemma, in backend.CSEproof]
-wf_numbering [definition, in backend.CSEproof]
-wf_rhs [definition, in backend.CSEproof]
-wf_rhs_increasing [lemma, in backend.CSEproof]
-wf_transfer [lemma, in backend.CSEproof]
-wf_tunneled_code [lemma, in backend.Tunneling]
-wf_valnum_reg [lemma, in backend.CSEproof]
-wf_valnum_regs [lemma, in backend.CSEproof]
-wordsize [definition, in lib.Integers]
-wt_add_call [lemma, in backend.Alloctyping]
-wt_add_cond [lemma, in backend.Alloctyping]
-wt_add_entry [lemma, in backend.Alloctyping]
-wt_add_load [lemma, in backend.Alloctyping]
-wt_add_move [lemma, in backend.Alloctyping]
-wt_add_moves [lemma, in backend.Alloctyping_aux]
-wt_add_op_move [lemma, in backend.Alloctyping]
-wt_add_op_others [lemma, in backend.Alloctyping]
-wt_add_op_undef [lemma, in backend.Alloctyping]
-wt_add_reload [lemma, in backend.Alloctyping]
-wt_add_reloads [lemma, in backend.Alloctyping]
-wt_add_return [lemma, in backend.Alloctyping]
-wt_add_spill [lemma, in backend.Alloctyping]
-wt_add_store [lemma, in backend.Alloctyping]
-wt_add_undefs [lemma, in backend.Alloctyping]
-wt_Bgetstack [constructor, in backend.LTLtyping]
-wt_block [inductive, in backend.LTLtyping]
-wt_Bop [constructor, in backend.LTLtyping]
-wt_Bopmove [constructor, in backend.LTLtyping]
-wt_Bopundef [constructor, in backend.LTLtyping]
-wt_Bsetstack [constructor, in backend.LTLtyping]
-wt_content [definition, in backend.Machtyping]
-wt_fold_right [lemma, in backend.Stackingtyping]
-wt_frame [definition, in backend.Machtyping]
-wt_function [inductive, in backend.RTLtyping]
-wt_function [inductive, in backend.Machtyping]
-wt_function [definition, in backend.LTLtyping]
-wt_function [definition, in backend.Lineartyping]
-wt_get_slot [lemma, in backend.Machtyping]
-wt_init_frame [lemma, in backend.Machtyping]
-wt_init_regs [lemma, in backend.RTLtyping]
-wt_Inop [constructor, in backend.RTLtyping]
-wt_instr [inductive, in backend.Lineartyping]
-wt_instr [inductive, in backend.Machtyping]
-wt_instr [inductive, in backend.RTLtyping]
-wt_instrs [definition, in backend.Stackingtyping]
-wt_instrs_cons [lemma, in backend.Stackingtyping]
-wt_Iop [constructor, in backend.RTLtyping]
-wt_Iopmove [constructor, in backend.RTLtyping]
-wt_Iopundef [constructor, in backend.RTLtyping]
-wt_Lgetstack [constructor, in backend.Lineartyping]
-wt_linearize_block [lemma, in backend.Linearizetyping]
-wt_linearize_body [lemma, in backend.Linearizetyping]
-wt_Lop [constructor, in backend.Lineartyping]
-wt_Lopmove [constructor, in backend.Lineartyping]
-wt_Lopundef [constructor, in backend.Lineartyping]
-wt_Lsetstack [constructor, in backend.Lineartyping]
-wt_Mgetstack [constructor, in backend.Machtyping]
-wt_Mlabel [constructor, in backend.Machtyping]
-wt_Msetstack [constructor, in backend.Machtyping]
-wt_Msetstack' [lemma, in backend.Stackingtyping]
-wt_parallel_move [lemma, in backend.Alloctyping]
-wt_parallel_moveX [lemma, in backend.Alloctyping_aux]
-wt_parallel_move' [lemma, in backend.Alloctyping_aux]
-wt_program [definition, in backend.Lineartyping]
-wt_program [definition, in backend.RTLtyping]
-wt_program [definition, in backend.LTLtyping]
-wt_program [definition, in backend.Machtyping]
-wt_regset [definition, in backend.RTLtyping]
-wt_regset [definition, in backend.Machtyping]
-wt_regset_assign [lemma, in backend.RTLtyping]
-wt_regset_list [lemma, in backend.RTLtyping]
-wt_regs_for [lemma, in backend.Alloctyping]
-wt_regs_for_rec [lemma, in backend.Alloctyping]
-wt_reg_for [lemma, in backend.Alloctyping]
-wt_restore_callee_save [lemma, in backend.Stackingtyping]
-wt_restore_float_callee_save [lemma, in backend.Stackingtyping]
-wt_restore_int_callee_save [lemma, in backend.Stackingtyping]
-wt_rtl_function [lemma, in backend.Alloctyping]
-wt_save_callee_save [lemma, in backend.Stackingtyping]
-wt_save_float_callee_save [lemma, in backend.Stackingtyping]
-wt_save_int_callee_save [lemma, in backend.Stackingtyping]
-wt_setreg [lemma, in backend.Machtyping]
-wt_set_slot [lemma, in backend.Machtyping]
-wt_transf_entrypoint [lemma, in backend.Alloctyping]
-wt_transf_function [lemma, in backend.Stackingtyping]
-wt_transf_function [lemma, in backend.Alloctyping]
-wt_transf_function [lemma, in backend.Linearizetyping]
-wt_transf_instr [lemma, in backend.Alloctyping]
-wt_transf_instrs [lemma, in backend.Alloctyping]
-wt_transl_instr [lemma, in backend.Stackingtyping]
-wt_tunnel_block [lemma, in backend.Tunnelingtyping]
-wt_tunnel_function [lemma, in backend.Tunnelingtyping]
-

X

-xcombine_l [definition, in lib.Maps]
-xcombine_lr [lemma, in lib.Maps]
-xcombine_r [definition, in lib.Maps]
-xelements [definition, in lib.Maps]
-xelements_complete [lemma, in lib.Maps]
-xelements_correct [lemma, in lib.Maps]
-xelements_hi [lemma, in lib.Maps]
-xelements_ho [lemma, in lib.Maps]
-xelements_ih [lemma, in lib.Maps]
-xelements_ii [lemma, in lib.Maps]
-xelements_io [lemma, in lib.Maps]
-xelements_keys_norepet [lemma, in lib.Maps]
-xelements_oh [lemma, in lib.Maps]
-xelements_oi [lemma, in lib.Maps]
-xelements_oo [lemma, in lib.Maps]
-xgcombine [lemma, in lib.Maps]
-xgcombine_l [lemma, in lib.Maps]
-xgcombine_r [lemma, in lib.Maps]
-xget [definition, in lib.Maps]
-xget_left [lemma, in lib.Maps]
-xgmap [lemma, in lib.Maps]
-xkeys [definition, in lib.Maps]
-xmap [definition, in lib.Maps]
-xor [definition, in backend.Cmconstr]
-xor [definition, in backend.Values]
-xor [definition, in lib.Integers]
-xorimm [definition, in backend.PPCgen]
-xorimm_correct [lemma, in backend.PPCgenproof1]
-xor_assoc [lemma, in lib.Integers]
-xor_assoc [lemma, in backend.Values]
-xor_commut [lemma, in backend.Values]
-xor_commut [lemma, in lib.Integers]
-xor_one_one [lemma, in lib.Integers]
-xor_zero [lemma, in lib.Integers]
-xor_zero_one [lemma, in lib.Integers]
-

Z

-Zdiv_round [definition, in lib.Integers]
-Zdiv_small [lemma, in lib.Coqlib]
-Zdiv_unique [lemma, in lib.Coqlib]
-zeq [definition, in lib.Coqlib]
-zeq_false [lemma, in lib.Coqlib]
-zeq_true [lemma, in lib.Coqlib]
-zero [definition, in lib.Integers]
-zero [axiom, in lib.Floats]
-ZIndexed [module, in lib.Maps]
-zle [definition, in lib.Coqlib]
-zle_false [lemma, in lib.Coqlib]
-zle_true [lemma, in lib.Coqlib]
-zlt [definition, in lib.Coqlib]
-zlt_false [lemma, in lib.Coqlib]
-zlt_true [lemma, in lib.Coqlib]
-ZMap [module, in lib.Maps]
-Zmax_bound_l [lemma, in lib.Coqlib]
-Zmax_bound_r [lemma, in lib.Coqlib]
-Zmax_spec [lemma, in lib.Coqlib]
-Zmin_spec [lemma, in lib.Coqlib]
-Zmod_round [definition, in lib.Integers]
-Zmod_small [lemma, in lib.Coqlib]
-Zmod_unique [lemma, in lib.Coqlib]
-ztonat [definition, in backend.Mem]
-Z_bin_decomp [definition, in lib.Integers]
-Z_bin_decomp_range [lemma, in lib.Integers]
-Z_bin_decomp_shift_add [lemma, in lib.Integers]
-Z_of_bits [definition, in lib.Integers]
-Z_of_bits_excl [lemma, in lib.Integers]
-Z_of_bits_exten [lemma, in lib.Integers]
-Z_of_bits_of_Z [lemma, in lib.Integers]
-Z_of_bits_range [lemma, in lib.Integers]
-Z_of_bits_range_2 [lemma, in lib.Integers]
-Z_of_bits_shift [lemma, in lib.Integers]
-Z_of_bits_shifts [lemma, in lib.Integers]
-Z_of_bits_shifts_rev [lemma, in lib.Integers]
-Z_of_bits_shift_rev [lemma, in lib.Integers]
-Z_one_bits [definition, in lib.Integers]
-Z_one_bits_powerserie [lemma, in lib.Integers]
-Z_one_bits_range [lemma, in lib.Integers]
-Z_shift_add [definition, in lib.Integers]
-Z_shift_add_bin_decomp [lemma, in lib.Integers]
-Z_shift_add_inj [lemma, in lib.Integers]
-

_

-_ [constructor, in backend.Lineartyping]
-_ [constructor, in backend.LTLtyping]
-

-

Axiom Index

-

A

-abs [in lib.Floats]
-add [in lib.Floats]
-addf_commut [in lib.Floats]
-

C

-cmp [in lib.Floats]
-cmp_ge_gt_eq [in lib.Floats]
-cmp_le_lt_eq [in lib.Floats]
-cmp_ne_eq [in lib.Floats]
-

D

-div [in lib.Floats]
-

E

-eq_dec [in lib.Floats]
-eq_zero_false [in lib.Floats]
-eq_zero_true [in lib.Floats]
-extensionality [in lib.Coqlib]
-

F

-float [in lib.Floats]
-floatofint [in lib.Floats]
-floatofintu [in lib.Floats]
-

G

-graph_coloring [in backend.Coloring]
-

H

-high_half_signed [in backend.PPC]
-high_half_signed_type [in backend.PPC]
-high_half_unsigned [in backend.PPC]
-high_half_unsigned_type [in backend.PPC]
-

I

-intoffloat [in lib.Floats]
-

L

-low_half_signed [in backend.PPC]
-low_half_signed_type [in backend.PPC]
-low_half_unsigned [in backend.PPC]
-low_half_unsigned_type [in backend.PPC]
-low_high_half_signed [in backend.PPC]
-low_high_half_unsigned [in backend.PPC]
-

M

-more_likely [in backend.RTLgen]
-mul [in lib.Floats]
-

N

-neg [in lib.Floats]
-neg_mul_distr_l [in lib.Integers]
-neg_mul_distr_r [in lib.Integers]
-

O

-one [in lib.Floats]
-

P

-proof_irrelevance [in lib.Coqlib]
-

S

-singleoffloat [in lib.Floats]
-singleoffloat_idem [in lib.Floats]
-sub [in lib.Floats]
-subf_addf_opp [in lib.Floats]
-

Z

-zero [in lib.Floats]
-

-

Lemma Index

-

A

-addf_commut [in backend.Values]
-addimm_correct [in backend.PPCgenproof1]
-addimm_1_correct [in backend.PPCgenproof1]
-addimm_2_correct [in backend.PPCgenproof1]
-address_inject [in backend.Mem]
-addr_strength_reduction_correct [in backend.Constpropproof]
-add_and [in lib.Integers]
-add_assoc [in lib.Integers]
-add_assoc [in backend.Values]
-add_call_correct [in backend.Allocproof]
-add_commut [in lib.Integers]
-add_commut [in backend.Values]
-add_cond_correct [in backend.Allocproof]
-add_edges_instrs_correct [in backend.Coloringproof]
-add_edges_instrs_correct_aux [in backend.Coloringproof]
-add_edges_instrs_incl_aux [in backend.Coloringproof]
-add_edges_instr_correct [in backend.Coloringproof]
-add_edges_instr_incl [in backend.Coloringproof]
-add_entry_correct [in backend.Allocproof]
-add_functs_transf [in backend.Globalenvs]
-add_instr_at [in backend.RTLgenproof1]
-add_instr_incr [in backend.RTLgenproof1]
-add_instr_wf [in backend.RTLgen]
-add_interf_call_correct [in backend.Coloringproof]
-add_interf_call_correct_aux_1 [in backend.Coloringproof]
-add_interf_call_correct_aux_2 [in backend.Coloringproof]
-add_interf_call_incl [in backend.Coloringproof]
-add_interf_call_incl_aux_1 [in backend.Coloringproof]
-add_interf_call_incl_aux_2 [in backend.Coloringproof]
-add_interf_correct [in backend.InterfGraph]
-add_interf_entry_correct [in backend.Coloringproof]
-add_interf_entry_incl [in backend.Coloringproof]
-add_interf_incl [in backend.InterfGraph]
-add_interf_live_correct [in backend.Coloringproof]
-add_interf_live_correct_aux [in backend.Coloringproof]
-add_interf_live_incl [in backend.Coloringproof]
-add_interf_live_incl_aux [in backend.Coloringproof]
-add_interf_move_correct [in backend.Coloringproof]
-add_interf_move_incl [in backend.Coloringproof]
-add_interf_mreg_correct [in backend.InterfGraph]
-add_interf_mreg_incl [in backend.InterfGraph]
-add_interf_op_correct [in backend.Coloringproof]
-add_interf_op_incl [in backend.Coloringproof]
-add_interf_params_correct [in backend.Coloringproof]
-add_interf_params_correct_aux [in backend.Coloringproof]
-add_interf_params_incl [in backend.Coloringproof]
-add_interf_params_incl_aux [in backend.Coloringproof]
-add_letvar_wf [in backend.RTLgenproof1]
-add_load_correct [in backend.Allocproof]
-add_load_satisfiable [in backend.CSEproof]
-add_move_correct [in backend.RTLgenproof]
-add_move_correct [in backend.Allocproof]
-add_move_incr [in backend.RTLgenproof1]
-add_neg_zero [in lib.Integers]
-add_op_correct [in backend.Allocproof]
-add_op_satisfiable [in backend.CSEproof]
-add_permut [in backend.Values]
-add_permut [in lib.Integers]
-add_permut_4 [in backend.Values]
-add_prefs_call_incl [in backend.Coloringproof]
-add_pref_incl [in backend.InterfGraph]
-add_pref_mreg_incl [in backend.InterfGraph]
-add_reloads_correct [in backend.Allocproof]
-add_reloads_correct_rec [in backend.Allocproof]
-add_reload_correct [in backend.Allocproof]
-add_return_correct [in backend.Allocproof]
-add_rhs_satisfiable [in backend.CSEproof]
-add_signed [in lib.Integers]
-add_spill_correct [in backend.Allocproof]
-add_store_correct [in backend.Allocproof]
-add_successors_correct [in backend.Kildall]
-add_to_worklist_1 [in backend.Kildall]
-add_to_worklist_2 [in backend.Kildall]
-add_undefs_correct [in backend.Allocproof]
-add_unsigned [in lib.Integers]
-add_vars_incr [in backend.RTLgenproof1]
-add_vars_letenv [in backend.RTLgenproof1]
-add_vars_valid [in backend.RTLgenproof1]
-add_vars_wf [in backend.RTLgenproof1]
-add_var_find [in backend.RTLgenproof1]
-add_var_incr [in backend.RTLgenproof1]
-add_var_letenv [in backend.RTLgenproof1]
-add_var_valid [in backend.RTLgenproof1]
-add_var_wf [in backend.RTLgenproof1]
-add_zero [in lib.Integers]
-agree_assign_dead [in backend.Allocproof]
-agree_assign_live [in backend.Allocproof]
-agree_call [in backend.Allocproof]
-agree_eval_reg [in backend.Stackingproof]
-agree_eval_reg [in backend.Allocproof]
-agree_eval_regs [in backend.Stackingproof]
-agree_eval_regs [in backend.Allocproof]
-agree_exten [in backend.Allocproof]
-agree_exten_1 [in backend.PPCgenproof1]
-agree_exten_2 [in backend.PPCgenproof1]
-agree_increasing [in backend.Allocproof]
-agree_init_regs [in backend.Allocproof]
-agree_move_live [in backend.Allocproof]
-agree_nextinstr [in backend.PPCgenproof1]
-agree_nextinstr_commut [in backend.PPCgenproof1]
-agree_parameters [in backend.Allocproof]
-agree_reg_list_live [in backend.Allocproof]
-agree_reg_live [in backend.Allocproof]
-agree_reg_sum_live [in backend.Allocproof]
-agree_return_regs [in backend.Stackingproof]
-agree_set_commut [in backend.PPCgenproof1]
-agree_set_local [in backend.Stackingproof]
-agree_set_mfreg [in backend.PPCgenproof1]
-agree_set_mireg [in backend.PPCgenproof1]
-agree_set_mireg_exten [in backend.PPCgenproof1]
-agree_set_mireg_twice [in backend.PPCgenproof1]
-agree_set_mreg [in backend.PPCgenproof1]
-agree_set_other [in backend.PPCgenproof1]
-agree_set_outgoing [in backend.Stackingproof]
-agree_set_reg [in backend.Stackingproof]
-agree_set_twice_mireg [in backend.PPCgenproof1]
-align_le [in lib.Coqlib]
-allocs_write_ok [in backend.Alloctyping]
-alloc_extends [in backend.Mem]
-alloc_mapped_inject [in backend.Mem]
-alloc_of_coloring_correct_1 [in backend.Coloringproof]
-alloc_of_coloring_correct_2 [in backend.Coloringproof]
-alloc_of_coloring_correct_3 [in backend.Coloringproof]
-alloc_of_coloring_correct_4 [in backend.Coloringproof]
-alloc_regs_fresh_or_in_map [in backend.RTLgenproof1]
-alloc_regs_incr [in backend.RTLgenproof1]
-alloc_regs_target_ok [in backend.RTLgenproof1]
-alloc_regs_valid [in backend.RTLgenproof1]
-alloc_reg_fresh_or_in_map [in backend.RTLgenproof1]
-alloc_reg_incr [in backend.RTLgenproof1]
-alloc_reg_target_ok [in backend.RTLgenproof1]
-alloc_reg_valid [in backend.RTLgenproof1]
-alloc_right_inject [in backend.Mem]
-alloc_type [in backend.Alloctyping]
-alloc_types [in backend.Alloctyping]
-alloc_unmapped_inject [in backend.Mem]
-alloc_variables_list_block [in backend.Cminorgenproof]
-alloc_variables_nextblock_incr [in backend.Cminorgenproof]
-alloc_write_ok [in backend.Alloctyping]
-all_interf_regs_correct_aux_1 [in backend.InterfGraph]
-all_interf_regs_correct_aux_2 [in backend.InterfGraph]
-all_interf_regs_correct_aux_3 [in backend.InterfGraph]
-all_interf_regs_correct_1 [in backend.InterfGraph]
-all_interf_regs_correct_2 [in backend.InterfGraph]
-analysis_correct_entry [in backend.CSEproof]
-analysis_correct_N [in backend.CSEproof]
-analysis_correct_1 [in backend.CSEproof]
-analyze_correct [in backend.Allocproof]
-analyze_correct_1 [in backend.Constpropproof]
-analyze_correct_2 [in backend.Constpropproof]
-analyze_correct_3 [in backend.Constpropproof]
-analyze_invariant [in backend.Kildall]
-analyze_P [in backend.Kildall]
-andimm_correct [in backend.PPCgenproof1]
-and_assoc [in backend.Values]
-and_assoc [in lib.Integers]
-and_commut [in lib.Integers]
-and_commut [in backend.Values]
-and_idem [in lib.Integers]
-and_mone [in lib.Integers]
-and_or_distrib [in lib.Integers]
-and_shl [in lib.Integers]
-and_shru [in lib.Integers]
-and_xor_distrib [in lib.Integers]
-and_zero [in lib.Integers]
-appcons_length [in backend.Parallelmove]
-append_assoc_0 [in lib.Maps]
-append_assoc_1 [in lib.Maps]
-append_injective [in lib.Maps]
-append_neutral_l [in lib.Maps]
-append_neutral_r [in lib.Maps]
-apply_total_transf_program [in backend.Main]
-approx_regs_val_list [in backend.Constpropproof]
-app_app [in backend.Parallelmove]
-app_cons [in backend.Parallelmove]
-app_nil [in backend.Parallelmove]
-app_rewrite [in backend.Parallelmove]
-app_rewriter [in backend.Parallelmove]
-app_rewrite2 [in backend.Parallelmove]
-arguments_not_preserved [in backend.Conventions]
-

B

-bind_parameters_length [in backend.Cminorgenproof]
-bits_of_Z_above [in lib.Integers]
-bits_of_Z_below [in lib.Integers]
-bits_of_Z_mone [in lib.Integers]
-bits_of_Z_of_bits [in lib.Integers]
-bits_of_Z_zero [in lib.Integers]
-bitwise_binop_assoc [in lib.Integers]
-bitwise_binop_commut [in lib.Integers]
-bitwise_binop_idem [in lib.Integers]
-bitwise_binop_rol [in lib.Integers]
-bitwise_binop_shl [in lib.Integers]
-bitwise_binop_shru [in lib.Integers]
-block_agree_refl [in backend.Mem]
-block_agree_sym [in backend.Mem]
-block_agree_trans [in backend.Mem]
-block_contents_exten [in backend.Mem]
-block_contents_inject_incr [in backend.Mem]
-block_cont_val [in backend.Mem]
-bool_of_false_val [in backend.Values]
-bool_of_false_val2 [in backend.Values]
-bool_of_false_val_inv [in backend.Values]
-bool_of_true_val [in backend.Values]
-bool_of_true_val2 [in backend.Values]
-bool_of_true_val_inv [in backend.Values]
-bounds_free_block [in backend.Mem]
-bound_float_callee_save_pos [in backend.Lineartyping]
-bound_float_local_pos [in backend.Lineartyping]
-bound_int_callee_save_pos [in backend.Lineartyping]
-bound_int_local_pos [in backend.Lineartyping]
-bound_outgoing_pos [in backend.Lineartyping]
-branch_target_characterization [in backend.Tunnelingproof]
-branch_target_rec_1 [in backend.Tunnelingproof]
-branch_target_rec_2 [in backend.Tunnelingproof]
-

C

-callstack_dom_diff [in backend.Machabstr2mach]
-callstack_dom_incr [in backend.Machabstr2mach]
-callstack_dom_less [in backend.Machabstr2mach]
-callstack_exten [in backend.Machabstr2mach]
-callstack_function_entry [in backend.Machabstr2mach]
-callstack_function_return [in backend.Machabstr2mach]
-callstack_get_parent [in backend.Machabstr2mach]
-callstack_get_slot [in backend.Machabstr2mach]
-callstack_init [in backend.Machabstr2mach]
-callstack_load [in backend.Machabstr2mach]
-callstack_set_slot [in backend.Machabstr2mach]
-callstack_store [in backend.Machabstr2mach]
-callstack_store_aux [in backend.Machabstr2mach]
-callstack_store_ok [in backend.Machabstr2mach]
-call_regs_param_of_arg [in backend.Allocproof]
-cast16unsigned_and [in lib.Integers]
-cast16unsigned_and [in backend.Values]
-cast16_signed_equal_if_unsigned_equal [in lib.Integers]
-cast16_signed_idem [in lib.Integers]
-cast16_unsigned_idem [in lib.Integers]
-cast16_unsigned_signed [in lib.Integers]
-cast8unsigned_and [in lib.Integers]
-cast8unsigned_and [in backend.Values]
-cast8_signed_equal_if_unsigned_equal [in lib.Integers]
-cast8_signed_idem [in lib.Integers]
-cast8_signed_unsigned [in lib.Integers]
-cast8_unsigned_idem [in lib.Integers]
-cast8_unsigned_signed [in lib.Integers]
-check_all_leaves_sound [in lib.Inclusion]
-check_coloring_1_correct [in backend.Coloringproof]
-check_coloring_2_correct [in backend.Coloringproof]
-check_coloring_3_correct [in backend.Coloringproof]
-check_cont_agree [in backend.Mem]
-check_cont_false [in backend.Mem]
-check_cont_inject [in backend.Mem]
-check_cont_inv [in backend.Mem]
-check_cont_true [in backend.Mem]
-check_equal_on_range_correct [in lib.Integers]
-cleanup_code_conservation [in backend.Linearizetyping]
-cleanup_code_conservation_2 [in backend.Linearizetyping]
-cleanup_code_correct_1 [in backend.Linearizeproof]
-cleanup_code_correct_2 [in backend.Linearizeproof]
-cleanup_function_conservation [in backend.Linearizetyping]
-cleanup_function_conservation_2 [in backend.Linearizetyping]
-cleanup_function_correct [in backend.Linearizeproof]
-cmpf_ge [in backend.Values]
-cmpf_is_bool [in backend.Values]
-cmpf_le [in backend.Values]
-cmpu_is_bool [in backend.Values]
-cmp_is_bool [in backend.Values]
-cmp_mismatch_is_bool [in backend.Values]
-code_tail_next [in backend.PPCgenproof]
-code_tail_next_int [in backend.PPCgenproof]
-combine_commut [in lib.Maps]
-compare [in lib.Ordered]
-compare [in lib.Ordered]
-compare [in lib.Ordered]
-compare_float_spec [in backend.PPCgenproof1]
-compare_sint_spec [in backend.PPCgenproof1]
-compare_uint_spec [in backend.PPCgenproof1]
-cond_strength_reduction_correct [in backend.Constpropproof]
-consistent_not_eq [in backend.RTLtyping]
-cons_replace [in backend.Parallelmove]
-contentmap_inject_incr [in backend.Mem]
-content_inject_incr [in backend.Mem]
-correct_interf_alloc_instr [in backend.Coloringproof]
-correct_interf_instr_incl [in backend.Coloringproof]
-

D

-definite_included [in backend.RTLtyping]
-diff_not_eq [in backend.Locations]
-diff_sym [in backend.Locations]
-discard_top_worklist_invariant [in backend.Kildall]
-disc1 [in backend.Parallelmove]
-disc2 [in backend.Parallelmove]
-disjoint_cons_left [in backend.Locations]
-disjoint_cons_right [in backend.Locations]
-disjoint_notin [in backend.Locations]
-disjoint_sym [in backend.Locations]
-disjoint_tmp__noTmp [in backend.Parallelmove]
-dis_dsttmp1_pnilnil [in backend.Allocproof_aux]
-dis_srctmp1_pnilnil [in backend.Allocproof_aux]
-divs_pow2 [in lib.Integers]
-divs_pow2 [in backend.Values]
-divu_pow2 [in backend.Values]
-divu_pow2 [in lib.Integers]
-Done_notmp1src_inv [in backend.Allocproof_aux]
-Done_notmp1src_invf [in backend.Allocproof_aux]
-Done_notmp1src_invpp [in backend.Allocproof_aux]
-Done_notmp1src_res [in backend.Allocproof_aux]
-Done_notmp1_inv [in backend.Allocproof_aux]
-Done_notmp1_invf [in backend.Allocproof_aux]
-Done_notmp1_invpp [in backend.Allocproof_aux]
-Done_notmp1_res [in backend.Allocproof_aux]
-Done_notmp3_inv [in backend.Allocproof_aux]
-Done_notmp3_invf [in backend.Allocproof_aux]
-Done_notmp3_invpp [in backend.Allocproof_aux]
-Done_notmp3_res [in backend.Allocproof_aux]
-dstepp_sameExec [in backend.Parallelmove]
-dstepp_stepp [in backend.Parallelmove]
-dstep_inv [in backend.Parallelmove]
-dstep_inv_getdst [in backend.Parallelmove]
-dstep_step [in backend.Parallelmove]
-dst_tmp2_res [in backend.Allocproof_aux]
-dst_tmp2_step [in backend.Allocproof_aux]
-dst_tmp2_stepf [in backend.Allocproof_aux]
-dst_tmp2_stepp [in backend.Allocproof_aux]
-

E

-elements_complete [in lib.Maps]
-elements_complete [in lib.Sets]
-elements_correct [in lib.Maps]
-elements_correct [in lib.Sets]
-elements_keys_norepet [in lib.Maps]
-empty_numbering_satisfiable [in backend.CSE]
-encode_decode [in backend.RTLtyping]
-encode_injective [in backend.RTLtyping]
-entrypoint_function_translated [in backend.Allocproof]
-enumerate_complete [in backend.Linearizeproof]
-enumerate_head [in backend.Linearizeproof]
-enumerate_norepet [in backend.Linearizeproof]
-eq [in backend.Constprop]
-eq [in lib.Lattice]
-eq [in lib.Sets]
-eq [in lib.Lattice]
-eq [in lib.Lattice]
-eq [in backend.Locations]
-eq [in lib.Maps]
-eq [in lib.Maps]
-eqmod_add [in lib.Integers]
-eqmod_mod [in lib.Integers]
-eqmod_mod_eq [in lib.Integers]
-eqmod_mult [in lib.Integers]
-eqmod_neg [in lib.Integers]
-eqmod_refl [in lib.Integers]
-eqmod_refl2 [in lib.Integers]
-eqmod_small_eq [in lib.Integers]
-eqmod_sub [in lib.Integers]
-eqmod_sym [in lib.Integers]
-eqmod_trans [in lib.Integers]
-eqmod_256_unsigned_repr [in lib.Integers]
-eqmod_65536_unsigned_repr [in lib.Integers]
-eqm_add [in lib.Integers]
-eqm_mult [in lib.Integers]
-eqm_neg [in lib.Integers]
-eqm_refl [in lib.Integers]
-eqm_refl2 [in lib.Integers]
-eqm_samerepr [in lib.Integers]
-eqm_signed_unsigned [in lib.Integers]
-eqm_small_eq [in lib.Integers]
-eqm_sub [in lib.Integers]
-eqm_sym [in lib.Integers]
-eqm_trans [in lib.Integers]
-eqm_unsigned_repr [in lib.Integers]
-eqm_unsigned_repr_l [in lib.Integers]
-eqm_unsigned_repr_r [in lib.Integers]
-equal_eq [in backend.RTLtyping]
-equal_on_range [in lib.Integers]
-equation_evals_to_holds_1 [in backend.CSEproof]
-equation_evals_to_holds_2 [in backend.CSEproof]
-eq_dec [in lib.Integers]
-eq_false [in lib.Integers]
-eq_refl [in lib.Ordered]
-eq_refl [in lib.Ordered]
-eq_refl [in lib.Ordered]
-eq_spec [in lib.Integers]
-eq_sym [in lib.Ordered]
-eq_sym [in lib.Ordered]
-eq_sym [in lib.Integers]
-eq_sym [in lib.Ordered]
-eq_trans [in lib.Ordered]
-eq_trans [in lib.Ordered]
-eq_trans [in lib.Ordered]
-eq_true [in lib.Integers]
-error_inconsistent [in backend.RTLtyping]
-eval_absfloat [in backend.Cmconstrproof]
-eval_add [in backend.Cmconstrproof]
-eval_addf [in backend.Cmconstrproof]
-eval_addimm [in backend.Cmconstrproof]
-eval_addimm_ptr [in backend.Cmconstrproof]
-eval_addressing [in backend.Cmconstrproof]
-eval_addressing_preserved [in backend.Op]
-eval_addressing_weaken [in backend.Op]
-eval_add_ptr [in backend.Cmconstrproof]
-eval_add_ptr_2 [in backend.Cmconstrproof]
-eval_and [in backend.Cmconstrproof]
-eval_andimm [in backend.Cmconstrproof]
-eval_base_condition_of_expr [in backend.Cmconstrproof]
-eval_cast16signed [in backend.Cmconstrproof]
-eval_cast16unsigned [in backend.Cmconstrproof]
-eval_cast8signed [in backend.Cmconstrproof]
-eval_cast8unsigned [in backend.Cmconstrproof]
-eval_cmp [in backend.Cmconstrproof]
-eval_cmpf [in backend.Cmconstrproof]
-eval_cmpu [in backend.Cmconstrproof]
-eval_cmp_null_l [in backend.Cmconstrproof]
-eval_cmp_null_r [in backend.Cmconstrproof]
-eval_cmp_ptr [in backend.Cmconstrproof]
-eval_compare_null_weaken [in backend.Op]
-eval_conditionalexpr_false [in backend.Cmconstrproof]
-eval_conditionalexpr_true [in backend.Cmconstrproof]
-eval_condition_of_expr [in backend.Cmconstrproof]
-eval_condition_total_is_bool [in backend.Op]
-eval_condition_weaken [in backend.Op]
-eval_divf [in backend.Cmconstrproof]
-eval_divs [in backend.Cmconstrproof]
-eval_divu [in backend.Cmconstrproof]
-eval_divu_base [in backend.Cmconstrproof]
-eval_floatofint [in backend.Cmconstrproof]
-eval_floatofintu [in backend.Cmconstrproof]
-eval_intoffloat [in backend.Cmconstrproof]
-eval_lift [in backend.Cmconstrproof]
-eval_lift_expr [in backend.Cmconstrproof]
-eval_load [in backend.Cmconstrproof]
-eval_mods [in backend.Cmconstrproof]
-eval_modu [in backend.Cmconstrproof]
-eval_mod_aux [in backend.Cmconstrproof]
-eval_mul [in backend.Cmconstrproof]
-eval_mulf [in backend.Cmconstrproof]
-eval_mulimm [in backend.Cmconstrproof]
-eval_mulimm_base [in backend.Cmconstrproof]
-eval_negate_condition [in backend.Op]
-eval_negfloat [in backend.Cmconstrproof]
-eval_negint [in backend.Cmconstrproof]
-eval_notbool [in backend.Cmconstrproof]
-eval_notbool_base [in backend.Cmconstrproof]
-eval_notint [in backend.Cmconstrproof]
-eval_operation_preserved [in backend.Op]
-eval_operation_weaken [in backend.Op]
-eval_or [in backend.Cmconstrproof]
-eval_rolm [in backend.Cmconstrproof]
-eval_shl [in backend.Cmconstrproof]
-eval_shlimm [in backend.Cmconstrproof]
-eval_shr [in backend.Cmconstrproof]
-eval_shru [in backend.Cmconstrproof]
-eval_shruimm [in backend.Cmconstrproof]
-eval_singleoffloat [in backend.Cmconstrproof]
-eval_static_condition_correct [in backend.Constpropproof]
-eval_static_operation_correct [in backend.Constpropproof]
-eval_store [in backend.Cmconstrproof]
-eval_sub [in backend.Cmconstrproof]
-eval_subf [in backend.Cmconstrproof]
-eval_sub_ptr_int [in backend.Cmconstrproof]
-eval_sub_ptr_ptr [in backend.Cmconstrproof]
-eval_xor [in backend.Cmconstrproof]
-exec_blocks_Bgoto_inv [in backend.Tunnelingproof]
-exec_blocks_extends [in backend.LTL]
-exec_blocks_valid_outcome [in backend.Linearizeproof]
-exec_block_Bgoto_inv [in backend.Tunnelingproof]
-exec_function_body_prop_ [in backend.PPCgenproof]
-exec_function_equiv [in backend.Machabstr2mach]
-exec_function_prop_ [in backend.PPCgenproof]
-exec_ifthenelse_false [in backend.Cmconstrproof]
-exec_ifthenelse_true [in backend.Cmconstrproof]
-exec_Iload' [in backend.RTL]
-exec_instrs_Bgoto_inv [in backend.Tunnelingproof]
-exec_instrs_extends [in backend.RTLgenproof1]
-exec_instrs_extends_rec [in backend.RTLgenproof1]
-exec_instrs_incl [in backend.Stackingproof]
-exec_instrs_incl [in backend.PPCgenproof]
-exec_instrs_incr [in backend.RTLgenproof1]
-exec_instrs_link_invariant [in backend.Machtyping]
-exec_instrs_pmov [in backend.Allocproof_aux]
-exec_instrs_present [in backend.RTL]
-exec_instr_extends [in backend.RTLgenproof1]
-exec_instr_extends_rec [in backend.RTLgenproof1]
-exec_instr_incl [in backend.PPCgenproof]
-exec_instr_incl [in backend.Stackingproof]
-exec_instr_incr [in backend.RTLgenproof1]
-exec_instr_in_s2 [in backend.RTLgenproof1]
-exec_instr_link_invariant [in backend.Machtyping]
-exec_instr_not_halt [in backend.RTLgenproof1]
-exec_instr_present [in backend.RTL]
-exec_instr_update [in backend.Allocproof_aux]
-exec_Iop' [in backend.RTL]
-exec_Mcall_prop [in backend.PPCgenproof]
-exec_Mcond_false_prop [in backend.PPCgenproof]
-exec_Mcond_true_prop [in backend.PPCgenproof]
-exec_Mgetparam_prop [in backend.PPCgenproof]
-exec_Mgetstack' [in backend.Stackingproof]
-exec_Mgetstack_prop [in backend.PPCgenproof]
-exec_Mgoto_prop [in backend.PPCgenproof]
-exec_Mlabel_prop [in backend.PPCgenproof]
-exec_Mload_prop [in backend.PPCgenproof]
-exec_Mop_prop [in backend.PPCgenproof]
-exec_Msetstack' [in backend.Stackingproof]
-exec_Msetstack_prop [in backend.PPCgenproof]
-exec_Mstore_prop [in backend.PPCgenproof]
-exec_mutual_induction [in backend.Machabstr]
-exec_one_prop [in backend.PPCgenproof]
-exec_program_equiv [in backend.Machabstr2mach]
-exec_refl_prop [in backend.PPCgenproof]
-exec_step [in backend.RTL]
-exec_straight_exec_prop [in backend.PPCgenproof]
-exec_straight_one [in backend.PPCgenproof1]
-exec_straight_steps [in backend.PPCgenproof]
-exec_straight_steps_1 [in backend.PPCgenproof]
-exec_straight_steps_2 [in backend.PPCgenproof]
-exec_straight_three [in backend.PPCgenproof1]
-exec_straight_trans [in backend.PPCgenproof1]
-exec_straight_two [in backend.PPCgenproof1]
-exec_trans_prop [in backend.PPCgenproof]
-expr_condexpr_exprlist_ind [in backend.RTLgenproof1]
-exten [in lib.Maps]
-extends_refl [in backend.Mem]
-extend_inject_incr [in backend.Mem]
-

F

-find_funct_find_funct_ptr [in backend.Globalenvs]
-find_funct_inv [in backend.Globalenvs]
-find_funct_prop [in backend.Globalenvs]
-find_funct_ptr_inv [in backend.Globalenvs]
-find_funct_ptr_prop [in backend.Globalenvs]
-find_funct_ptr_transf [in backend.Globalenvs]
-find_funct_ptr_transf_partial [in backend.Globalenvs]
-find_funct_transf [in backend.Globalenvs]
-find_funct_transf_partial [in backend.Globalenvs]
-find_instr_in [in backend.PPCgenproof]
-find_instr_tail [in backend.PPCgenproof]
-find_label_cleanup_code [in backend.Linearizeproof]
-find_label_goto_label [in backend.PPCgenproof]
-find_label_incl [in backend.Stackingproof]
-find_label_lin [in backend.Linearizeproof]
-find_label_lin_block [in backend.Linearizeproof]
-find_label_lin_rec [in backend.Linearizeproof]
-find_label_transl_code [in backend.Stackingproof]
-find_label_unique [in backend.Linearizeproof]
-find_letvar_incr [in backend.RTLgenproof1]
-find_letvar_in_map [in backend.RTLgenproof1]
-find_letvar_not_mutated [in backend.RTLgenproof1]
-find_letvar_valid [in backend.RTLgenproof1]
-find_load_correct [in backend.CSEproof]
-find_op_correct [in backend.CSEproof]
-find_rhs_correct [in backend.CSEproof]
-find_symbol_inv [in backend.Globalenvs]
-find_symbol_transf [in backend.Globalenvs]
-find_symbol_transf_partial [in backend.Globalenvs]
-find_valnum_rhs_correct [in backend.CSEproof]
-find_var_incr [in backend.RTLgenproof1]
-find_var_in_map [in backend.RTLgenproof1]
-find_var_not_mutated [in backend.RTLgenproof1]
-find_var_valid [in backend.RTLgenproof1]
-fixpoint_entry [in backend.Kildall]
-fixpoint_entry [in backend.Kildall]
-fixpoint_entry [in backend.Kildall]
-fixpoint_incr [in backend.Kildall]
-fixpoint_invariant [in backend.Kildall]
-fixpoint_solution [in backend.Kildall]
-fixpoint_solution [in backend.Kildall]
-fixpoint_solution [in backend.Kildall]
-flatten_aux_valid_A [in lib.Inclusion]
-flatten_valid_A [in lib.Inclusion]
-floatcomp_correct [in backend.PPCgenproof1]
-float_callee_save_bound [in backend.Linearizetyping]
-float_callee_save_norepet [in backend.Conventions]
-float_callee_save_not_destroyed [in backend.Conventions]
-float_callee_save_type [in backend.Conventions]
-float_local_slot_bound [in backend.Linearizetyping]
-fold_spec [in lib.Maps]
-fold_spec [in lib.Sets]
-for_all_spec [in lib.Sets]
-Fpmov_correct [in backend.Parallelmove]
-Fpmov_correctMoves [in backend.Parallelmove]
-Fpmov_correct1 [in backend.Parallelmove]
-Fpmov_correct2 [in backend.Parallelmove]
-Fpmov_correct_ext [in backend.Parallelmove]
-Fpmov_correct_IT3 [in backend.Parallelmove]
-Fpmov_correct_map [in backend.Parallelmove]
-frame_match_alloc [in backend.Machabstr2mach]
-frame_match_exten [in backend.Machabstr2mach]
-frame_match_free [in backend.Machabstr2mach]
-frame_match_get_slot [in backend.Machabstr2mach]
-frame_match_load [in backend.Machabstr2mach]
-frame_match_new [in backend.Machabstr2mach]
-frame_match_set_slot [in backend.Machabstr2mach]
-frame_match_store [in backend.Machabstr2mach]
-frame_match_store_ok [in backend.Machabstr2mach]
-frame_match_store_stack_other [in backend.Machabstr2mach]
-free_empty_bounds [in backend.Mem]
-free_extends [in backend.Mem]
-free_first_inject [in backend.Mem]
-free_first_list_inject [in backend.Mem]
-free_inject [in backend.Mem]
-free_snd_inject [in backend.Mem]
-freg_eq [in backend.PPC]
-freg_of_is_data_reg [in backend.PPCgenproof1]
-freg_of_not_FPR13 [in backend.PPCgenproof1]
-freg_val [in backend.PPCgenproof1]
-fresh_block_alloc [in backend.Mem]
-functions_globalenv [in backend.Globalenvs]
-functions_translated [in backend.Constpropproof]
-functions_translated [in backend.Tunnelingproof]
-functions_translated [in backend.PPCgenproof]
-functions_translated [in backend.Allocproof]
-functions_translated [in backend.Linearizeproof]
-functions_translated [in backend.Stackingproof]
-functions_translated [in backend.CSEproof]
-functions_translated [in backend.Cminorgenproof]
-functions_translated [in backend.RTLgenproof]
-functions_translated_no_overflow [in backend.PPCgenproof]
-functions_translated_2 [in backend.PPCgenproof]
-function_entry_ok [in backend.Cminorgenproof]
-function_ptr_translated [in backend.Linearizeproof]
-function_ptr_translated [in backend.Allocproof]
-function_ptr_translated [in backend.Stackingproof]
-function_ptr_translated [in backend.Cminorgenproof]
-function_ptr_translated [in backend.RTLgenproof]
-function_ptr_translated [in backend.Constpropproof]
-function_ptr_translated [in backend.Tunnelingproof]
-funct_ptr_translated [in backend.CSEproof]
-f2ind [in backend.Parallelmove]
-f2ind' [in backend.Parallelmove]
-

G

-gcombine [in lib.Maps]
-gempty [in lib.Maps]
-getdst_add [in backend.Parallelmove]
-getdst_app [in backend.Parallelmove]
-getdst_f [in backend.Alloctyping_aux]
-getdst_lists2moves [in backend.Allocproof_aux]
-getdst_map [in backend.Parallelmove]
-getN_agree [in backend.Mem]
-getN_init [in backend.Mem]
-getN_inject [in backend.Mem]
-getN_setN_mismatch [in backend.Mem]
-getN_setN_other [in backend.Mem]
-getN_setN_overlap [in backend.Mem]
-getN_setN_same [in backend.Mem]
-getsrcdst_app [in backend.Allocproof_aux]
-getsrc_add [in backend.Parallelmove]
-getsrc_add1 [in backend.Parallelmove]
-getsrc_app [in backend.Parallelmove]
-getsrc_f [in backend.Alloctyping_aux]
-getsrc_map [in backend.Parallelmove]
-get_add_1 [in backend.RTLtyping]
-get_add_2 [in backend.RTLtyping]
-get_bot [in lib.Lattice]
-get_empty [in backend.RTLtyping]
-get_noWrite [in backend.Parallelmove]
-get_pexec_id_noWrite [in backend.Parallelmove]
-get_slot_index [in backend.Stackingproof]
-get_slot_ok [in backend.Stackingproof]
-get_top [in lib.Lattice]
-get_update [in backend.Parallelmove]
-get_update_diff [in backend.Parallelmove]
-get_update_id [in backend.Parallelmove]
-get_update_ndiff [in backend.Parallelmove]
-get_xget_h [in lib.Maps]
-ge_bot [in lib.Lattice]
-ge_bot [in lib.Lattice]
-ge_bot [in lib.Sets]
-ge_bot [in lib.Lattice]
-ge_bot [in backend.Constprop]
-ge_lub_left [in lib.Lattice]
-ge_lub_left [in lib.Sets]
-ge_lub_left [in backend.Constprop]
-ge_lub_left [in lib.Lattice]
-ge_lub_left [in lib.Lattice]
-ge_lub_right [in lib.Sets]
-ge_refl [in lib.Lattice]
-ge_refl [in lib.Sets]
-ge_refl [in lib.Lattice]
-ge_refl [in lib.Lattice]
-ge_refl [in backend.Constprop]
-ge_top [in lib.Lattice]
-ge_top [in backend.Constprop]
-ge_top [in lib.Lattice]
-ge_top [in lib.Lattice]
-ge_trans [in lib.Lattice]
-ge_trans [in backend.Constprop]
-ge_trans [in lib.Sets]
-ge_trans [in lib.Lattice]
-ge_trans [in lib.Lattice]
-gi [in lib.Maps]
-gi [in lib.Maps]
-gi [in lib.Maps]
-gleaf [in lib.Maps]
-gmap [in lib.Maps]
-gmap [in lib.Maps]
-gmap [in lib.Maps]
-gmap [in lib.Maps]
-gpr_or_zero_not_zero [in backend.PPCgenproof1]
-gpr_or_zero_zero [in backend.PPCgenproof1]
-graph_incl_refl [in backend.Coloringproof]
-graph_incl_trans [in backend.InterfGraph]
-gro [in lib.Maps]
-grs [in lib.Maps]
-gsident [in lib.Maps]
-gsident [in lib.Maps]
-gsident [in lib.Maps]
-gso [in lib.Maps]
-gso [in backend.Locations]
-gso [in lib.Maps]
-gso [in lib.Maps]
-gso [in lib.Lattice]
-gso [in lib.Maps]
-gss [in lib.Maps]
-gss [in lib.Maps]
-gss [in backend.Locations]
-gss [in lib.Maps]
-gss [in lib.Lattice]
-gss [in lib.Maps]
-gsspec [in lib.Maps]
-gsspec [in lib.Maps]
-gsspec [in lib.Maps]
-gsspec [in lib.Maps]
-

H

-high_bound_alloc [in backend.Mem]
-high_bound_free [in backend.Mem]
-high_bound_store [in backend.Mem]
-high_half_signed_zero [in backend.PPCgenproof1]
-high_half_unsigned_zero [in backend.PPCgenproof1]
-

I

-identify_aux_decomp [in lib.union_find]
-identify_base_a_maps_to_b [in lib.union_find]
-identify_base_b_canon [in lib.union_find]
-identify_base_order_wf [in lib.union_find]
-identify_base_repr [in lib.union_find]
-identify_base_repr_order [in lib.union_find]
-identify_base_sameclass_1 [in lib.union_find]
-identify_base_sameclass_2 [in lib.union_find]
-included_consistent [in backend.RTLtyping]
-included_identify [in backend.RTLtyping]
-included_mapped [in backend.RTLtyping]
-included_mapped_forall [in backend.RTLtyping]
-included_refl [in backend.RTLtyping]
-included_trans [in backend.RTLtyping]
-inclusion_theorem [in lib.Inclusion]
-incl_app_inv_l [in lib.Coqlib]
-incl_app_inv_r [in lib.Coqlib]
-incl_cons_inv [in lib.Coqlib]
-incl_dst [in backend.Alloctyping_aux]
-incl_find_label [in backend.Machtyping]
-incl_nil [in backend.Alloctyping_aux]
-incl_same_head [in lib.Coqlib]
-incl_src [in backend.Alloctyping_aux]
-index_arg_valid [in backend.Stackingproof]
-index_float_callee_save_inj [in backend.Conventions]
-index_float_callee_save_pos [in backend.Conventions]
-index_float_callee_save_pos2 [in backend.Conventions]
-index_inj [in lib.Maps]
-index_inj [in backend.Locations]
-index_inj [in lib.Maps]
-index_int_callee_save_inj [in backend.Conventions]
-index_int_callee_save_pos [in backend.Conventions]
-index_int_callee_save_pos2 [in backend.Conventions]
-index_local_valid [in backend.Stackingproof]
-index_saved_float_valid [in backend.Stackingproof]
-index_saved_int_valid [in backend.Stackingproof]
-index_val_init_frame [in backend.Stackingproof]
-Indst_noOverlap_aux [in backend.Parallelmove]
-Ingetsrc_swap [in backend.Parallelmove]
-Ingetsrc_swap2 [in backend.Parallelmove]
-initial_state_invariant [in backend.Kildall]
-initmem_nullptr [in backend.Globalenvs]
-initmem_undef [in backend.Globalenvs]
-init_mapping_wf [in backend.RTLgenproof1]
-init_mem_transf [in backend.Globalenvs]
-init_mem_transf_partial [in backend.Globalenvs]
-init_state_wf [in backend.RTLgen]
-inject_incr_refl [in backend.Mem]
-inject_incr_trans [in backend.Mem]
-insert_bin_included [in lib.Inclusion]
-insert_lenv_lookup1 [in backend.Cmconstrproof]
-insert_lenv_lookup2 [in backend.Cmconstrproof]
-instr_at_incr [in backend.RTLgenproof1]
-interfere_incl [in backend.Coloringproof]
-interfere_mreg_incl [in backend.Coloringproof]
-interfere_sym [in backend.InterfGraph]
-interf_graph_correct_1 [in backend.Coloringproof]
-interf_graph_correct_2 [in backend.Coloringproof]
-interf_graph_correct_3 [in backend.Coloringproof]
-intval_correct [in backend.Constpropproof]
-int_add_no_overflow [in backend.Machabstr2mach]
-int_callee_save_bound [in backend.Linearizetyping]
-int_callee_save_norepet [in backend.Conventions]
-int_callee_save_not_destroyed [in backend.Conventions]
-int_callee_save_type [in backend.Conventions]
-int_float_callee_save_disjoint [in backend.Conventions]
-int_local_slot_bound [in backend.Linearizetyping]
-inv_eval_Eop_0 [in backend.Cmconstrproof]
-inv_eval_Eop_1 [in backend.Cmconstrproof]
-inv_eval_Eop_2 [in backend.Cmconstrproof]
-in_bounds_exten [in backend.Mem]
-in_bounds_holds [in backend.Mem]
-in_bounds_inject [in backend.Mem]
-in_cons_noteq [in backend.Allocproof_aux]
-in_incr_refl [in backend.Kildall]
-in_incr_trans [in backend.Kildall]
-In_Indst [in backend.Parallelmove]
-in_move__in_srcdst [in backend.Alloctyping_aux]
-In_norepet [in backend.Allocproof_aux]
-in_notin_diff [in backend.Locations]
-In_noTmp_notempo [in backend.Parallelmove]
-in_or_insert_bin [in lib.Inclusion]
-in_or_notin_callstack [in backend.Machabstr2mach]
-In_permute_app_head [in lib.Inclusion]
-in_range_range [in lib.Integers]
-in_remove_head [in lib.Inclusion]
-In_SD_diff [in backend.Parallelmove]
-In_SD_diff' [in backend.Parallelmove]
-In_SD_no_o [in backend.Parallelmove]
-in_split_move [in backend.Alloctyping_aux]
-in_xelements [in lib.Maps]
-in_xkeys [in lib.Maps]
-ireg_eq [in backend.PPC]
-ireg_of_is_data_reg [in backend.PPCgenproof1]
-ireg_of_not_GPR1 [in backend.PPCgenproof1]
-ireg_of_not_GPR2 [in backend.PPCgenproof1]
-ireg_val [in backend.PPCgenproof1]
-isfalse_not_istrue [in backend.Values]
-istrue_not_isfalse [in backend.Values]
-is_goto_block_correct [in backend.Tunnelingproof]
-is_label_correct [in backend.PPC]
-is_label_correct [in backend.Mach]
-is_label_correct [in backend.Linear]
-is_move_operation_correct [in backend.Op]
-is_power2_correct [in lib.Integers]
-is_power2_range [in lib.Integers]
-is_power2_rng [in lib.Integers]
-is_tail_cons_left [in backend.Linearizeproof]
-is_tail_exec_instr [in backend.Linearizeproof]
-is_tail_exec_instrs [in backend.Linearizeproof]
-is_tail_find_label [in backend.Linearizeproof]
-is_tail_in [in backend.Linearizeproof]
-iterate_base [in backend.Kildall]
-iterate_incr [in backend.Kildall]
-iterate_solution [in backend.Kildall]
-iterate_step [in backend.Kildall]
-

K

-kill_load_eqs_incl [in backend.CSEproof]
-kill_load_eqs_ops [in backend.CSEproof]
-kill_load_satisfiable [in backend.CSEproof]
-

L

-label_in_lin_block [in backend.Linearizeproof]
-label_in_lin_rec [in backend.Linearizeproof]
-label_pos_code_tail [in backend.PPCgenproof]
-last_app [in backend.Parallelmove]
-last_cons [in backend.Parallelmove]
-last_replace [in backend.Parallelmove]
-length_addr_args [in backend.Allocproof]
-length_app [in backend.Parallelmove]
-length_cond_args [in backend.Allocproof]
-length_op_args [in backend.Allocproof]
-length_replace [in backend.Parallelmove]
-let_fold_args_res [in backend.RTLtyping]
-linearize_block_incl [in backend.Linearizetyping]
-list_append_map [in lib.Coqlib]
-list_disjoint_cons_left [in lib.Coqlib]
-list_disjoint_cons_right [in lib.Coqlib]
-list_disjoint_notin [in lib.Coqlib]
-list_disjoint_sym [in lib.Coqlib]
-list_forall2_imply [in lib.Coqlib]
-list_in_map_inv [in lib.Coqlib]
-list_length_map [in lib.Coqlib]
-list_map_compose [in lib.Coqlib]
-list_map_exten [in lib.Coqlib]
-list_map_norepet [in lib.Coqlib]
-list_map_nth [in lib.Coqlib]
-list_norepet_append [in lib.Coqlib]
-list_norepet_append_left [in lib.Coqlib]
-list_norepet_append_right [in lib.Coqlib]
-list_norepet_dec [in lib.Coqlib]
-loadimm_correct [in backend.PPCgenproof1]
-loadind_aux_correct [in backend.PPCgenproof1]
-loadind_correct [in backend.PPCgenproof1]
-loadv_inject [in backend.Mem]
-loadv_8_signed_unsigned [in backend.PPCgenproof]
-load_agree [in backend.Mem]
-load_alloc_other [in backend.Mem]
-load_alloc_same [in backend.Mem]
-load_contentmap_agree [in backend.Mem]
-load_contents_init [in backend.Mem]
-load_contents_inject [in backend.Mem]
-load_extends [in backend.Mem]
-load_free [in backend.Mem]
-load_freelist [in backend.Cminorgenproof]
-load_from_alloc_is_undef [in backend.Cminorgenproof]
-load_inject [in backend.Mem]
-load_inv [in backend.Mem]
-load_in_bounds [in backend.Mem]
-load_result_idem [in backend.Cminorgenproof]
-load_result_inject [in backend.Mem]
-load_result_normalized [in backend.Cminorgenproof]
-load_result_ty [in backend.Machabstr2mach]
-load_store_contents_mismatch [in backend.Mem]
-load_store_contents_other [in backend.Mem]
-load_store_contents_overlap [in backend.Mem]
-load_store_contents_same [in backend.Mem]
-load_store_other [in backend.Mem]
-load_store_same [in backend.Mem]
-locs_acceptable_disj_temporaries [in backend.Conventions]
-loc_acceptable_noteq_diff [in backend.Allocproof]
-loc_acceptable_notin_notin [in backend.Allocproof]
-loc_arguments_acceptable [in backend.Conventions]
-loc_arguments_bounded [in backend.Conventions]
-loc_arguments_length [in backend.Conventions]
-loc_arguments_norepet [in backend.Conventions]
-loc_arguments_not_temporaries [in backend.Conventions]
-loc_arguments_type [in backend.Conventions]
-loc_is_acceptable_correct [in backend.Coloringproof]
-loc_parameters_not_temporaries [in backend.Conventions]
-loc_parameters_type [in backend.Conventions]
-loc_result_acceptable [in backend.Conventions]
-loc_result_type [in backend.Conventions]
-low_bound_alloc [in backend.Mem]
-low_bound_free [in backend.Mem]
-low_bound_store [in backend.Mem]
-low_high_s [in backend.PPCgenproof1]
-low_high_u [in backend.PPCgenproof1]
-low_high_u_xor [in backend.PPCgenproof1]
-lt_not_eq [in lib.Ordered]
-lt_not_eq [in lib.Ordered]
-lt_not_eq [in lib.Ordered]
-lt_trans [in lib.Ordered]
-lt_trans [in lib.Ordered]
-lt_trans [in lib.Ordered]
-lub_commut [in lib.Lattice]
-lub_commut [in backend.Constprop]
-lub_commut [in lib.Lattice]
-lub_commut [in lib.Sets]
-lub_commut [in lib.Lattice]
-

M

-make_addimm_correct [in backend.Constpropproof]
-make_andimm_correct [in backend.Constpropproof]
-make_cast_correct [in backend.Cminorgenproof]
-make_load_correct [in backend.Cminorgenproof]
-make_mulimm_correct [in backend.Constpropproof]
-make_op_correct [in backend.Cminorgenproof]
-make_orimm_correct [in backend.Constpropproof]
-make_predecessors_correct [in backend.Kildall]
-make_shlimm_correct [in backend.Constpropproof]
-make_shrimm_correct [in backend.Constpropproof]
-make_shruimm_correct [in backend.Constpropproof]
-make_stackaddr_correct [in backend.Cminorgenproof]
-make_store_correct [in backend.Cminorgenproof]
-make_xorimm_correct [in backend.Constpropproof]
-mapped_included_consistent [in backend.RTLtyping]
-mapped_list_included [in backend.RTLtyping]
-map_f_getsrc_getdst [in backend.Alloctyping_aux]
-map_inv [in backend.Allocproof_aux]
-map_wf_incr [in backend.RTLgenproof1]
-match_callstack_alloc_left [in backend.Cminorgenproof]
-match_callstack_alloc_other [in backend.Cminorgenproof]
-match_callstack_alloc_right [in backend.Cminorgenproof]
-match_callstack_alloc_variables [in backend.Cminorgenproof]
-match_callstack_alloc_variables_rec [in backend.Cminorgenproof]
-match_callstack_freelist [in backend.Cminorgenproof]
-match_callstack_freelist_rec [in backend.Cminorgenproof]
-match_callstack_incr_bound [in backend.Cminorgenproof]
-match_callstack_mapped [in backend.Cminorgenproof]
-match_callstack_match_globalenvs [in backend.Cminorgenproof]
-match_callstack_store_above [in backend.Cminorgenproof]
-match_callstack_store_local [in backend.Cminorgenproof]
-match_callstack_store_local_unchanged [in backend.Cminorgenproof]
-match_env_alloc_other [in backend.Cminorgenproof]
-match_env_alloc_same [in backend.Cminorgenproof]
-match_env_empty [in backend.RTLgenproof1]
-match_env_exten [in backend.RTLgenproof1]
-match_env_extensional [in backend.Cminorgenproof]
-match_env_find_reg [in backend.RTLgenproof1]
-match_env_freelist [in backend.Cminorgenproof]
-match_env_invariant [in backend.RTLgenproof1]
-match_env_letvar [in backend.RTLgenproof1]
-match_env_store_above [in backend.Cminorgenproof]
-match_env_store_local [in backend.Cminorgenproof]
-match_env_store_mapped [in backend.Cminorgenproof]
-match_env_update_temp [in backend.RTLgenproof1]
-match_env_update_var [in backend.RTLgenproof1]
-match_globalenvs_init [in backend.Cminorgenproof]
-match_init_env_init_reg [in backend.RTLgenproof1]
-match_set_locals [in backend.RTLgenproof1]
-match_set_params_init_regs [in backend.RTLgenproof1]
-max_over_instrs_bound [in backend.Linearizetyping]
-max_over_list_bound [in backend.Linearizetyping]
-max_over_list_pos [in backend.Lineartyping]
-max_over_regs_of_funct_bound [in backend.Linearizetyping]
-max_over_regs_of_funct_pos [in backend.Lineartyping]
-max_over_slots_of_funct_bound [in backend.Linearizetyping]
-max_over_slots_of_funct_pos [in backend.Lineartyping]
-member_correct [in backend.RTLtyping]
-mem_add_globals_transf [in backend.Globalenvs]
-mem_add_other [in lib.Sets]
-mem_add_same [in lib.Sets]
-mem_add_tail [in backend.InterfGraph]
-mem_empty [in lib.Sets]
-mem_exten [in backend.Mem]
-mem_remove_other [in lib.Sets]
-mem_remove_same [in lib.Sets]
-mem_union [in lib.Sets]
-mkint_eq [in lib.Integers]
-mods_divs [in lib.Integers]
-mods_divs [in backend.Values]
-modulus_pos [in lib.Integers]
-modu_and [in lib.Integers]
-modu_divu [in lib.Integers]
-modu_divu [in backend.Values]
-modu_divu_Euclid [in lib.Integers]
-modu_pow2 [in backend.Values]
-mod_in_range [in lib.Integers]
-mone_max_unsigned [in lib.Integers]
-move_types_res [in backend.Alloctyping_aux]
-move_types_stepf [in backend.Alloctyping_aux]
-mreg_eq [in backend.Locations]
-mreg_is_bounded [in backend.Linearizetyping]
-multiple_predecessors [in backend.Kildall]
-mul_add_distr_l [in lib.Integers]
-mul_add_distr_l [in backend.Values]
-mul_add_distr_r [in lib.Integers]
-mul_add_distr_r [in backend.Values]
-mul_assoc [in lib.Integers]
-mul_assoc [in backend.Values]
-mul_commut [in backend.Values]
-mul_commut [in lib.Integers]
-mul_one [in lib.Integers]
-mul_pow2 [in lib.Integers]
-mul_pow2 [in backend.Values]
-mul_zero [in lib.Integers]
-mutated_reg_in_map [in backend.RTLgenproof1]
-

N

-negate_cmp [in backend.Values]
-negate_cmp [in lib.Integers]
-negate_cmpf_eq [in backend.Values]
-negate_cmpu [in lib.Integers]
-negate_cmpu [in backend.Values]
-negate_cmp_mismatch [in backend.Values]
-neg_add_distr [in backend.Values]
-neg_add_distr [in lib.Integers]
-neg_repr [in lib.Integers]
-neg_zero [in lib.Integers]
-neg_zero [in backend.Values]
-neq_is_neq [in backend.Parallelmove]
-new_reg_fresh [in backend.RTLgenproof1]
-new_reg_incr [in backend.RTLgenproof1]
-new_reg_not_in_map [in backend.RTLgenproof1]
-new_reg_not_mutated [in backend.RTLgenproof1]
-new_reg_return_ok [in backend.RTLgenproof1]
-new_reg_valid [in backend.RTLgenproof1]
-nextinstr_inv [in backend.PPCgenproof1]
-nextinstr_set_preg [in backend.PPCgenproof1]
-non_overlap_diff [in backend.Locations]
-noOverlapaux_insert [in backend.Parallelmove]
-noOverlapaux_swap2 [in backend.Parallelmove]
-noOverlap_auxpop [in backend.Parallelmove]
-noOverlap_auxPop [in backend.Parallelmove]
-noOverlap_aux_app [in backend.Parallelmove]
-noOverlap_Front0 [in backend.Parallelmove]
-noOverlap_head [in backend.Parallelmove]
-noOverlap_insert [in backend.Parallelmove]
-noOverlap_movBack [in backend.Parallelmove]
-noOverlap_movBack0 [in backend.Parallelmove]
-noOverlap_movFront [in backend.Parallelmove]
-noOverlap_nil [in backend.Parallelmove]
-noOverlap_Pop [in backend.Parallelmove]
-noOverlap_pop [in backend.Parallelmove]
-noOverlap_right [in backend.Parallelmove]
-noOverlap_swap [in backend.Parallelmove]
-noO_diff [in backend.Parallelmove]
-noO_list_pnilnil [in backend.Allocproof_aux]
-noRead_app [in backend.Parallelmove]
-noRead_by_path [in backend.Parallelmove]
-norepet_SD [in backend.Allocproof_aux]
-notbool_idem2 [in backend.Values]
-notbool_idem3 [in backend.Values]
-notbool_isfalse_istrue [in lib.Integers]
-notbool_istrue_isfalse [in lib.Integers]
-notbool_is_bool [in backend.Values]
-notbool_negb_1 [in backend.Values]
-notbool_negb_2 [in backend.Values]
-notbool_xor [in backend.Values]
-notindst_nW [in backend.Parallelmove]
-notin_disjoint [in backend.Locations]
-notin_not_in [in backend.Locations]
-noTmpLast_lastnoTmp [in backend.Parallelmove]
-noTmpLast_Pop [in backend.Parallelmove]
-noTmpLast_pop [in backend.Parallelmove]
-noTmpLast_popBack [in backend.Parallelmove]
-noTmpLast_push [in backend.Parallelmove]
-noTmpLast_tmpLast [in backend.Parallelmove]
-noTmpL_diff [in backend.Parallelmove]
-noTmp_app [in backend.Parallelmove]
-noTmp_append [in backend.Parallelmove]
-noTmP_noOverlap_aux [in backend.Parallelmove]
-noTmp_noReadTmp [in backend.Parallelmove]
-noTmp_noTmpLast [in backend.Parallelmove]
-noTmp_pop [in backend.Parallelmove]
-noWrite_in [in backend.Parallelmove]
-noWrite_insert [in backend.Parallelmove]
-noWrite_movFront [in backend.Parallelmove]
-noWrite_pop [in backend.Parallelmove]
-noWrite_swap [in backend.Parallelmove]
-noWrite_tmpLast [in backend.Parallelmove]
-no_overlapD_inv [in backend.Allocproof_aux]
-no_overlapD_invf [in backend.Allocproof_aux]
-no_overlapD_invpp [in backend.Allocproof_aux]
-no_overlapD_res [in backend.Allocproof_aux]
-no_overlap_arguments [in backend.Conventions]
-no_overlap_list_pop [in backend.Allocproof_aux]
-no_overlap_noOverlap [in backend.Parallelmove]
-no_overlap_parameters [in backend.Conventions]
-no_overlap_temp [in backend.Allocproof_aux]
-no_self_loop [in backend.Kildall]
-nth_error_in [in lib.Coqlib]
-nth_error_nil [in lib.Coqlib]
-numbering_holds_exten [in backend.CSEproof]
-

O

-offset_of_index_disj [in backend.Stackingproof]
-offset_of_index_no_overflow [in backend.Stackingproof]
-offset_of_index_valid [in backend.Stackingproof]
-of_bool_is_bool [in backend.Values]
-one_bits_decomp [in lib.Integers]
-one_bits_range [in lib.Integers]
-one_not_zero [in lib.Integers]
-option_sum [in lib.union_find]
-op_strength_reduction_correct [in backend.Constpropproof]
-ordered_pair_charact [in backend.InterfGraph]
-ordered_pair_sym [in backend.InterfGraph]
-orimm_correct [in backend.PPCgenproof1]
-or_assoc [in lib.Integers]
-or_assoc [in backend.Values]
-or_commut [in lib.Integers]
-or_commut [in backend.Values]
-or_idem [in lib.Integers]
-or_mone [in lib.Integers]
-or_of_bool [in backend.Values]
-or_rolm [in lib.Integers]
-or_rolm [in backend.Values]
-or_zero [in lib.Integers]
-outgoing_slot_bound [in backend.Linearizetyping]
-overlap_aux_false_1 [in backend.Locations]
-overlap_aux_true_1 [in backend.Locations]
-overlap_aux_true_2 [in backend.Locations]
-overlap_not_diff [in backend.Locations]
-

P

-parallel_move_correct [in backend.Allocproof]
-parallel_move_correctX [in backend.Allocproof_aux]
-parallel_move_correct' [in backend.Allocproof_aux]
-path_pop [in backend.Parallelmove]
-path_tmpLast [in backend.Parallelmove]
-peq_false [in lib.Coqlib]
-peq_true [in lib.Coqlib]
-pexec_add [in backend.Parallelmove]
-pexec_correct [in backend.Parallelmove]
-pexec_mov [in backend.Parallelmove]
-pexec_movBack [in backend.Parallelmove]
-pexec_movFront [in backend.Parallelmove]
-pexec_nop [in backend.Parallelmove]
-pexec_push [in backend.Parallelmove]
-pexec_swap [in backend.Parallelmove]
-pexec_update [in backend.Parallelmove]
-Ple_refl [in lib.Coqlib]
-Ple_succ [in lib.Coqlib]
-Ple_trans [in lib.Coqlib]
-Plt_ne [in lib.Coqlib]
-Plt_Ple [in lib.Coqlib]
-Plt_Ple_trans [in lib.Coqlib]
-Plt_strict [in lib.Coqlib]
-Plt_succ [in lib.Coqlib]
-Plt_succ_inv [in lib.Coqlib]
-Plt_trans [in lib.Coqlib]
-Plt_trans_succ [in lib.Coqlib]
-Plt_wf [in lib.Coqlib]
-Pmov_equation [in backend.Parallelmove]
-positive_Peano_ind [in lib.Coqlib]
-positive_rec_base [in lib.Coqlib]
-positive_rec_succ [in lib.Coqlib]
-Ppred_Plt [in lib.Coqlib]
-predecessors_correct [in backend.Kildall]
-preg_eq [in backend.PPC]
-preg_of_injective [in backend.PPCgenproof1]
-preg_of_is_data_reg [in backend.PPCgenproof1]
-preg_of_not [in backend.PPCgenproof1]
-preg_of_not_GPR1 [in backend.PPCgenproof1]
-preg_val [in backend.PPCgenproof1]
-program_typing_preserved [in backend.Tunnelingtyping]
-program_typing_preserved [in backend.Linearizetyping]
-program_typing_preserved [in backend.Alloctyping]
-program_typing_preserved [in backend.Stackingtyping]
-prog_funct_transf_OK [in backend.Globalenvs]
-propagate_successors_charact1 [in backend.Kildall]
-propagate_successors_charact2 [in backend.Kildall]
-propagate_successors_invariant [in backend.Kildall]
-propagate_successors_P [in backend.Kildall]
-propagate_succ_charact [in backend.Kildall]
-propagate_succ_incr [in backend.Kildall]
-propagate_succ_incr_worklist [in backend.Kildall]
-propagate_succ_list_charact [in backend.Kildall]
-propagate_succ_list_incr [in backend.Kildall]
-propagate_succ_list_incr_worklist [in backend.Kildall]
-propagate_succ_list_records_changes [in backend.Kildall]
-propagate_succ_records_changes [in backend.Kildall]
-

R

-reachable_correct_1 [in backend.Linearizeproof]
-reachable_correct_2 [in backend.Linearizeproof]
-reachable_entrypoint [in backend.Linearizeproof]
-reachable_successors [in backend.Linearizeproof]
-rebuild_l [in backend.Parallelmove]
-refl_ge [in backend.CSE]
-regalloc_acceptable [in backend.Coloringproof]
-regalloc_correct_1 [in backend.Coloringproof]
-regalloc_correct_2 [in backend.Coloringproof]
-regalloc_correct_3 [in backend.Coloringproof]
-regalloc_disj_temporaries [in backend.Allocproof]
-regalloc_norepet_norepet [in backend.Allocproof]
-regalloc_noteq_diff [in backend.Allocproof]
-regalloc_notin_notin [in backend.Allocproof]
-regalloc_not_temporary [in backend.Allocproof]
-regalloc_ok [in backend.Coloringproof]
-regalloc_preserves_types [in backend.Coloringproof]
-register_classification [in backend.Conventions]
-regsalloc_acceptable [in backend.Coloringproof]
-regs_match_approx_increasing [in backend.Constpropproof]
-regs_match_approx_update [in backend.Constpropproof]
-reg_for_spec [in backend.Allocproof]
-reg_fresh_decr [in backend.RTLgenproof1]
-reg_in_map_valid [in backend.RTLgenproof1]
-reg_valid_incr [in backend.RTLgenproof1]
-reg_valnum_correct [in backend.CSEproof]
-remove_all_leaves_sound [in lib.Inclusion]
-repet_correct [in backend.RTLtyping]
-replace_last_id [in backend.Parallelmove]
-repr_aux_canon [in lib.union_find]
-repr_aux_none [in lib.union_find]
-repr_aux_some [in lib.union_find]
-repr_empty [in lib.union_find]
-repr_rec_ext [in lib.union_find]
-repr_repr [in lib.union_find]
-repr_signed [in lib.Integers]
-repr_unsigned [in lib.Integers]
-reserve_instr_incr [in backend.RTLgenproof1]
-reserve_instr_wf [in backend.RTLgen]
-restore_callee_save_correct [in backend.Stackingproof]
-restore_float_callee_save_correct [in backend.Stackingproof]
-restore_float_callee_save_correct_rec [in backend.Stackingproof]
-restore_int_callee_save_correct [in backend.Stackingproof]
-restore_int_callee_save_correct_rec [in backend.Stackingproof]
-return_regs_not_destroyed [in backend.Allocproof]
-return_regs_result [in backend.Allocproof]
-return_reg_ok_incr [in backend.RTLgenproof1]
-rleaf [in lib.Maps]
-rolm_rolm [in lib.Integers]
-rolm_rolm [in backend.Values]
-rolm_zero [in lib.Integers]
-rolm_zero [in backend.Values]
-rol_and [in lib.Integers]
-rol_or [in lib.Integers]
-rol_rol [in lib.Integers]
-rol_zero [in lib.Integers]
-

S

-sameclass_empty [in lib.union_find]
-sameclass_identify_1 [in lib.union_find]
-sameclass_identify_2 [in lib.union_find]
-sameclass_refl [in lib.union_find]
-sameclass_repr [in lib.union_find]
-sameclass_sym [in lib.union_find]
-sameclass_trans [in lib.union_find]
-sameExec_reflexive [in backend.Parallelmove]
-sameExec_transitive [in backend.Parallelmove]
-same_not_diff [in backend.Locations]
-same_typ_correct [in backend.Coloringproof]
-save_callee_save_correct [in backend.Stackingproof]
-save_float_callee_save_correct [in backend.Stackingproof]
-save_float_callee_save_correct_rec [in backend.Stackingproof]
-save_int_callee_save_correct [in backend.Stackingproof]
-save_int_callee_save_correct_rec [in backend.Stackingproof]
-SB_Pmov [in backend.Parallelmove]
-SDone_Pmov [in backend.Allocproof_aux]
-SDone_stepf [in backend.Allocproof_aux]
-sD_nW [in backend.Parallelmove]
-sD_pexec [in backend.Parallelmove]
-setN_agree [in backend.Mem]
-setN_inject [in backend.Mem]
-setN_outside_agree [in backend.Mem]
-setN_outside_inject [in backend.Mem]
-set_cont_agree [in backend.Mem]
-set_cont_inject [in backend.Mem]
-set_cont_inside [in backend.Mem]
-set_cont_outside [in backend.Mem]
-set_cont_outside1 [in backend.Mem]
-set_cont_outside_agree [in backend.Mem]
-set_cont_outside_inject [in backend.Mem]
-set_locals_defined [in backend.Cminorgenproof]
-set_locals_params_defined [in backend.Cminorgenproof]
-set_params_defined [in backend.Cminorgenproof]
-set_slot_index [in backend.Stackingproof]
-set_slot_link_invariant [in backend.Machtyping]
-set_slot_ok [in backend.Stackingproof]
-shift_eval_addressing [in backend.Stackingproof]
-shift_eval_operation [in backend.Stackingproof]
-shl_mul [in backend.Values]
-shl_mul [in lib.Integers]
-shl_mul_two_p [in lib.Integers]
-shl_rolm [in lib.Integers]
-shl_rolm [in backend.Values]
-shl_zero [in lib.Integers]
-shru_div_two_p [in lib.Integers]
-shru_rolm [in backend.Values]
-shru_rolm [in lib.Integers]
-shru_zero [in lib.Integers]
-shrx_carry [in backend.Values]
-shrx_carry [in lib.Integers]
-shr_zero [in lib.Integers]
-signed_range [in lib.Integers]
-signed_repr [in lib.Integers]
-sig_function_translated [in backend.Allocproof]
-sig_transl_function [in backend.Cminorgenproof]
-simpleDest_insert [in backend.Parallelmove]
-simpleDest_movBack [in backend.Parallelmove]
-simpleDest_movFront [in backend.Parallelmove]
-simpleDest_Pop [in backend.Parallelmove]
-simpleDest_pop [in backend.Parallelmove]
-simpleDest_pop2 [in backend.Parallelmove]
-simpleDest_right [in backend.Parallelmove]
-simpleDest_swap [in backend.Parallelmove]
-simpleDest_swap_app [in backend.Parallelmove]
-simpleDest_tmpLast [in backend.Parallelmove]
-size_arguments_bound [in backend.Linearizetyping]
-size_chunk_pos [in backend.Mem]
-size_mem_pos [in backend.Mem]
-size_no_overflow [in backend.Stackingproof]
-size_pos [in backend.Stackingproof]
-slot_eq [in backend.Locations]
-slot_gi [in backend.Stackingproof]
-slot_gso [in backend.Stackingproof]
-slot_gss [in backend.Stackingproof]
-slot_iso [in backend.Stackingproof]
-slot_iss [in backend.Stackingproof]
-slot_is_bounded [in backend.Linearizetyping]
-sort_included [in lib.Inclusion]
-sort_included2 [in lib.Inclusion]
-splitNone [in backend.Parallelmove]
-splitSome [in backend.Parallelmove]
-split_length [in backend.Parallelmove]
-split_move_incl [in backend.Alloctyping_aux]
-sp_val [in backend.PPCgenproof1]
-srcdst_tmp2_stepf [in backend.Alloctyping_aux]
-src_tmp2_res [in backend.Alloctyping_aux]
-starts_with_correct [in backend.Linearizeproof]
-start_state_good [in backend.Kildall]
-start_state_in_entry [in backend.Kildall]
-state_incr_extends [in backend.RTLgenproof1]
-state_incr_refl [in backend.RTLgenproof1]
-state_incr_trans [in backend.RTLgenproof1]
-state_incr_trans2 [in backend.RTLgenproof1]
-state_incr_trans3 [in backend.RTLgenproof1]
-state_incr_trans4 [in backend.RTLgenproof1]
-state_incr_trans5 [in backend.RTLgenproof1]
-state_incr_trans6 [in backend.RTLgenproof1]
-stepf1_dec [in backend.Parallelmove]
-stepf_dec [in backend.Parallelmove]
-stepf_dec0 [in backend.Parallelmove]
-stepf_dec0' [in backend.Parallelmove]
-stepf_pop [in backend.Parallelmove]
-stepf_popLoop [in backend.Parallelmove]
-stepInv_pnilnil [in backend.Allocproof_aux]
-stepp_inv [in backend.Parallelmove]
-stepp_sameExec [in backend.Parallelmove]
-stepp_transitive [in backend.Parallelmove]
-step1 [in backend.RTLtyping]
-step2 [in backend.RTLtyping]
-step3 [in backend.RTLtyping]
-step4 [in backend.RTLtyping]
-step_dec [in backend.Parallelmove]
-step_dec0 [in backend.Parallelmove]
-step_inv [in backend.Parallelmove]
-step_inv_getdst [in backend.Parallelmove]
-step_inv_loop [in backend.Parallelmove]
-step_inv_loop_aux [in backend.Parallelmove]
-step_inv_noOverlap [in backend.Parallelmove]
-step_inv_NoOverlap [in backend.Parallelmove]
-step_inv_noTmp [in backend.Parallelmove]
-step_inv_noTmpLast [in backend.Parallelmove]
-step_inv_path [in backend.Parallelmove]
-step_inv_simpleDest [in backend.Parallelmove]
-step_sameExec [in backend.Parallelmove]
-step_state_good [in backend.Kildall]
-step_stepp [in backend.Parallelmove]
-stmt_stmtlist_ind [in backend.RTLgenproof1]
-STM_Pmov [in backend.Parallelmove]
-storeind_aux_correct [in backend.PPCgenproof1]
-storeind_correct [in backend.PPCgenproof1]
-storev_mapped_inject [in backend.Mem]
-storev_mapped_inject_1 [in backend.Mem]
-storev_16_signed_unsigned [in backend.PPCgenproof]
-storev_8_signed_unsigned [in backend.PPCgenproof]
-store_agree [in backend.Mem]
-store_alloc [in backend.Mem]
-store_contentmap_agree [in backend.Mem]
-store_contentmap_outside_agree [in backend.Mem]
-store_contents_inject [in backend.Mem]
-store_contents_outside_inject [in backend.Mem]
-store_inv [in backend.Mem]
-store_in_bounds [in backend.Mem]
-store_is_in_bounds [in backend.Mem]
-store_mapped_inject [in backend.Mem]
-store_mapped_inject_1 [in backend.Mem]
-store_outside_agree [in backend.Mem]
-store_outside_extends [in backend.Mem]
-store_parameters_correct [in backend.Cminorgenproof]
-store_unmapped_inject [in backend.Mem]
-store_within_extends [in backend.Mem]
-subject_reduction [in backend.Machtyping]
-subject_reduction [in backend.RTLtyping]
-subject_reduction_function [in backend.Machtyping]
-subject_reduction_instr [in backend.Machtyping]
-subject_reduction_instrs [in backend.Machtyping]
-sub_add_l [in backend.Values]
-sub_add_l [in lib.Integers]
-sub_add_opp [in lib.Integers]
-sub_add_opp [in backend.Values]
-sub_add_r [in backend.Values]
-sub_add_r [in lib.Integers]
-sub_idem [in lib.Integers]
-sub_shifted [in lib.Integers]
-sub_zero_l [in lib.Integers]
-sub_zero_r [in backend.Values]
-sub_zero_r [in lib.Integers]
-successors_aux_invariant [in backend.LTL]
-successors_correct [in backend.LTL]
-successors_correct [in backend.RTL]
-swap_cmp [in lib.Integers]
-swap_cmp [in backend.Values]
-swap_cmpu [in backend.Values]
-swap_cmpu [in lib.Integers]
-swap_cmp_mismatch [in backend.Values]
-symbols_add_globals_transf [in backend.Globalenvs]
-symbols_init_transf [in backend.Globalenvs]
-symbols_preserved [in backend.Tunnelingproof]
-symbols_preserved [in backend.Allocproof]
-symbols_preserved [in backend.Cminorgenproof]
-symbols_preserved [in backend.Constpropproof]
-symbols_preserved [in backend.PPCgenproof]
-symbols_preserved [in backend.RTLgenproof]
-symbols_preserved [in backend.Linearizeproof]
-symbols_preserved [in backend.CSEproof]
-symbols_preserved [in backend.Stackingproof]
-

T

-target_regs_not_mutated [in backend.RTLgenproof1]
-target_regs_ok_incr [in backend.RTLgenproof1]
-target_regs_valid [in backend.RTLgenproof1]
-target_reg_not_mutated [in backend.RTLgenproof1]
-target_reg_ok_incr [in backend.RTLgenproof1]
-target_reg_valid [in backend.RTLgenproof1]
-temporaries_not_acceptable [in backend.Conventions]
-teq_correct [in backend.RTLtyping]
-test_inclusion_sound [in lib.Inclusion]
-top_ge [in backend.CSE]
-transfer_correct [in backend.Constpropproof]
-transfer_correct [in backend.CSEproof]
-transform_partial_program_compose [in backend.Main]
-transform_partial_program_function [in backend.AST]
-transform_partial_program_main [in backend.AST]
-transform_program_function [in backend.AST]
-transform_program_partial_total [in backend.Main]
-transform_program_transform_partial_program [in backend.Globalenvs]
-transf_cminor_program2_correct [in backend.Main]
-transf_cminor_program_correct [in backend.Main]
-transf_cminor_program_equiv [in backend.Main]
-transf_code_wf [in backend.CSE]
-transf_code_wf [in backend.Constprop]
-transf_code_wf [in backend.RTL]
-transf_csharpminor_program2_correct [in backend.Main]
-transf_csharpminor_program_correct [in backend.Main]
-transf_csharpminor_program_equiv [in backend.Main]
-transf_entrypoint_correct [in backend.Allocproof]
-transf_entrypoint_wf [in backend.Allocation]
-transf_function_correct [in backend.Linearizeproof]
-transf_function_correct [in backend.PPCgenproof]
-transf_function_correct [in backend.Stackingproof]
-transf_function_correct [in backend.CSEproof]
-transf_funct_correct [in backend.Constpropproof]
-transf_partial_program_compose [in backend.Main]
-transf_program_correct [in backend.Linearizeproof]
-transf_program_correct [in backend.Tunnelingproof]
-transf_program_correct [in backend.Constpropproof]
-transf_program_correct [in backend.PPCgenproof]
-transf_program_correct [in backend.CSEproof]
-transf_program_partial_total [in backend.Main]
-transf_program_transf_partial_program [in backend.Globalenvs]
-translate_cmp [in lib.Integers]
-translate_eq [in lib.Integers]
-translate_lt [in lib.Integers]
-transl_code_label [in backend.PPCgenproof]
-transl_condition_CEcondition_correct [in backend.RTLgenproof]
-transl_condition_CEcond_correct [in backend.RTLgenproof]
-transl_condition_CEfalse_correct [in backend.RTLgenproof]
-transl_condition_CEtrue_correct [in backend.RTLgenproof]
-transl_condition_incr [in backend.RTLgenproof1]
-transl_cond_correct [in backend.PPCgenproof1]
-transl_cond_correct_aux [in backend.PPCgenproof1]
-transl_exprlist_Econs_correct [in backend.Cminorgenproof]
-transl_exprlist_Econs_correct [in backend.RTLgenproof]
-transl_exprlist_Enil_correct [in backend.RTLgenproof]
-transl_exprlist_Enil_correct [in backend.Cminorgenproof]
-transl_exprlist_incr [in backend.RTLgenproof1]
-transl_expr_condition_exprlist_incr [in backend.RTLgenproof1]
-transl_expr_Eaddrof_global_correct [in backend.Cminorgenproof]
-transl_expr_Eaddrof_local_correct [in backend.Cminorgenproof]
-transl_expr_Eassign_correct [in backend.Cminorgenproof]
-transl_expr_Eassign_correct [in backend.RTLgenproof]
-transl_expr_Ecall_correct [in backend.RTLgenproof]
-transl_expr_Ecall_correct [in backend.Cminorgenproof]
-transl_expr_Econdition_correct [in backend.RTLgenproof]
-transl_expr_Econdition_false_correct [in backend.Cminorgenproof]
-transl_expr_Econdition_true_correct [in backend.Cminorgenproof]
-transl_expr_Eletvar_correct [in backend.RTLgenproof]
-transl_expr_Eletvar_correct [in backend.Cminorgenproof]
-transl_expr_Elet_correct [in backend.Cminorgenproof]
-transl_expr_Elet_correct [in backend.RTLgenproof]
-transl_expr_Eload_correct [in backend.RTLgenproof]
-transl_expr_Eload_correct [in backend.Cminorgenproof]
-transl_expr_Eop_correct [in backend.RTLgenproof]
-transl_expr_Eop_correct [in backend.Cminorgenproof]
-transl_expr_Estore_correct [in backend.RTLgenproof]
-transl_expr_Estore_correct [in backend.Cminorgenproof]
-transl_expr_Evar_correct [in backend.Cminorgenproof]
-transl_expr_Evar_correct [in backend.RTLgenproof]
-transl_expr_incr [in backend.RTLgenproof1]
-transl_find_label [in backend.PPCgenproof]
-transl_find_label [in backend.Stackingproof]
-transl_funcall_correct [in backend.Cminorgenproof]
-transl_funcall_correct [in backend.RTLgenproof]
-transl_function_correct [in backend.Allocproof]
-transl_function_correct [in backend.Cminorgenproof]
-transl_function_correctness [in backend.Allocproof]
-transl_function_correctness [in backend.RTLgenproof]
-transl_Icall_correct [in backend.Allocproof]
-transl_Icond_false_correct [in backend.Allocproof]
-transl_Icond_true_correct [in backend.Allocproof]
-transl_Iload_correct [in backend.Allocproof]
-transl_Inop_correct [in backend.Allocproof]
-transl_instr_label [in backend.PPCgenproof]
-transl_Iop_correct [in backend.Allocproof]
-transl_Istore_correct [in backend.Allocproof]
-transl_load_correct [in backend.PPCgenproof1]
-transl_load_store_correct [in backend.PPCgenproof1]
-transl_one_correct [in backend.Allocproof]
-transl_op_correct [in backend.PPCgenproof1]
-transl_program_correct [in backend.RTLgenproof]
-transl_program_correct [in backend.Stackingproof]
-transl_program_correct [in backend.Allocproof]
-transl_program_correct [in backend.Cminorgenproof]
-transl_refl_correct [in backend.Allocproof]
-transl_stmtlist_incr [in backend.RTLgenproof1]
-transl_stmtlist_Scons_continue_correct [in backend.RTLgenproof]
-transl_stmtlist_Scons_stop_correct [in backend.RTLgenproof]
-transl_stmtlist_Scons_1_correct [in backend.Cminorgenproof]
-transl_stmtlist_Scons_2_correct [in backend.Cminorgenproof]
-transl_stmtlist_Snil_correct [in backend.RTLgenproof]
-transl_stmtlist_Snil_correct [in backend.Cminorgenproof]
-transl_stmt_incr [in backend.RTLgenproof1]
-transl_stmt_Sblock_correct [in backend.RTLgenproof]
-transl_stmt_Sblock_correct [in backend.Cminorgenproof]
-transl_stmt_Sexit_correct [in backend.RTLgenproof]
-transl_stmt_Sexit_correct [in backend.Cminorgenproof]
-transl_stmt_Sexpr_correct [in backend.RTLgenproof]
-transl_stmt_Sexpr_correct [in backend.Cminorgenproof]
-transl_stmt_Sifthenelse_correct [in backend.RTLgenproof]
-transl_stmt_Sifthenelse_false_correct [in backend.Cminorgenproof]
-transl_stmt_Sifthenelse_true_correct [in backend.Cminorgenproof]
-transl_stmt_Sloop_exit_correct [in backend.Cminorgenproof]
-transl_stmt_Sloop_loop_correct [in backend.Cminorgenproof]
-transl_stmt_Sloop_loop_correct [in backend.RTLgenproof]
-transl_stmt_Sloop_stop_correct [in backend.RTLgenproof]
-transl_stmt_Sreturn_none_correct [in backend.Cminorgenproof]
-transl_stmt_Sreturn_none_correct [in backend.RTLgenproof]
-transl_stmt_Sreturn_some_correct [in backend.RTLgenproof]
-transl_stmt_Sreturn_some_correct [in backend.Cminorgenproof]
-transl_stmt_stmtlist_incr [in backend.RTLgenproof1]
-transl_store_correct [in backend.PPCgenproof1]
-transl_trans_correct [in backend.Allocproof]
-tunnel_function_correct [in backend.Tunnelingproof]
-two_power_nat_O [in lib.Coqlib]
-two_power_nat_pos [in lib.Coqlib]
-typesize_pos [in backend.Locations]
-type_args_complete [in backend.RTLtyping]
-type_args_correct [in backend.RTLtyping]
-type_args_extends [in backend.RTLtyping]
-type_args_included [in backend.RTLtyping]
-type_args_mapped [in backend.RTLtyping]
-type_args_res_complete [in backend.RTLtyping]
-type_args_res_included [in backend.RTLtyping]
-type_args_res_ros_included [in backend.RTLtyping]
-type_arg_complete [in backend.RTLtyping]
-type_arg_correct [in backend.RTLtyping]
-type_arg_correct_1 [in backend.RTLtyping]
-type_arg_extends [in backend.RTLtyping]
-type_arg_included [in backend.RTLtyping]
-type_arg_mapped [in backend.RTLtyping]
-type_instrs_extends [in backend.RTLtyping]
-type_instrs_included [in backend.RTLtyping]
-type_instr_included [in backend.RTLtyping]
-type_of_chunk_correct [in backend.Op]
-type_of_operation_sound [in backend.Op]
-type_res_complete [in backend.RTLtyping]
-type_res_correct [in backend.RTLtyping]
-type_ros_complete [in backend.RTLtyping]
-type_ros_correct [in backend.RTLtyping]
-type_rtl_function_correct [in backend.RTLtyping]
-type_rtl_function_instrs [in backend.RTLtyping]
-type_rtl_function_norepet [in backend.RTLtyping]
-type_rtl_function_params [in backend.RTLtyping]
-T_type [in backend.Alloctyping_aux]
-

U

-undef_is_bool [in backend.Values]
-unfold_transf_function [in backend.Stackingproof]
-unique_labels_lin_block [in backend.Linearizeproof]
-unique_labels_lin_function [in backend.Linearizeproof]
-unique_labels_lin_rec [in backend.Linearizeproof]
-unroll_positive_rec [in lib.Coqlib]
-unsigned_range [in lib.Integers]
-unsigned_range_2 [in lib.Integers]
-unsigned_repr [in lib.Integers]
-unsplit_move [in backend.Parallelmove]
-update_instr_extends [in backend.RTLgenproof1]
-update_instr_incr [in backend.RTLgenproof1]
-update_instr_wf [in backend.RTLgen]
-update_o [in backend.Mem]
-update_s [in backend.Mem]
-

V

-valid_block_alloc [in backend.Mem]
-valid_block_free [in backend.Mem]
-valid_block_store [in backend.Mem]
-valid_fresh_absurd [in backend.RTLgenproof1]
-valid_fresh_different [in backend.RTLgenproof1]
-valid_new_block [in backend.Mem]
-valid_not_valid_diff [in backend.Mem]
-valid_pointer_inject_no_overflow [in backend.Mem]
-valnum_regs_holds [in backend.CSEproof]
-valnum_reg_holds [in backend.CSEproof]
-valu_agree_list [in backend.CSEproof]
-valu_agree_refl [in backend.CSEproof]
-valu_agree_trans [in backend.CSEproof]
-val_content_inject_cast [in backend.Cminorgenproof]
-val_content_inject_incr [in backend.Mem]
-val_inject_incr [in backend.Mem]
-val_list_inject_incr [in backend.Mem]
-val_match_approx_increasing [in backend.Constpropproof]
-vars_vals_match_extensional [in backend.Cminorgenproof]
-vars_vals_match_holds [in backend.Cminorgenproof]
-vars_vals_match_holds_1 [in backend.Cminorgenproof]
-var_addr_global_correct [in backend.Cminorgenproof]
-var_addr_local_correct [in backend.Cminorgenproof]
-var_get_correct [in backend.Cminorgenproof]
-var_set_correct [in backend.Cminorgenproof]
-

W

-wf_add_load [in backend.CSEproof]
-wf_add_op [in backend.CSEproof]
-wf_add_rhs [in backend.CSEproof]
-wf_analyze [in backend.CSEproof]
-wf_empty [in lib.union_find]
-wf_empty_numbering [in backend.CSEproof]
-wf_equation_increasing [in backend.CSEproof]
-wf_kill_loads [in backend.CSEproof]
-wf_rhs_increasing [in backend.CSEproof]
-wf_transfer [in backend.CSEproof]
-wf_tunneled_code [in backend.Tunneling]
-wf_valnum_reg [in backend.CSEproof]
-wf_valnum_regs [in backend.CSEproof]
-wt_add_call [in backend.Alloctyping]
-wt_add_cond [in backend.Alloctyping]
-wt_add_entry [in backend.Alloctyping]
-wt_add_load [in backend.Alloctyping]
-wt_add_move [in backend.Alloctyping]
-wt_add_moves [in backend.Alloctyping_aux]
-wt_add_op_move [in backend.Alloctyping]
-wt_add_op_others [in backend.Alloctyping]
-wt_add_op_undef [in backend.Alloctyping]
-wt_add_reload [in backend.Alloctyping]
-wt_add_reloads [in backend.Alloctyping]
-wt_add_return [in backend.Alloctyping]
-wt_add_spill [in backend.Alloctyping]
-wt_add_store [in backend.Alloctyping]
-wt_add_undefs [in backend.Alloctyping]
-wt_fold_right [in backend.Stackingtyping]
-wt_get_slot [in backend.Machtyping]
-wt_init_frame [in backend.Machtyping]
-wt_init_regs [in backend.RTLtyping]
-wt_instrs_cons [in backend.Stackingtyping]
-wt_linearize_block [in backend.Linearizetyping]
-wt_linearize_body [in backend.Linearizetyping]
-wt_Msetstack' [in backend.Stackingtyping]
-wt_parallel_move [in backend.Alloctyping]
-wt_parallel_moveX [in backend.Alloctyping_aux]
-wt_parallel_move' [in backend.Alloctyping_aux]
-wt_regset_assign [in backend.RTLtyping]
-wt_regset_list [in backend.RTLtyping]
-wt_regs_for [in backend.Alloctyping]
-wt_regs_for_rec [in backend.Alloctyping]
-wt_reg_for [in backend.Alloctyping]
-wt_restore_callee_save [in backend.Stackingtyping]
-wt_restore_float_callee_save [in backend.Stackingtyping]
-wt_restore_int_callee_save [in backend.Stackingtyping]
-wt_rtl_function [in backend.Alloctyping]
-wt_save_callee_save [in backend.Stackingtyping]
-wt_save_float_callee_save [in backend.Stackingtyping]
-wt_save_int_callee_save [in backend.Stackingtyping]
-wt_setreg [in backend.Machtyping]
-wt_set_slot [in backend.Machtyping]
-wt_transf_entrypoint [in backend.Alloctyping]
-wt_transf_function [in backend.Stackingtyping]
-wt_transf_function [in backend.Alloctyping]
-wt_transf_function [in backend.Linearizetyping]
-wt_transf_instr [in backend.Alloctyping]
-wt_transf_instrs [in backend.Alloctyping]
-wt_transl_instr [in backend.Stackingtyping]
-wt_tunnel_block [in backend.Tunnelingtyping]
-wt_tunnel_function [in backend.Tunnelingtyping]
-

X

-xcombine_lr [in lib.Maps]
-xelements_complete [in lib.Maps]
-xelements_correct [in lib.Maps]
-xelements_hi [in lib.Maps]
-xelements_ho [in lib.Maps]
-xelements_ih [in lib.Maps]
-xelements_ii [in lib.Maps]
-xelements_io [in lib.Maps]
-xelements_keys_norepet [in lib.Maps]
-xelements_oh [in lib.Maps]
-xelements_oi [in lib.Maps]
-xelements_oo [in lib.Maps]
-xgcombine [in lib.Maps]
-xgcombine_l [in lib.Maps]
-xgcombine_r [in lib.Maps]
-xget_left [in lib.Maps]
-xgmap [in lib.Maps]
-xorimm_correct [in backend.PPCgenproof1]
-xor_assoc [in lib.Integers]
-xor_assoc [in backend.Values]
-xor_commut [in backend.Values]
-xor_commut [in lib.Integers]
-xor_one_one [in lib.Integers]
-xor_zero [in lib.Integers]
-xor_zero_one [in lib.Integers]
-

Z

-Zdiv_small [in lib.Coqlib]
-Zdiv_unique [in lib.Coqlib]
-zeq_false [in lib.Coqlib]
-zeq_true [in lib.Coqlib]
-zle_false [in lib.Coqlib]
-zle_true [in lib.Coqlib]
-zlt_false [in lib.Coqlib]
-zlt_true [in lib.Coqlib]
-Zmax_bound_l [in lib.Coqlib]
-Zmax_bound_r [in lib.Coqlib]
-Zmax_spec [in lib.Coqlib]
-Zmin_spec [in lib.Coqlib]
-Zmod_small [in lib.Coqlib]
-Zmod_unique [in lib.Coqlib]
-Z_bin_decomp_range [in lib.Integers]
-Z_bin_decomp_shift_add [in lib.Integers]
-Z_of_bits_excl [in lib.Integers]
-Z_of_bits_exten [in lib.Integers]
-Z_of_bits_of_Z [in lib.Integers]
-Z_of_bits_range [in lib.Integers]
-Z_of_bits_range_2 [in lib.Integers]
-Z_of_bits_shift [in lib.Integers]
-Z_of_bits_shifts [in lib.Integers]
-Z_of_bits_shifts_rev [in lib.Integers]
-Z_of_bits_shift_rev [in lib.Integers]
-Z_one_bits_powerserie [in lib.Integers]
-Z_one_bits_range [in lib.Integers]
-Z_shift_add_bin_decomp [in lib.Integers]
-Z_shift_add_inj [in lib.Integers]
-

-

Constructor Index

-

A

-Abased [in backend.Op]
-addf_case1 [in backend.Cmconstr]
-addf_case2 [in backend.Cmconstr]
-addf_default [in backend.Cmconstr]
-addimm_case1 [in backend.Cmconstr]
-addimm_case2 [in backend.Cmconstr]
-addimm_case3 [in backend.Cmconstr]
-addimm_case4 [in backend.Cmconstr]
-addimm_default [in backend.Cmconstr]
-addressing_case1 [in backend.Cmconstr]
-addressing_case2 [in backend.Cmconstr]
-addressing_case3 [in backend.Cmconstr]
-addressing_case4 [in backend.Cmconstr]
-addressing_case5 [in backend.Cmconstr]
-addressing_default [in backend.Cmconstr]
-addr_strength_reduction_case1 [in backend.Constprop]
-addr_strength_reduction_case2 [in backend.Constprop]
-addr_strength_reduction_case3 [in backend.Constprop]
-addr_strength_reduction_default [in backend.Constprop]
-add_case1 [in backend.Cmconstr]
-add_case2 [in backend.Cmconstr]
-add_case3 [in backend.Cmconstr]
-add_case4 [in backend.Cmconstr]
-add_case5 [in backend.Cmconstr]
-add_default [in backend.Cmconstr]
-Aglobal [in backend.Op]
-Aindexed [in backend.Op]
-Aindexed2 [in backend.Op]
-Ainstack [in backend.Op]
-alloc_variables_cons [in backend.Csharpminor]
-alloc_variables_nil [in backend.Csharpminor]
-

B

-Bcall [in backend.LTL]
-Bcond [in backend.LTL]
-Bgetstack [in backend.LTL]
-Bgoto [in backend.LTL]
-bind_parameters_cons [in backend.Csharpminor]
-bind_parameters_nil [in backend.Csharpminor]
-Bload [in backend.LTL]
-bool_of_val_int_true [in backend.Values]
-Bop [in backend.LTL]
-Bot [in lib.Lattice]
-Bot_except [in lib.Lattice]
-Breturn [in backend.LTL]
-Bsetstack [in backend.LTL]
-Bstore [in backend.LTL]
-

C

-callstack_dom_cons [in backend.Machabstr2mach]
-callstack_dom_nil [in backend.Machabstr2mach]
-callstack_linked_cons [in backend.Machabstr2mach]
-callstack_linked_nil [in backend.Machabstr2mach]
-callstack_linked_one [in backend.Machabstr2mach]
-CARRY [in backend.PPC]
-Ccomp [in backend.Op]
-Ccompf [in backend.Op]
-Ccompimm [in backend.Op]
-Ccompu [in backend.Op]
-Ccompuimm [in backend.Op]
-CEcond [in backend.Cminor]
-CEcondition [in backend.Cminor]
-CEfalse [in backend.Cminor]
-Ceq [in backend.AST]
-CEtrue [in backend.Cminor]
-Cge [in backend.AST]
-Cgt [in backend.AST]
-Cint [in backend.PPC]
-Cle [in backend.AST]
-Clt [in backend.AST]
-Cmasknotzero [in backend.Op]
-Cmaskzero [in backend.Op]
-Cne [in backend.AST]
-Cnotcompf [in backend.Op]
-Cont [in backend.LTL]
-Cont [in backend.Mem]
-content_inject_cont [in backend.Mem]
-content_inject_datum16 [in backend.Mem]
-content_inject_datum32 [in backend.Mem]
-content_inject_datum64 [in backend.Mem]
-content_inject_datum8 [in backend.Mem]
-content_inject_undef [in backend.Mem]
-CRbit_0 [in backend.PPC]
-CRbit_1 [in backend.PPC]
-CRbit_2 [in backend.PPC]
-CRbit_3 [in backend.PPC]
-CR0_0 [in backend.PPC]
-CR0_1 [in backend.PPC]
-CR0_2 [in backend.PPC]
-CR0_3 [in backend.PPC]
-csr_case1 [in backend.Constprop]
-csr_case2 [in backend.Constprop]
-csr_default [in backend.Constprop]
-Csymbol_high_signed [in backend.PPC]
-Csymbol_high_unsigned [in backend.PPC]
-Csymbol_low_signed [in backend.PPC]
-Csymbol_low_unsigned [in backend.PPC]
-CTR [in backend.PPC]
-

D

-Datum16 [in backend.Mem]
-Datum32 [in backend.Mem]
-Datum64 [in backend.Mem]
-Datum8 [in backend.Mem]
-divu_case1 [in backend.Cmconstr]
-divu_default [in backend.Cmconstr]
-dstepp_refl [in backend.Parallelmove]
-dstepp_trans [in backend.Parallelmove]
-dstep_nop [in backend.Parallelmove]
-dstep_pop [in backend.Parallelmove]
-dstep_pop_loop [in backend.Parallelmove]
-dstep_push [in backend.Parallelmove]
-dstep_start [in backend.Parallelmove]
-

E

-Eaddrof [in backend.Csharpminor]
-Eassign [in backend.Cminor]
-Eassign [in backend.Csharpminor]
-Ecall [in backend.Csharpminor]
-Ecall [in backend.Cminor]
-Econdition [in backend.Csharpminor]
-Econdition [in backend.Cminor]
-Econs [in backend.Cminor]
-Econs [in backend.Csharpminor]
-Elet [in backend.Csharpminor]
-Elet [in backend.Cminor]
-Eletvar [in backend.Cminor]
-Eletvar [in backend.Csharpminor]
-Eload [in backend.Cminor]
-Eload [in backend.Csharpminor]
-Enil [in backend.Csharpminor]
-Enil [in backend.Cminor]
-Eop [in backend.Csharpminor]
-Eop [in backend.Cminor]
-Error [in backend.RTLgen]
-Error [in backend.PPC]
-Estore [in backend.Cminor]
-Estore [in backend.Csharpminor]
-eval_Evar [in backend.Csharpminor]
-eval_Evar [in backend.Cminor]
-eval_static_condition_case1 [in backend.Constprop]
-eval_static_condition_case2 [in backend.Constprop]
-eval_static_condition_case3 [in backend.Constprop]
-eval_static_condition_case4 [in backend.Constprop]
-eval_static_condition_case5 [in backend.Constprop]
-eval_static_condition_case6 [in backend.Constprop]
-eval_static_condition_case7 [in backend.Constprop]
-eval_static_condition_case8 [in backend.Constprop]
-eval_static_condition_default [in backend.Constprop]
-eval_static_operation_case1 [in backend.Constprop]
-eval_static_operation_case11 [in backend.Constprop]
-eval_static_operation_case12 [in backend.Constprop]
-eval_static_operation_case13 [in backend.Constprop]
-eval_static_operation_case14 [in backend.Constprop]
-eval_static_operation_case15 [in backend.Constprop]
-eval_static_operation_case16 [in backend.Constprop]
-eval_static_operation_case17 [in backend.Constprop]
-eval_static_operation_case18 [in backend.Constprop]
-eval_static_operation_case19 [in backend.Constprop]
-eval_static_operation_case2 [in backend.Constprop]
-eval_static_operation_case20 [in backend.Constprop]
-eval_static_operation_case21 [in backend.Constprop]
-eval_static_operation_case22 [in backend.Constprop]
-eval_static_operation_case23 [in backend.Constprop]
-eval_static_operation_case24 [in backend.Constprop]
-eval_static_operation_case25 [in backend.Constprop]
-eval_static_operation_case26 [in backend.Constprop]
-eval_static_operation_case27 [in backend.Constprop]
-eval_static_operation_case28 [in backend.Constprop]
-eval_static_operation_case29 [in backend.Constprop]
-eval_static_operation_case3 [in backend.Constprop]
-eval_static_operation_case30 [in backend.Constprop]
-eval_static_operation_case31 [in backend.Constprop]
-eval_static_operation_case32 [in backend.Constprop]
-eval_static_operation_case33 [in backend.Constprop]
-eval_static_operation_case34 [in backend.Constprop]
-eval_static_operation_case35 [in backend.Constprop]
-eval_static_operation_case36 [in backend.Constprop]
-eval_static_operation_case37 [in backend.Constprop]
-eval_static_operation_case38 [in backend.Constprop]
-eval_static_operation_case39 [in backend.Constprop]
-eval_static_operation_case4 [in backend.Constprop]
-eval_static_operation_case40 [in backend.Constprop]
-eval_static_operation_case41 [in backend.Constprop]
-eval_static_operation_case42 [in backend.Constprop]
-eval_static_operation_case43 [in backend.Constprop]
-eval_static_operation_case44 [in backend.Constprop]
-eval_static_operation_case45 [in backend.Constprop]
-eval_static_operation_case46 [in backend.Constprop]
-eval_static_operation_case47 [in backend.Constprop]
-eval_static_operation_case6 [in backend.Constprop]
-eval_static_operation_case7 [in backend.Constprop]
-eval_static_operation_case8 [in backend.Constprop]
-eval_static_operation_case9 [in backend.Constprop]
-eval_static_operation_default [in backend.Constprop]
-Evar [in backend.Cminor]
-Evar [in backend.Csharpminor]
-exec_Bgetstack [in backend.LTL]
-exec_Iload [in backend.RTL]
-exec_Inop [in backend.RTL]
-exec_Iop [in backend.RTL]
-exec_Lgetstack [in backend.Linear]
-exec_Mgetparam [in backend.Mach]
-exec_Mgetstack [in backend.Mach]
-exec_Mgetstack [in backend.Machabstr]
-exec_Mlabel [in backend.Mach]
-exec_Mlabel [in backend.Machabstr]
-exec_Msetstack [in backend.Mach]
-exec_one [in backend.PPC]
-exec_refl [in backend.PPC]
-exec_step_intro [in backend.PPC]
-exec_straight_refl [in backend.PPCgenproof1]
-exec_straight_step [in backend.PPCgenproof1]
-exec_trans [in backend.PPC]
-

F

-FI_arg [in backend.Stacking]
-FI_local [in backend.Stacking]
-FI_saved_float [in backend.Stacking]
-FI_saved_int [in backend.Stacking]
-FPR0 [in backend.PPC]
-FPR1 [in backend.PPC]
-FPR10 [in backend.PPC]
-FPR11 [in backend.PPC]
-FPR12 [in backend.PPC]
-FPR13 [in backend.PPC]
-FPR14 [in backend.PPC]
-FPR15 [in backend.PPC]
-FPR16 [in backend.PPC]
-FPR17 [in backend.PPC]
-FPR18 [in backend.PPC]
-FPR19 [in backend.PPC]
-FPR2 [in backend.PPC]
-FPR20 [in backend.PPC]
-FPR21 [in backend.PPC]
-FPR22 [in backend.PPC]
-FPR23 [in backend.PPC]
-FPR24 [in backend.PPC]
-FPR25 [in backend.PPC]
-FPR26 [in backend.PPC]
-FPR27 [in backend.PPC]
-FPR28 [in backend.PPC]
-FPR29 [in backend.PPC]
-FPR3 [in backend.PPC]
-FPR30 [in backend.PPC]
-FPR31 [in backend.PPC]
-FPR4 [in backend.PPC]
-FPR5 [in backend.PPC]
-FPR6 [in backend.PPC]
-FPR7 [in backend.PPC]
-FPR8 [in backend.PPC]
-FPR9 [in backend.PPC]
-FR [in backend.PPC]
-frame_match_intro [in backend.Machabstr2mach]
-FT1 [in backend.Locations]
-FT2 [in backend.Locations]
-FT3 [in backend.Locations]
-F1 [in backend.Locations]
-F10 [in backend.Locations]
-F14 [in backend.Locations]
-F15 [in backend.Locations]
-F16 [in backend.Locations]
-F17 [in backend.Locations]
-F18 [in backend.Locations]
-F19 [in backend.Locations]
-F2 [in backend.Locations]
-F20 [in backend.Locations]
-F21 [in backend.Locations]
-F22 [in backend.Locations]
-F23 [in backend.Locations]
-F24 [in backend.Locations]
-F25 [in backend.Locations]
-F26 [in backend.Locations]
-F27 [in backend.Locations]
-F28 [in backend.Locations]
-F29 [in backend.Locations]
-F3 [in backend.Locations]
-F30 [in backend.Locations]
-F31 [in backend.Locations]
-F4 [in backend.Locations]
-F5 [in backend.Locations]
-F6 [in backend.Locations]
-F7 [in backend.Locations]
-F8 [in backend.Locations]
-F9 [in backend.Locations]
-

G

-get_slot_intro [in backend.Machabstr]
-GPR0 [in backend.PPC]
-GPR1 [in backend.PPC]
-GPR10 [in backend.PPC]
-GPR11 [in backend.PPC]
-GPR12 [in backend.PPC]
-GPR13 [in backend.PPC]
-GPR14 [in backend.PPC]
-GPR15 [in backend.PPC]
-GPR16 [in backend.PPC]
-GPR17 [in backend.PPC]
-GPR18 [in backend.PPC]
-GPR19 [in backend.PPC]
-GPR2 [in backend.PPC]
-GPR20 [in backend.PPC]
-GPR21 [in backend.PPC]
-GPR22 [in backend.PPC]
-GPR23 [in backend.PPC]
-GPR24 [in backend.PPC]
-GPR25 [in backend.PPC]
-GPR26 [in backend.PPC]
-GPR27 [in backend.PPC]
-GPR28 [in backend.PPC]
-GPR29 [in backend.PPC]
-GPR3 [in backend.PPC]
-GPR30 [in backend.PPC]
-GPR31 [in backend.PPC]
-GPR4 [in backend.PPC]
-GPR5 [in backend.PPC]
-GPR6 [in backend.PPC]
-GPR7 [in backend.PPC]
-GPR8 [in backend.PPC]
-GPR9 [in backend.PPC]
-

I

-Incoming [in backend.Locations]
-Inj [in lib.Lattice]
-Inop [in backend.RTL]
-insert_lenv_S [in backend.Cmconstrproof]
-insert_lenv_0 [in backend.Cmconstrproof]
-IR [in backend.PPC]
-is_tail_cons [in backend.Linearizeproof]
-is_tail_refl [in backend.Linearizeproof]
-IT1 [in backend.Locations]
-IT2 [in backend.Locations]
-IT3 [in backend.Locations]
-

L

-Lcall [in backend.Linear]
-Lcond [in backend.Linear]
-Leaf [in lib.Maps]
-leaf [in lib.Inclusion]
-Lgetstack [in backend.Linear]
-Lgoto [in backend.Linear]
-list_forall2_cons [in lib.Coqlib]
-list_forall2_nil [in lib.Coqlib]
-list_norepet_cons [in lib.Coqlib]
-list_norepet_nil [in lib.Coqlib]
-Llabel [in backend.Linear]
-Lload [in backend.Linear]
-Load [in backend.CSE]
-Local [in backend.Locations]
-Lop [in backend.Linear]
-LR [in backend.PPC]
-Lreturn [in backend.Linear]
-Lsetstack [in backend.Linear]
-Lstore [in backend.Linear]
-LVarray [in backend.Csharpminor]
-LVscalar [in backend.Csharpminor]
-

M

-Mcall [in backend.Mach]
-Mcond [in backend.Mach]
-mcs_cons [in backend.Cminorgenproof]
-mcs_nil [in backend.Cminorgenproof]
-Mfloat32 [in backend.AST]
-Mfloat64 [in backend.AST]
-Mgetparam [in backend.Mach]
-Mgetstack [in backend.Mach]
-Mgoto [in backend.Mach]
-Mint16signed [in backend.AST]
-Mint16unsigned [in backend.AST]
-Mint32 [in backend.AST]
-Mint8signed [in backend.AST]
-Mint8unsigned [in backend.AST]
-Mlabel [in backend.Mach]
-Mload [in backend.Mach]
-Mop [in backend.Mach]
-Mreturn [in backend.Mach]
-Msetstack [in backend.Mach]
-Mstore [in backend.Mach]
-mulimm_case1 [in backend.Cmconstr]
-mulimm_case2 [in backend.Cmconstr]
-mulimm_default [in backend.Cmconstr]
-mul_case1 [in backend.Cmconstr]
-mul_case2 [in backend.Cmconstr]
-mul_default [in backend.Cmconstr]
-

N

-n [in backend.Op]
-Node [in lib.Maps]
-node [in lib.Inclusion]
-norepet_cons [in backend.Locations]
-norepet_nil [in backend.Locations]
-notint_case1 [in backend.Cmconstr]
-notint_case2 [in backend.Cmconstr]
-notint_case3 [in backend.Cmconstr]
-notint_default [in backend.Cmconstr]
-notin_callstack_cons [in backend.Machabstr2mach]
-notin_callstack_nil [in backend.Machabstr2mach]
-Novalue [in backend.Constprop]
-

O

-Oabsf [in backend.Op]
-Oabsf [in backend.Csharpminor]
-Oadd [in backend.Csharpminor]
-Oadd [in backend.Op]
-Oaddf [in backend.Csharpminor]
-Oaddf [in backend.Op]
-Oaddimm [in backend.Op]
-Oaddrstack [in backend.Op]
-Oaddrsymbol [in backend.Op]
-Oand [in backend.Op]
-Oand [in backend.Csharpminor]
-Oandimm [in backend.Op]
-Ocast16signed [in backend.Csharpminor]
-Ocast16signed [in backend.Op]
-Ocast16unsigned [in backend.Csharpminor]
-Ocast8signed [in backend.Csharpminor]
-Ocast8signed [in backend.Op]
-Ocast8unsigned [in backend.Csharpminor]
-Ocmp [in backend.Op]
-Ocmp [in backend.Csharpminor]
-Ocmpf [in backend.Csharpminor]
-Ocmpu [in backend.Csharpminor]
-Odiv [in backend.Op]
-Odiv [in backend.Csharpminor]
-Odivf [in backend.Op]
-Odivf [in backend.Csharpminor]
-Odivu [in backend.Csharpminor]
-Odivu [in backend.Op]
-Ofloatconst [in backend.Op]
-Ofloatconst [in backend.Csharpminor]
-Ofloatofint [in backend.Op]
-Ofloatofint [in backend.Csharpminor]
-Ofloatofintu [in backend.Csharpminor]
-Ofloatofintu [in backend.Op]
-Ointconst [in backend.Csharpminor]
-Ointconst [in backend.Op]
-Ointoffloat [in backend.Csharpminor]
-Ointoffloat [in backend.Op]
-OK [in backend.RTLgen]
-OK [in backend.PPC]
-Omod [in backend.Csharpminor]
-Omodu [in backend.Csharpminor]
-Omove [in backend.Op]
-Omul [in backend.Csharpminor]
-Omul [in backend.Op]
-Omuladdf [in backend.Op]
-Omulf [in backend.Op]
-Omulf [in backend.Csharpminor]
-Omulimm [in backend.Op]
-Omulsubf [in backend.Op]
-Onand [in backend.Op]
-Onegf [in backend.Csharpminor]
-Onegf [in backend.Op]
-Onor [in backend.Op]
-Onotint [in backend.Csharpminor]
-Onxor [in backend.Op]
-Oor [in backend.Op]
-Oor [in backend.Csharpminor]
-Oorimm [in backend.Op]
-Op [in backend.CSE]
-op_strength_reduction_case1 [in backend.Constprop]
-op_strength_reduction_case10 [in backend.Constprop]
-op_strength_reduction_case11 [in backend.Constprop]
-op_strength_reduction_case12 [in backend.Constprop]
-op_strength_reduction_case2 [in backend.Constprop]
-op_strength_reduction_case3 [in backend.Constprop]
-op_strength_reduction_case4 [in backend.Constprop]
-op_strength_reduction_case5 [in backend.Constprop]
-op_strength_reduction_case6 [in backend.Constprop]
-op_strength_reduction_case7 [in backend.Constprop]
-op_strength_reduction_case8 [in backend.Constprop]
-op_strength_reduction_case9 [in backend.Constprop]
-op_strength_reduction_default [in backend.Constprop]
-Orolm [in backend.Op]
-or_case1 [in backend.Cmconstr]
-or_default [in backend.Cmconstr]
-Oshl [in backend.Csharpminor]
-Oshl [in backend.Op]
-Oshr [in backend.Op]
-Oshr [in backend.Csharpminor]
-Oshrimm [in backend.Op]
-Oshru [in backend.Op]
-Oshru [in backend.Csharpminor]
-Oshrximm [in backend.Op]
-Osingleoffloat [in backend.Op]
-Osingleoffloat [in backend.Csharpminor]
-Osub [in backend.Csharpminor]
-Osub [in backend.Op]
-Osubf [in backend.Csharpminor]
-Osubf [in backend.Op]
-Osubimm [in backend.Op]
-Oundef [in backend.Op]
-Outgoing [in backend.Locations]
-Out_exit [in backend.Csharpminor]
-Out_exit [in backend.Cminor]
-Out_normal [in backend.Cminor]
-Out_normal [in backend.Csharpminor]
-Out_return [in backend.Cminor]
-Out_return [in backend.Csharpminor]
-Oxor [in backend.Op]
-Oxor [in backend.Csharpminor]
-Oxorimm [in backend.Op]
-

P

-Padd [in backend.PPC]
-Paddi [in backend.PPC]
-Paddis [in backend.PPC]
-Paddze [in backend.PPC]
-Pallocframe [in backend.PPC]
-Pandc [in backend.PPC]
-Pandis_ [in backend.PPC]
-Pandi_ [in backend.PPC]
-Pand_ [in backend.PPC]
-Pb [in backend.PPC]
-Pbctr [in backend.PPC]
-Pbctrl [in backend.PPC]
-Pbf [in backend.PPC]
-Pbl [in backend.PPC]
-Pblr [in backend.PPC]
-Pbt [in backend.PPC]
-PC [in backend.PPC]
-Pcmplw [in backend.PPC]
-Pcmplwi [in backend.PPC]
-Pcmpw [in backend.PPC]
-Pcmpwi [in backend.PPC]
-Pcror [in backend.PPC]
-Pdivw [in backend.PPC]
-Pdivwu [in backend.PPC]
-Peqv [in backend.PPC]
-Pextsb [in backend.PPC]
-Pextsh [in backend.PPC]
-Pfabs [in backend.PPC]
-Pfadd [in backend.PPC]
-Pfcmpu [in backend.PPC]
-Pfcti [in backend.PPC]
-Pfdiv [in backend.PPC]
-Pfmadd [in backend.PPC]
-Pfmr [in backend.PPC]
-Pfmsub [in backend.PPC]
-Pfmul [in backend.PPC]
-Pfneg [in backend.PPC]
-Pfreeframe [in backend.PPC]
-Pfrsp [in backend.PPC]
-Pfsub [in backend.PPC]
-Pfundef [in backend.PPC]
-Pictf [in backend.PPC]
-Piuctf [in backend.PPC]
-Piundef [in backend.PPC]
-Plabel [in backend.PPC]
-Plbz [in backend.PPC]
-Plbzx [in backend.PPC]
-Plfd [in backend.PPC]
-Plfdx [in backend.PPC]
-Plfi [in backend.PPC]
-Plfs [in backend.PPC]
-Plfsx [in backend.PPC]
-Plha [in backend.PPC]
-Plhax [in backend.PPC]
-Plhz [in backend.PPC]
-Plhzx [in backend.PPC]
-Plwz [in backend.PPC]
-Plwzx [in backend.PPC]
-Pmfcrbit [in backend.PPC]
-Pmflr [in backend.PPC]
-Pmr [in backend.PPC]
-Pmtctr [in backend.PPC]
-Pmtlr [in backend.PPC]
-Pmulli [in backend.PPC]
-Pmullw [in backend.PPC]
-Pnand [in backend.PPC]
-Pnor [in backend.PPC]
-Por [in backend.PPC]
-Porc [in backend.PPC]
-Pori [in backend.PPC]
-Poris [in backend.PPC]
-Prlwinm [in backend.PPC]
-Pslw [in backend.PPC]
-Psraw [in backend.PPC]
-Psrawi [in backend.PPC]
-Psrw [in backend.PPC]
-Pstb [in backend.PPC]
-Pstbx [in backend.PPC]
-Pstfd [in backend.PPC]
-Pstfdx [in backend.PPC]
-Pstfs [in backend.PPC]
-Pstfsx [in backend.PPC]
-Psth [in backend.PPC]
-Psthx [in backend.PPC]
-Pstw [in backend.PPC]
-Pstwx [in backend.PPC]
-Psubfc [in backend.PPC]
-Psubfic [in backend.PPC]
-Pxor [in backend.PPC]
-Pxori [in backend.PPC]
-Pxoris [in backend.PPC]
-

R

-R [in backend.Locations]
-Return [in backend.LTL]
-return_reg_ok_none [in backend.RTLgenproof1]
-return_reg_ok_some [in backend.RTLgenproof1]
-RLW_Sbad [in lib.Integers]
-RLW_S0 [in lib.Integers]
-RLW_S1 [in lib.Integers]
-RLW_S2 [in lib.Integers]
-RLW_S3 [in lib.Integers]
-RLW_S4 [in lib.Integers]
-RLW_S5 [in lib.Integers]
-RLW_S6 [in lib.Integers]
-rolm_case1 [in backend.Cmconstr]
-rolm_case2 [in backend.Cmconstr]
-rolm_default [in backend.Cmconstr]
-R10 [in backend.Locations]
-R13 [in backend.Locations]
-R14 [in backend.Locations]
-R15 [in backend.Locations]
-R16 [in backend.Locations]
-R17 [in backend.Locations]
-R18 [in backend.Locations]
-R19 [in backend.Locations]
-r2 [in backend.Op]
-r2 [in backend.Op]
-R20 [in backend.Locations]
-R21 [in backend.Locations]
-R22 [in backend.Locations]
-R23 [in backend.Locations]
-R24 [in backend.Locations]
-R25 [in backend.Locations]
-R26 [in backend.Locations]
-R27 [in backend.Locations]
-R28 [in backend.Locations]
-R29 [in backend.Locations]
-R3 [in backend.Locations]
-R30 [in backend.Locations]
-R31 [in backend.Locations]
-R4 [in backend.Locations]
-R5 [in backend.Locations]
-R6 [in backend.Locations]
-R7 [in backend.Locations]
-R8 [in backend.Locations]
-R9 [in backend.Locations]
-

S

-S [in backend.Locations]
-Sblock [in backend.Cminor]
-Sblock [in backend.Csharpminor]
-Scons [in backend.Cminor]
-Scons [in backend.Csharpminor]
-set_slot_intro [in backend.Machabstr]
-Sexit [in backend.Cminor]
-Sexit [in backend.Csharpminor]
-Sexpr [in backend.Cminor]
-Sexpr [in backend.Csharpminor]
-shift_case1 [in backend.Cmconstr]
-shift_default [in backend.Cmconstr]
-Sifthenelse [in backend.Csharpminor]
-Sifthenelse [in backend.Cminor]
-Size16 [in backend.Mem]
-Size32 [in backend.Mem]
-Size64 [in backend.Mem]
-Size8 [in backend.Mem]
-Sloop [in backend.Csharpminor]
-Sloop [in backend.Cminor]
-Snil [in backend.Csharpminor]
-Snil [in backend.Cminor]
-Sreturn [in backend.Csharpminor]
-Sreturn [in backend.Cminor]
-state_incr_intro [in backend.RTLgenproof1]
-stepp_refl [in backend.Parallelmove]
-stepp_trans [in backend.Parallelmove]
-step_loop [in backend.Parallelmove]
-step_nop [in backend.Parallelmove]
-step_pop [in backend.Parallelmove]
-step_push [in backend.Parallelmove]
-step_start [in backend.Parallelmove]
-subf_case1 [in backend.Cmconstr]
-subf_default [in backend.Cmconstr]
-sub_case1 [in backend.Cmconstr]
-sub_case2 [in backend.Cmconstr]
-sub_case3 [in backend.Cmconstr]
-sub_case4 [in backend.Cmconstr]
-sub_default [in backend.Cmconstr]
-

T

-target_regs_cons [in backend.RTLgenproof1]
-target_regs_nil [in backend.RTLgenproof1]
-target_reg_immut_var [in backend.RTLgenproof1]
-Tfloat [in backend.AST]
-Tint [in backend.AST]
-tReg [in backend.RTLtyping]
-tTy [in backend.RTLtyping]
-

U

-Undef [in backend.Mem]
-

V

-val_cons_inject [in backend.Mem]
-val_content_inject_base [in backend.Mem]
-val_content_inject_8 [in backend.Mem]
-val_inject_float [in backend.Mem]
-val_inject_int [in backend.Mem]
-val_inject_ptr [in backend.Mem]
-val_nil_inject [in backend.Mem]
-vars_vals_cons [in backend.Cminorgenproof]
-vars_vals_nil [in backend.Cminorgenproof]
-Var_global [in backend.Cminorgen]
-Var_local [in backend.Cminorgen]
-Var_stack_array [in backend.Cminorgen]
-Var_stack_scalar [in backend.Cminorgen]
-Vfloat [in backend.Values]
-Vint [in backend.Values]
-vlma_cons [in backend.Constpropproof]
-vlma_nil [in backend.Constpropproof]
-Vptr [in backend.Values]
-Vundef [in backend.Values]
-

W

-wt_Bgetstack [in backend.LTLtyping]
-wt_Bop [in backend.LTLtyping]
-wt_Bopmove [in backend.LTLtyping]
-wt_Bopundef [in backend.LTLtyping]
-wt_Bsetstack [in backend.LTLtyping]
-wt_Inop [in backend.RTLtyping]
-wt_Iop [in backend.RTLtyping]
-wt_Iopmove [in backend.RTLtyping]
-wt_Iopundef [in backend.RTLtyping]
-wt_Lgetstack [in backend.Lineartyping]
-wt_Lop [in backend.Lineartyping]
-wt_Lopmove [in backend.Lineartyping]
-wt_Lopundef [in backend.Lineartyping]
-wt_Lsetstack [in backend.Lineartyping]
-wt_Mgetstack [in backend.Machtyping]
-wt_Mlabel [in backend.Machtyping]
-wt_Msetstack [in backend.Machtyping]
-

_

-_ [in backend.Lineartyping]
-_ [in backend.LTLtyping]
-

-

Inductive Index

-

A

-a [in backend.Op]
-a [in backend.Op]
-addf_cases [in backend.Cmconstr]
-addimm_cases [in backend.Cmconstr]
-addressing [in backend.Op]
-addressing_cases [in backend.Cmconstr]
-addr_strength_reduction_cases [in backend.Constprop]
-add_cases [in backend.Cmconstr]
-agree [in backend.Stackingproof]
-alloc_variables [in backend.Csharpminor]
-approx [in backend.Constprop]
-

B

-bin [in lib.Inclusion]
-bind_parameters [in backend.Csharpminor]
-block [in backend.LTL]
-block_contents [in backend.Mem]
-block_contents_inject [in backend.Mem]
-bool_of_val [in backend.Values]
-bounds [in backend.Lineartyping]
-

C

-callstack_dom [in backend.Machabstr2mach]
-callstack_invariant [in backend.Machabstr2mach]
-callstack_linked [in backend.Machabstr2mach]
-comparison [in backend.AST]
-condexpr [in backend.Cminor]
-condition [in backend.Op]
-cond_strength_reduction_cases [in backend.Constprop]
-constant [in backend.PPC]
-content [in backend.Mem]
-content_inject [in backend.Mem]
-cont_for_outcome [in backend.Linearizeproof]
-crbit [in backend.PPC]
-

D

-divu_cases [in backend.Cmconstr]
-dstep [in backend.Parallelmove]
-dstepp [in backend.Parallelmove]
-

E

-eval_expr [in backend.Csharpminor]
-eval_expr [in backend.Cminor]
-eval_static_condition_cases [in backend.Constprop]
-eval_static_operation_cases [in backend.Constprop]
-exec_instr [in backend.Machabstr]
-exec_instr [in backend.RTL]
-exec_instr [in backend.LTL]
-exec_instr [in backend.Linear]
-exec_instr [in backend.Mach]
-exec_step [in backend.PPC]
-exec_steps [in backend.PPC]
-exec_straight [in backend.PPCgenproof1]
-expr [in backend.Csharpminor]
-expr [in backend.Cminor]
-exprlist [in backend.Csharpminor]
-exprlist [in backend.Cminor]
-

F

-frame [in backend.Cminorgenproof]
-frame_env [in backend.Stacking]
-frame_index [in backend.Stacking]
-frame_match [in backend.Machabstr2mach]
-freg [in backend.PPC]
-function [in backend.Mach]
-function [in backend.Csharpminor]
-function [in backend.RTL]
-function [in backend.LTL]
-function [in backend.Cminor]
-function [in backend.Linear]
-

G

-genv [in backend.Globalenvs]
-get_slot [in backend.Machabstr]
-graph [in backend.InterfGraph]
-

I

-immediate [in backend.PPC]
-immediate [in backend.PPC]
-immediate [in backend.PPC]
-immediate [in backend.PPC]
-immediate [in backend.PPC]
-immediate [in backend.PPC]
-Incoming [in backend.LTLtyping]
-Incoming [in backend.Lineartyping]
-insert_lenv [in backend.Cmconstrproof]
-instruction [in backend.Linear]
-instruction [in backend.PPC]
-instruction [in backend.RTL]
-instruction [in backend.Mach]
-int [in lib.Integers]
-ireg [in backend.PPC]
-is_tail [in backend.Linearizeproof]
-

L

-list_forall2 [in lib.Coqlib]
-list_norepet [in lib.Coqlib]
-loc [in backend.Locations]
-local_variable [in backend.Csharpminor]
-

M

-mapping [in backend.RTLgen]
-map_wf [in backend.RTLgenproof1]
-match_callstack [in backend.Cminorgenproof]
-match_env [in backend.Cminorgenproof]
-match_env [in backend.RTLgenproof1]
-match_globalenvs [in backend.Cminorgenproof]
-match_var [in backend.Cminorgenproof]
-mem [in backend.Mem]
-memory_chunk [in backend.AST]
-memory_size [in backend.Mem]
-mem_inject [in backend.Mem]
-mreg [in backend.Locations]
-mulimm_cases [in backend.Cmconstr]
-mul_cases [in backend.Cmconstr]
-myT [in backend.RTLtyping]
-

N

-norepet [in backend.Locations]
-notint_cases [in backend.Cmconstr]
-notin_callstack [in backend.Machabstr2mach]
-numbering [in backend.CSE]
-

O

-operation [in backend.Csharpminor]
-operation [in backend.Op]
-op_strength_reduction_cases [in backend.Constprop]
-or_cases [in backend.Cmconstr]
-outcome [in backend.Cminor]
-outcome [in backend.LTL]
-outcome [in backend.PPC]
-outcome [in backend.Csharpminor]
-outcome_inject [in backend.Cminorgenproof]
-

P

-preg [in backend.PPC]
-program [in backend.AST]
-

R

-res [in backend.RTLgen]
-return_reg_ok [in backend.RTLgenproof1]
-rhs [in backend.CSE]
-rlw_state [in lib.Integers]
-rolm_cases [in backend.Cmconstr]
-

S

-set_slot [in backend.Machabstr]
-shift_cases [in backend.Cmconstr]
-signature [in backend.AST]
-slot [in backend.Locations]
-state [in backend.Kildall]
-state [in backend.RTLgen]
-state [in backend.Kildall]
-state_incr [in backend.RTLgenproof1]
-step [in backend.Parallelmove]
-stepp [in backend.Parallelmove]
-stmt [in backend.Csharpminor]
-stmt [in backend.Cminor]
-stmtlist [in backend.Csharpminor]
-stmtlist [in backend.Cminor]
-subf_cases [in backend.Cmconstr]
-sub_cases [in backend.Cmconstr]
-

T

-target_regs_ok [in backend.RTLgenproof1]
-target_reg_ok [in backend.RTLgenproof1]
-transl_code_at_pc [in backend.PPCgenproof]
-tree [in lib.Maps]
-typ [in backend.AST]
-t_ [in lib.Lattice]
-t_ [in lib.Lattice]
-

U

-unionfind [in lib.union_find]
-

V

-val [in backend.Values]
-val_content_inject [in backend.Mem]
-val_inject [in backend.Mem]
-val_list_inject [in backend.Mem]
-val_list_match_approx [in backend.Constpropproof]
-vars_vals_match [in backend.Cminorgenproof]
-var_info [in backend.Cminorgen]
-

W

-wt_block [in backend.LTLtyping]
-wt_function [in backend.RTLtyping]
-wt_function [in backend.Machtyping]
-wt_instr [in backend.Lineartyping]
-wt_instr [in backend.Machtyping]
-wt_instr [in backend.RTLtyping]
-

-

Definition Index

-

A

-absf [in backend.Values]
-absfloat [in backend.Cmconstr]
-add [in backend.Values]
-add [in lib.Sets]
-add [in backend.Cmconstr]
-add [in backend.RTLtyping]
-add [in lib.Integers]
-addf [in backend.Cmconstr]
-addf [in backend.Values]
-addf_match [in backend.Cmconstr]
-addf_match_aux [in backend.Cmconstr]
-addimm [in backend.PPCgen]
-addimm [in backend.Cmconstr]
-addimm_match [in backend.Cmconstr]
-addimm_1 [in backend.PPCgen]
-addimm_2 [in backend.PPCgen]
-addressing [in backend.Cmconstr]
-addressing_match [in backend.Cmconstr]
-addr_strength_reduction [in backend.Constprop]
-addr_strength_reduction_match [in backend.Constprop]
-addr_taken_expr [in backend.Cminorgen]
-addr_taken_stmt [in backend.Cminorgen]
-add_call [in backend.Allocation]
-add_cond [in backend.Allocation]
-add_edges_instr [in backend.Coloring]
-add_edges_instrs [in backend.Coloring]
-add_entry [in backend.Allocation]
-add_funct [in backend.Globalenvs]
-add_functs [in backend.Globalenvs]
-add_globals [in backend.Globalenvs]
-add_instr [in backend.RTLgen]
-add_interf [in backend.InterfGraph]
-add_interf_call [in backend.Coloring]
-add_interf_entry [in backend.Coloring]
-add_interf_live [in backend.Coloring]
-add_interf_move [in backend.Coloring]
-add_interf_mreg [in backend.InterfGraph]
-add_interf_op [in backend.Coloring]
-add_interf_params [in backend.Coloring]
-add_letvar [in backend.RTLgen]
-add_load [in backend.CSE]
-add_load [in backend.Allocation]
-add_match [in backend.Cmconstr]
-add_match_aux [in backend.Cmconstr]
-add_move [in backend.RTLgen]
-add_move [in backend.Allocation]
-add_op [in backend.Allocation]
-add_op [in backend.CSE]
-add_pref [in backend.InterfGraph]
-add_prefs_call [in backend.Coloring]
-add_pref_mreg [in backend.InterfGraph]
-add_reload [in backend.Allocation]
-add_reloads [in backend.Allocation]
-add_return [in backend.Allocation]
-add_rhs [in backend.CSE]
-add_spill [in backend.Allocation]
-add_store [in backend.Allocation]
-add_successors [in backend.Kildall]
-add_symbol [in backend.Globalenvs]
-add_to_worklist [in backend.Kildall]
-add_undefs [in backend.Allocation]
-add_var [in backend.RTLgen]
-add_vars [in backend.RTLgen]
-agree [in backend.Allocproof]
-agree [in backend.PPCgenproof1]
-align [in lib.Coqlib]
-align_16_top [in backend.Mach]
-alloc [in backend.Mem]
-alloc_of_coloring [in backend.Coloring]
-alloc_reg [in backend.RTLgen]
-alloc_regs [in backend.RTLgen]
-all_interf_regs [in backend.InterfGraph]
-analyze [in backend.Allocation]
-analyze [in backend.Constprop]
-analyze [in backend.CSE]
-and [in lib.Integers]
-and [in backend.Cmconstr]
-and [in backend.Values]
-andimm [in backend.Cmconstr]
-andimm [in backend.PPCgen]
-append [in lib.Maps]
-apply_partial [in backend.Main]
-apply_total [in backend.Main]
-approx_regs [in backend.Constprop]
-assign_variable [in backend.Cminorgen]
-assign_variables [in backend.Cminorgen]
-

B

-base_case_Pmov_dec [in backend.Parallelmove]
-basic_block_list [in backend.Kildall]
-basic_block_map [in backend.Kildall]
-bbmap [in backend.Kildall]
-bind [in backend.RTLgen]
-bind [in backend.Cminorgen]
-bind2 [in backend.RTLgen]
-bin_A [in lib.Inclusion]
-bits_of_Z [in lib.Integers]
-bitwise_binop [in lib.Integers]
-block [in backend.Values]
-block_agree [in backend.Mem]
-block_contents_agree [in backend.Mem]
-block_contents_extends [in backend.Mem]
-bot [in lib.Lattice]
-bot [in lib.Lattice]
-bot [in backend.Constprop]
-bot [in lib.Sets]
-bot [in lib.Lattice]
-branch_target [in backend.Tunneling]
-branch_target_rec [in backend.Tunneling]
-build_compilenv [in backend.Cminorgen]
-

C

-callstack [in backend.Machabstr2mach]
-callstack [in backend.Cminorgenproof]
-call_regs [in backend.LTL]
-cast [in backend.Csharpminor]
-cast16signed [in lib.Integers]
-cast16signed [in backend.Values]
-cast16signed [in backend.Cmconstr]
-cast16unsigned [in backend.Cmconstr]
-cast16unsigned [in backend.Values]
-cast16unsigned [in lib.Integers]
-cast8signed [in backend.Cmconstr]
-cast8signed [in lib.Integers]
-cast8signed [in backend.Values]
-cast8unsigned [in backend.Cmconstr]
-cast8unsigned [in backend.Values]
-cast8unsigned [in lib.Integers]
-check_all_leaves [in lib.Inclusion]
-check_coloring [in backend.Coloring]
-check_coloring_1 [in backend.Coloring]
-check_coloring_2 [in backend.Coloring]
-check_coloring_3 [in backend.Coloring]
-check_cont [in backend.Mem]
-check_equal_on_range [in lib.Integers]
-chunk_of_type [in backend.Mach]
-cleanup_code [in backend.Linearize]
-cleanup_function [in backend.Linearize]
-cmp [in backend.Cmconstr]
-cmp [in backend.Values]
-cmp [in lib.Integers]
-cmpf [in backend.Cmconstr]
-cmpf [in backend.Values]
-cmpu [in backend.Values]
-cmpu [in backend.Cmconstr]
-cmpu [in lib.Integers]
-cmp_mismatch [in backend.Values]
-code [in backend.LTL]
-code [in backend.PPC]
-code [in backend.RTL]
-code [in backend.Linear]
-code [in backend.Mach]
-code_size [in backend.PPCgen]
-code_tail [in backend.PPCgenproof]
-combine [in lib.Maps]
-compare_float [in backend.PPC]
-compare_sint [in backend.PPC]
-compare_uint [in backend.PPC]
-compilenv [in backend.Cminorgen]
-condexpr_of_expr [in backend.Cmconstr]
-conditionalexpr [in backend.Cmconstr]
-cond_strength_reduction [in backend.Constprop]
-cond_strength_reduction_match [in backend.Constprop]
-consistent [in backend.RTLtyping]
-const_high [in backend.PPC]
-const_low [in backend.PPC]
-contentmap [in backend.Mem]
-contentmap_agree [in backend.Mem]
-contentmap_inject [in backend.Mem]
-correct_alloc_instr [in backend.Coloringproof]
-correct_interf_instr [in backend.Coloringproof]
-crbit_for_cond [in backend.PPCgen]
-crbit_for_fcmp [in backend.PPCgen]
-crbit_for_icmp [in backend.PPCgen]
-

D

-decode [in backend.RTLtyping]
-def [in backend.Parallelmove]
-definite [in backend.RTLtyping]
-destroyed_at_call [in backend.Conventions]
-destroyed_at_call_regs [in backend.Conventions]
-diff [in backend.Locations]
-diff_dec [in backend.Parallelmove]
-disjoint [in backend.Locations]
-divf [in backend.Values]
-divf [in backend.Cmconstr]
-divs [in backend.Cmconstr]
-divs [in lib.Integers]
-divs [in backend.Values]
-divu [in backend.Cmconstr]
-divu [in backend.Values]
-divu [in lib.Integers]
-divu_match [in backend.Cmconstr]
-Done_well_formed [in backend.Allocproof_aux]
-drop1 [in backend.Conventions]
-drop2 [in backend.Conventions]
-

E

-elements [in lib.Sets]
-elements [in lib.Maps]
-elt [in lib.Maps]
-elt [in backend.RTLtyping]
-elt [in lib.Sets]
-elt [in lib.union_find]
-elt [in lib.union_find]
-elt [in lib.union_find]
-elt [in lib.Maps]
-elt [in lib.Maps]
-elt [in lib.Maps]
-elt_eq [in lib.Maps]
-elt_eq [in lib.Maps]
-elt_eq [in lib.Maps]
-elt_eq [in lib.Maps]
-empty [in lib.Sets]
-empty [in lib.Maps]
-empty [in lib.union_find]
-empty [in backend.RTLtyping]
-empty [in backend.Globalenvs]
-empty [in backend.Mem]
-empty_block [in backend.Mem]
-empty_env [in backend.Csharpminor]
-empty_frame [in backend.Machabstr]
-empty_graph [in backend.InterfGraph]
-empty_numbering [in backend.CSE]
-encode [in backend.RTLtyping]
-enumerate [in backend.Linearize]
-env [in backend.Csharpminor]
-Env [in backend.Parallelmove]
-env [in backend.Cminor]
-eq [in backend.Mach]
-eq [in lib.Ordered]
-eq [in backend.RTLtyping]
-eq [in backend.CSEproof]
-eq [in lib.Maps]
-eq [in backend.Locations]
-eq [in lib.Ordered]
-eq [in backend.Registers]
-eq [in lib.Ordered]
-eq [in backend.PPC]
-eq [in lib.Integers]
-eqm [in lib.Integers]
-eqmod [in lib.Integers]
-equation_holds [in backend.CSE]
-eq_block [in backend.Values]
-eq_list_valnum [in backend.CSE]
-eq_rhs [in backend.CSE]
-eq_valnum [in backend.CSE]
-error [in backend.RTLtyping]
-error [in backend.RTLgen]
-eval_addressing [in backend.Op]
-eval_addressing_total [in backend.Op]
-eval_compare_null [in backend.Op]
-eval_compare_null [in backend.Csharpminor]
-eval_condition [in backend.Op]
-eval_condition_total [in backend.Op]
-eval_exprlist_prop [in backend.Cminorgenproof]
-eval_expr_prop [in backend.Cminorgenproof]
-eval_funcall_prop [in backend.Cminorgenproof]
-eval_operation [in backend.Op]
-eval_operation [in backend.Csharpminor]
-eval_operation_total [in backend.Op]
-eval_static_condition [in backend.Constprop]
-eval_static_condition_match [in backend.Constprop]
-eval_static_operation [in backend.Constprop]
-eval_static_operation_match [in backend.Constprop]
-exec [in backend.Parallelmove]
-exec_blocks_prop [in backend.Linearizeproof]
-exec_blocks_prop [in backend.Tunnelingproof]
-exec_block_prop [in backend.Linearizeproof]
-exec_block_prop [in backend.Tunnelingproof]
-exec_function_body_prop [in backend.Machabstr2mach]
-exec_function_body_prop [in backend.PPCgenproof]
-exec_function_body_prop [in backend.Machtyping]
-exec_function_prop [in backend.Stackingproof]
-exec_function_prop [in backend.Machtyping]
-exec_function_prop [in backend.PPCgenproof]
-exec_function_prop [in backend.Constpropproof]
-exec_function_prop [in backend.Linearizeproof]
-exec_function_prop [in backend.Machabstr2mach]
-exec_function_prop [in backend.CSEproof]
-exec_function_prop [in backend.Tunnelingproof]
-exec_function_prop [in backend.Allocproof]
-exec_function_subject_reduction [in backend.RTLtyping]
-exec_instr [in backend.PPC]
-exec_instrs_prop [in backend.Allocproof]
-exec_instrs_prop [in backend.Tunnelingproof]
-exec_instrs_prop [in backend.Machabstr2mach]
-exec_instrs_prop [in backend.CSEproof]
-exec_instrs_prop [in backend.Constpropproof]
-exec_instrs_prop [in backend.Linearizeproof]
-exec_instr_prop [in backend.Allocproof]
-exec_instr_prop [in backend.Machabstr2mach]
-exec_instr_prop [in backend.Machtyping]
-exec_instr_prop [in backend.Constpropproof]
-exec_instr_prop [in backend.CSEproof]
-exec_instr_prop [in backend.Tunnelingproof]
-exec_instr_prop [in backend.Stackingproof]
-exec_instr_prop [in backend.Linearizeproof]
-exec_instr_prop [in backend.PPCgenproof]
-exec_instr_subject_reduction [in backend.RTLtyping]
-exec_program [in backend.Csharpminor]
-exec_program [in backend.LTL]
-exec_program [in backend.Cminor]
-exec_program [in backend.RTL]
-exec_program [in backend.Mach]
-exec_program [in backend.Machabstr]
-exec_program [in backend.Linear]
-exec_program [in backend.PPC]
-exec_stmtlist_prop [in backend.Cminorgenproof]
-exec_stmt_prop [in backend.Cminorgenproof]
-extends [in backend.Mem]
-extend_inject [in backend.Mem]
-

F

-find_funct [in backend.Globalenvs]
-find_function [in backend.LTL]
-find_function [in backend.Mach]
-find_function [in backend.RTL]
-find_function [in backend.Linear]
-find_function2 [in backend.Allocproof]
-find_funct_ptr [in backend.Globalenvs]
-find_instr [in backend.PPC]
-find_label [in backend.Mach]
-find_label [in backend.PPCgenproof]
-find_label [in backend.Linear]
-find_letvar [in backend.RTLgen]
-find_load [in backend.CSE]
-find_op [in backend.CSE]
-find_rhs [in backend.CSE]
-find_symbol [in backend.Globalenvs]
-find_symbol_offset [in backend.Op]
-find_valnum_rhs [in backend.CSE]
-find_var [in backend.RTLgen]
-fixpoint [in backend.Kildall]
-fixpoint [in backend.Kildall]
-fixpoint [in backend.Kildall]
-flatten [in lib.Inclusion]
-flatten_aux [in lib.Inclusion]
-floatcomp [in backend.PPCgen]
-floatofint [in backend.Values]
-floatofint [in backend.Cmconstr]
-floatofintu [in backend.Cmconstr]
-floatofintu [in backend.Values]
-float_callee_save [in backend.Lineartyping]
-float_callee_save_regs [in backend.Conventions]
-float_local [in backend.Lineartyping]
-float_param_regs [in backend.Conventions]
-fn_params_names [in backend.Csharpminor]
-fn_variables [in backend.Csharpminor]
-fn_vars_names [in backend.Csharpminor]
-fold [in lib.Sets]
-fold [in lib.Maps]
-fold2 [in backend.RTLtyping]
-for_all [in lib.Sets]
-frame [in backend.Machabstr]
-free [in backend.Mem]
-free_list [in backend.Mem]
-freg_of [in backend.PPCgen]
-function_bounds [in backend.Lineartyping]
-

G

-ge [in lib.Lattice]
-ge [in backend.CSE]
-ge [in lib.Lattice]
-ge [in backend.Constprop]
-ge [in lib.Lattice]
-ge [in lib.Sets]
-genv [in backend.Cminor]
-genv [in backend.LTL]
-genv [in backend.PPC]
-genv [in backend.Csharpminor]
-genv [in backend.RTL]
-genv [in backend.Mach]
-genv [in backend.Linear]
-get [in lib.Maps]
-get [in lib.Maps]
-get [in lib.Maps]
-Get [in backend.Parallelmove]
-get [in backend.Locations]
-get [in lib.Lattice]
-get [in lib.Maps]
-get [in backend.Parallelmove]
-get [in backend.RTLtyping]
-getdst [in backend.Parallelmove]
-getN [in backend.Mem]
-getsrc [in backend.Parallelmove]
-globalenv [in backend.Globalenvs]
-globalenv_initmem [in backend.Globalenvs]
-good_state [in backend.Kildall]
-goto_label [in backend.PPC]
-gpr_or_zero [in backend.PPC]
-graph_incl [in backend.InterfGraph]
-

H

-half_modulus [in lib.Integers]
-has_type [in backend.Values]
-has_type_list [in backend.Values]
-head_but_last [in backend.Parallelmove]
-high_bound [in backend.Mem]
-high_s [in backend.PPCgen]
-high_u [in backend.PPCgen]
-

I

-ident [in backend.AST]
-identify [in lib.union_find]
-identify_base [in lib.union_find]
-ident_eq [in backend.AST]
-ifthenelse [in backend.Cmconstr]
-included [in backend.RTLtyping]
-index [in backend.Locations]
-index [in lib.Maps]
-index [in lib.Maps]
-index_diff [in backend.Stackingproof]
-index_float_callee_save [in backend.Conventions]
-index_int_callee_save [in backend.Conventions]
-index_val [in backend.Stackingproof]
-index_valid [in backend.Stackingproof]
-init [in lib.Maps]
-init [in backend.Locations]
-init [in lib.Maps]
-init [in lib.Maps]
-init_frame [in backend.Machabstr]
-init_mapping [in backend.RTLgen]
-init_mem [in backend.Globalenvs]
-init_regs [in backend.RTL]
-init_state [in backend.RTLgen]
-inject_incr [in backend.Mem]
-insert_bin [in lib.Inclusion]
-interfere [in backend.InterfGraph]
-interfere_mreg [in backend.InterfGraph]
-interf_graph [in backend.Coloring]
-intoffloat [in backend.Cmconstr]
-intoffloat [in backend.Values]
-intval [in backend.Constprop]
-int_callee_save [in backend.Lineartyping]
-int_callee_save_regs [in backend.Conventions]
-int_local [in backend.Lineartyping]
-int_of_one_bits [in lib.Integers]
-int_param_regs [in backend.Conventions]
-in_bounds [in backend.Mem]
-in_incr [in backend.Kildall]
-in_range [in lib.Integers]
-ireg_of [in backend.PPCgen]
-is_basic_block_head [in backend.Kildall]
-is_bool [in backend.Values]
-is_data_reg [in backend.PPCgenproof1]
-is_false [in lib.Integers]
-is_false [in backend.Values]
-is_goto_block [in backend.Tunneling]
-is_label [in backend.PPC]
-is_label [in backend.Mach]
-is_label [in backend.Linear]
-is_move_operation [in backend.Op]
-is_power2 [in lib.Integers]
-is_rlw_mask [in lib.Integers]
-is_rlw_mask_rec [in lib.Integers]
-is_trivial_op [in backend.CSE]
-is_true [in lib.Integers]
-is_true [in backend.Values]
-iterate [in backend.Kildall]
-iter_step [in backend.Kildall]
-

K

-kill_loads [in backend.CSE]
-kill_load_eqs [in backend.CSE]
-

L

-label [in backend.Linear]
-label [in backend.PPC]
-label [in backend.Mach]
-label_pos [in backend.PPC]
-last [in backend.Parallelmove]
-lbl [in backend.Linearize]
-lbl [in backend.Linearize]
-leaf [in lib.Inclusion]
-leaf [in lib.Inclusion]
-leaf [in lib.Inclusion]
-letenv [in backend.Cminor]
-letenv [in backend.Csharpminor]
-lift [in backend.Cmconstr]
-lift_condexpr [in backend.Cmconstr]
-lift_expr [in backend.Cmconstr]
-lift_exprlist [in backend.Cmconstr]
-linearize_block [in backend.Linearize]
-linearize_body [in backend.Linearize]
-linearize_function [in backend.Linearize]
-link_invariant [in backend.Machtyping]
-listsLoc2Moves [in backend.Parallelmove]
-listsLoc2Moves [in backend.Allocation]
-list_disjoint [in lib.Coqlib]
-live0 [in backend.Allocproof]
-load [in backend.Mem]
-load [in backend.Cmconstr]
-loadimm [in backend.PPCgen]
-loadind [in backend.PPCgen]
-loadind_aux [in backend.PPCgen]
-loadv [in backend.Mem]
-load1 [in backend.PPC]
-load2 [in backend.PPC]
-load_contents [in backend.Mem]
-load_result [in backend.Values]
-load_stack [in backend.Mach]
-locset [in backend.LTL]
-locset [in backend.Linear]
-locs_acceptable [in backend.Conventions]
-locs_read_ok [in backend.Alloctyping]
-locs_write_ok [in backend.Alloctyping]
-loc_acceptable [in backend.Conventions]
-loc_arguments [in backend.Conventions]
-loc_arguments_rec [in backend.Conventions]
-loc_argument_acceptable [in backend.Conventions]
-loc_is_acceptable [in backend.Coloring]
-loc_parameters [in backend.Conventions]
-loc_read_ok [in backend.Alloctyping]
-loc_result [in backend.Conventions]
-loc_write_ok [in backend.Alloctyping]
-low_bound [in backend.Mem]
-low_s [in backend.PPCgen]
-low_u [in backend.PPCgen]
-lt [in lib.Integers]
-lt [in lib.Ordered]
-lt [in lib.Ordered]
-lt [in lib.Ordered]
-ltu [in lib.Integers]
-lub [in lib.Lattice]
-lub [in lib.Lattice]
-lub [in lib.Sets]
-lub [in lib.Lattice]
-lub [in backend.Constprop]
-

M

-make_addimm [in backend.Constprop]
-make_andimm [in backend.Constprop]
-make_cast [in backend.Cminorgen]
-make_env [in backend.Stacking]
-make_load [in backend.Cminorgen]
-make_mulimm [in backend.Constprop]
-make_op [in backend.Cminorgen]
-make_orimm [in backend.Constprop]
-make_predecessors [in backend.Kildall]
-make_shlimm [in backend.Constprop]
-make_shrimm [in backend.Constprop]
-make_shruimm [in backend.Constprop]
-make_stackaddr [in backend.Cminorgen]
-make_store [in backend.Cminorgen]
-make_xorimm [in backend.Constprop]
-map [in lib.Maps]
-map [in lib.Maps]
-map [in lib.Maps]
-map [in lib.Maps]
-mapped [in backend.RTLtyping]
-match_return_outcome [in backend.RTLgenproof]
-match_return_reg [in backend.RTLgenproof]
-max_over_instrs [in backend.Lineartyping]
-max_over_list [in backend.Lineartyping]
-max_over_regs_of_funct [in backend.Lineartyping]
-max_over_regs_of_instr [in backend.Lineartyping]
-max_over_slots_of_funct [in backend.Lineartyping]
-max_over_slots_of_instr [in backend.Lineartyping]
-max_signed [in lib.Integers]
-max_unsigned [in lib.Integers]
-mem [in lib.Sets]
-member [in backend.RTLtyping]
-meminj [in backend.Mem]
-mem_chunk [in backend.Mem]
-mem_type [in backend.Machabstr]
-mesure [in backend.Parallelmove]
-min_signed [in lib.Integers]
-mk_env [in backend.RTLtyping]
-mods [in lib.Integers]
-mods [in backend.Cmconstr]
-mods [in backend.Values]
-modu [in lib.Integers]
-modu [in backend.Values]
-modu [in backend.Cmconstr]
-modulus [in lib.Integers]
-mod_aux [in backend.Cmconstr]
-mon [in backend.RTLgen]
-mone [in lib.Integers]
-Move [in backend.Parallelmove]
-Moves [in backend.Parallelmove]
-mreg_bounded [in backend.Lineartyping]
-mreg_type [in backend.Locations]
-mul [in lib.Integers]
-mul [in backend.Cmconstr]
-mul [in backend.Values]
-mulf [in backend.Cmconstr]
-mulf [in backend.Values]
-mulimm [in backend.Cmconstr]
-mulimm_base [in backend.Cmconstr]
-mulimm_match [in backend.Cmconstr]
-mul_match [in backend.Cmconstr]
-mul_match_aux [in backend.Cmconstr]
-mutated_condexpr [in backend.RTLgen]
-mutated_expr [in backend.RTLgen]
-mutated_exprlist [in backend.RTLgen]
-mutated_reg [in backend.RTLgenproof1]
-

N

-nat_le_bool [in lib.Inclusion]
-neg [in backend.Values]
-neg [in lib.Integers]
-negate_comparison [in backend.AST]
-negate_condition [in backend.Op]
-negf [in backend.Values]
-negfloat [in backend.Cmconstr]
-negint [in backend.Cmconstr]
-new_reg [in backend.RTLgen]
-nextinstr [in backend.PPC]
-nil [in backend.Parallelmove]
-nil [in backend.Parallelmove]
-nil [in backend.Parallelmove]
-nil [in backend.Parallelmove]
-nil [in backend.Parallelmove]
-nil [in backend.Parallelmove]
-nil [in backend.Parallelmove]
-nil [in backend.Parallelmove]
-nil [in backend.Parallelmove]
-nil [in backend.Parallelmove]
-nil [in backend.Allocproof_aux]
-nil [in backend.Parallelmove]
-nil [in backend.Parallelmove]
-nil [in backend.Parallelmove]
-nil [in backend.Parallelmove]
-nil [in backend.Parallelmove]
-nil [in backend.Parallelmove]
-nil [in backend.Parallelmove]
-node [in backend.RTL]
-node [in backend.LTL]
-NoOverlap [in backend.Parallelmove]
-noOverlap [in backend.Parallelmove]
-noOverlap_aux [in backend.Parallelmove]
-noRead [in backend.Parallelmove]
-not [in lib.Integers]
-notbool [in backend.Values]
-notbool [in backend.Cmconstr]
-notbool [in lib.Integers]
-notbool_base [in backend.Cmconstr]
-notemporary [in backend.Parallelmove]
-notin [in backend.Locations]
-notint [in backend.Values]
-notint [in backend.Cmconstr]
-notint_match [in backend.Cmconstr]
-noTmp [in backend.Parallelmove]
-noTmpLast [in backend.Parallelmove]
-noWrite [in backend.Parallelmove]
-no_overlap [in backend.Parallelmove]
-no_overlap [in backend.Locations]
-no_overlap_list [in backend.Parallelmove]
-no_overlap_state [in backend.Parallelmove]
-no_overlap_stateD [in backend.Allocproof_aux]
-no_tmp13_state [in backend.Allocproof_aux]
-nullptr [in backend.Mem]
-numbering_holds [in backend.CSE]
-numbering_satisfiable [in backend.CSE]
-num_iterations [in backend.Kildall]
-

O

-offset_of_index [in backend.Stacking]
-offset_sp [in backend.Op]
-of_bool [in backend.Values]
-one [in lib.Integers]
-one_bits [in lib.Integers]
-option_fold2 [in backend.RTLtyping]
-option_map [in lib.Coqlib]
-op_strength_reduction [in backend.Constprop]
-op_strength_reduction_match [in backend.Constprop]
-or [in lib.Integers]
-or [in backend.Values]
-or [in backend.Cmconstr]
-ordered_pair [in backend.InterfGraph]
-orimm [in backend.PPCgen]
-or_match [in backend.Cmconstr]
-outcome_block [in backend.Csharpminor]
-outcome_block [in backend.Cminor]
-outcome_node [in backend.RTLgenproof]
-outcome_result_value [in backend.Cminor]
-outcome_result_value [in backend.Csharpminor]
-outgoing_slot [in backend.Lineartyping]
-outgoing_space [in backend.Lineartyping]
-overlap [in backend.Locations]
-overlap_aux [in backend.Locations]
-

P

-parallel_move [in backend.Allocation]
-parallel_move_order [in backend.Allocation]
-parameter_of_argument [in backend.Conventions]
-path [in backend.Parallelmove]
-peq [in lib.Coqlib]
-pexec [in backend.Parallelmove]
-Ple [in lib.Coqlib]
-Plt [in lib.Coqlib]
-plt [in lib.Coqlib]
-Pmov [in backend.Parallelmove]
-positive_rec [in lib.Coqlib]
-powerserie [in lib.Integers]
-predecessors [in backend.Kildall]
-preg_of [in backend.PPCgenproof1]
-program [in backend.LTL]
-program [in backend.Cminor]
-program [in backend.Linear]
-program [in backend.RTL]
-program [in backend.Csharpminor]
-program [in backend.PPC]
-program [in backend.Mach]
-propagate_succ [in backend.Kildall]
-propagate_successors [in backend.Kildall]
-propagate_succ_list [in backend.Kildall]
-Pstate [in backend.Kildall]
-p_move [in backend.Allocproof_aux]
-P_move [in backend.Parallelmove]
-

R

-R [in backend.Coloring]
-reachable [in backend.Linearize]
-reachable_aux [in backend.Linearize]
-reg [in backend.Registers]
-Reg [in backend.Parallelmove]
-regalloc [in backend.Coloring]
-regenv [in backend.RTLtyping]
-reglist [in backend.LTL]
-regmap_optget [in backend.Registers]
-regmap_optset [in backend.Registers]
-regset [in backend.Mach]
-regset [in backend.RTL]
-regset [in backend.PPC]
-regs_for [in backend.Allocation]
-regs_for_rec [in backend.Allocation]
-regs_match_approx [in backend.Constpropproof]
-regs_of_instr [in backend.Lineartyping]
-reg_for [in backend.Allocation]
-reg_fresh [in backend.RTLgenproof1]
-reg_in_map [in backend.RTLgenproof1]
-reg_list_dead [in backend.Allocation]
-reg_list_live [in backend.Allocation]
-reg_of_crbit [in backend.PPC]
-reg_option_live [in backend.Allocation]
-reg_sum_live [in backend.Allocation]
-reg_valid [in backend.RTLgenproof1]
-reg_valnum [in backend.CSE]
-remove [in lib.Sets]
-remove [in lib.Maps]
-remove_all_leaves [in lib.Inclusion]
-repet [in backend.RTLtyping]
-replace_last_s [in backend.Parallelmove]
-repr [in lib.union_find]
-repr [in lib.Integers]
-repr_aux [in lib.union_find]
-repr_order [in lib.union_find]
-repr_rec [in lib.union_find]
-reserve_instr [in backend.RTLgen]
-restore_callee_save [in backend.Stacking]
-restore_float_callee_save [in backend.Stacking]
-restore_int_callee_save [in backend.Stacking]
-result [in backend.Kildall]
-reswellFormed [in backend.Allocproof_aux]
-ret [in backend.RTLgen]
-return_regs [in backend.LTL]
-ret_reg [in backend.RTLgen]
-rhs_evals_to [in backend.CSEproof]
-right [in backend.Parallelmove]
-rlw_accepting [in lib.Integers]
-rlw_transition [in lib.Integers]
-rol [in lib.Integers]
-rolm [in backend.Values]
-rolm [in backend.Cmconstr]
-rolm [in lib.Integers]
-rolm_match [in backend.Cmconstr]
-

S

-sameclass [in lib.union_find]
-sameclass [in lib.union_find]
-sameEnv [in backend.Parallelmove]
-sameExec [in backend.Parallelmove]
-same_expr_pure [in backend.Cmconstr]
-same_typ [in backend.Coloring]
-save_callee_save [in backend.Stacking]
-save_float_callee_save [in backend.Stacking]
-save_int_callee_save [in backend.Stacking]
-set [in lib.Maps]
-set [in backend.Locations]
-set [in lib.Maps]
-set [in lib.Maps]
-set [in lib.Lattice]
-set [in lib.Maps]
-setN [in backend.Mem]
-set_cont [in backend.Mem]
-set_locals [in backend.Cminor]
-set_params [in backend.Cminor]
-Sexec [in backend.Parallelmove]
-sexec [in backend.Parallelmove]
-shift_match [in backend.Cmconstr]
-shift_sp [in backend.Stackingproof]
-shl [in lib.Integers]
-shl [in backend.Cmconstr]
-shl [in backend.Values]
-shlimm [in backend.Cmconstr]
-shr [in lib.Integers]
-shr [in backend.Cmconstr]
-shr [in backend.Values]
-shru [in backend.Cmconstr]
-shru [in lib.Integers]
-shru [in backend.Values]
-shruimm [in backend.Cmconstr]
-shrx [in lib.Integers]
-shrx [in backend.Values]
-shr_carry [in backend.Values]
-shr_carry [in lib.Integers]
-signed [in lib.Integers]
-simpleDest [in backend.Parallelmove]
-singleoffloat [in backend.Values]
-singleoffloat [in backend.Cmconstr]
-sizeof [in backend.Csharpminor]
-size_arguments [in backend.Conventions]
-size_arguments_rec [in backend.Conventions]
-size_chunk [in backend.Mem]
-size_mem [in backend.Mem]
-slots_of_instr [in backend.Lineartyping]
-slot_bounded [in backend.Lineartyping]
-slot_bounded [in backend.LTLtyping]
-slot_type [in backend.Locations]
-Some [in backend.Parallelmove]
-sort_bin [in lib.Inclusion]
-split_move [in backend.Parallelmove]
-split_move' [in backend.Parallelmove]
-starts_with [in backend.Linearize]
-start_state [in backend.Kildall]
-start_state_in [in backend.Kildall]
-start_state_wrk [in backend.Kildall]
-State [in backend.Parallelmove]
-StateBeing [in backend.Parallelmove]
-StateDone [in backend.Parallelmove]
-StateToMove [in backend.Parallelmove]
-state_extends [in backend.RTLgenproof1]
-state_invariant [in backend.Kildall]
-step [in backend.Kildall]
-step [in backend.Kildall]
-stepf [in backend.Parallelmove]
-stepf' [in backend.Parallelmove]
-stepInv [in backend.Parallelmove]
-step_NF [in backend.Parallelmove]
-store [in backend.Cmconstr]
-store [in backend.Mem]
-storeind [in backend.PPCgen]
-storeind_aux [in backend.PPCgen]
-storev [in backend.Mem]
-store1 [in backend.PPC]
-store2 [in backend.PPC]
-store_contents [in backend.Mem]
-store_parameters [in backend.Cminorgen]
-store_stack [in backend.Mach]
-sub [in backend.Values]
-sub [in lib.Integers]
-sub [in backend.Cmconstr]
-subf [in backend.Values]
-subf [in backend.Cmconstr]
-subf_match [in backend.Cmconstr]
-sub_match [in backend.Cmconstr]
-sub_match_aux [in backend.Cmconstr]
-successors [in backend.LTL]
-successors [in backend.RTL]
-successors_aux [in backend.LTL]
-sum_left_map [in lib.Coqlib]
-swap_comparison [in backend.AST]
-symbol_offset [in backend.PPC]
-s1 [in backend.Linearize]
-

T

-t [in backend.PPC]
-t [in lib.Ordered]
-t [in lib.Maps]
-t [in lib.Maps]
-t [in lib.Lattice]
-t [in backend.Locations]
-t [in backend.Constprop]
-t [in lib.Ordered]
-t [in backend.Globalenvs]
-t [in lib.Lattice]
-T [in backend.RTLtyping]
-T [in lib.union_find]
-t [in backend.CSEproof]
-t [in backend.Locations]
-t [in lib.Maps]
-T [in backend.Parallelmove]
-t [in lib.Maps]
-T [in backend.RTLtyping]
-t [in backend.InterfGraph]
-t [in lib.Maps]
-t [in lib.Ordered]
-t [in lib.Lattice]
-t [in backend.Mach]
-t [in lib.Sets]
-t [in lib.Maps]
-t [in backend.CSE]
-temporaries [in backend.Conventions]
-temporaries1 [in backend.Allocproof_aux]
-temporaries1_3 [in backend.Allocproof_aux]
-temporaries2 [in backend.Allocproof_aux]
-teq [in backend.RTLtyping]
-test_inclusion [in lib.Inclusion]
-Tint [in backend.Allocation]
-top [in lib.Lattice]
-top [in lib.Lattice]
-top [in backend.CSE]
-top [in backend.Constprop]
-top [in lib.Lattice]
-transfer [in backend.Allocation]
-transfer [in backend.Constprop]
-transfer [in backend.CSE]
-transform_partial_program [in backend.AST]
-transform_program [in backend.AST]
-transf_cminor_function [in backend.Main]
-transf_cminor_program [in backend.Main]
-transf_cminor_program2 [in backend.Main]
-transf_code [in backend.Constprop]
-transf_code [in backend.CSE]
-transf_csharpminor_function [in backend.Main]
-transf_csharpminor_program [in backend.Main]
-transf_csharpminor_program2 [in backend.Main]
-transf_entrypoint [in backend.Allocation]
-transf_function [in backend.Linearize]
-transf_function [in backend.Allocation]
-transf_function [in backend.CSE]
-transf_function [in backend.RTL]
-transf_function [in backend.PPCgen]
-transf_function [in backend.Stacking]
-transf_function [in backend.Constprop]
-transf_instr [in backend.Allocation]
-transf_instr [in backend.Constprop]
-transf_instr [in backend.CSE]
-transf_partial [in backend.Globalenvs]
-transf_partial_program [in backend.AST]
-transf_program [in backend.CSE]
-transf_program [in backend.PPCgen]
-transf_program [in backend.Stacking]
-transf_program [in backend.Constprop]
-transf_program [in backend.Allocation]
-transf_program [in backend.Linearize]
-transf_program [in backend.AST]
-transl_addr [in backend.Stacking]
-transl_body [in backend.Stacking]
-transl_code [in backend.PPCgen]
-transl_code [in backend.Stacking]
-transl_cond [in backend.PPCgen]
-transl_condition_correct [in backend.RTLgenproof]
-transl_condition_incr_pred [in backend.RTLgenproof1]
-transl_expr [in backend.RTLgen]
-transl_expr [in backend.Cminorgen]
-transl_exprlist_correct [in backend.RTLgenproof]
-transl_exprlist_incr_pred [in backend.RTLgenproof1]
-transl_expr_correct [in backend.RTLgenproof]
-transl_expr_incr_pred [in backend.RTLgenproof1]
-transl_fun [in backend.RTLgen]
-transl_function [in backend.Cminorgen]
-transl_function [in backend.PPCgen]
-transl_function [in backend.RTLgen]
-transl_function_correct [in backend.RTLgenproof]
-transl_instr [in backend.PPCgen]
-transl_instr [in backend.Stacking]
-transl_load_store [in backend.PPCgen]
-transl_op [in backend.Stacking]
-transl_op [in backend.PPCgen]
-transl_program [in backend.RTLgen]
-transl_program [in backend.Cminorgen]
-transl_stmt [in backend.Cminorgen]
-transl_stmt [in backend.RTLgen]
-transl_stmtlist_correct [in backend.RTLgenproof]
-transl_stmtlist_incr_pred [in backend.RTLgenproof1]
-transl_stmt_correct [in backend.RTLgenproof]
-transl_stmt_incr_pred [in backend.RTLgenproof1]
-tunneled_code [in backend.Tunnelingproof]
-tunnel_block [in backend.Tunneling]
-tunnel_function [in backend.Tunneling]
-tunnel_outcome [in backend.Tunnelingproof]
-tunnel_program [in backend.Tunneling]
-type [in backend.Locations]
-typenv [in backend.Registers]
-typesize [in backend.AST]
-typesize [in backend.Locations]
-type_of_addressing [in backend.Op]
-type_of_chunk [in backend.Op]
-type_of_condition [in backend.Op]
-type_of_index [in backend.Stackingproof]
-type_of_operation [in backend.Op]
-type_of_sig_res [in backend.RTLtyping]
-type_rtl_arg [in backend.RTLtyping]
-type_rtl_function [in backend.RTLtyping]
-type_rtl_instr [in backend.RTLtyping]
-type_rtl_ros [in backend.RTLtyping]
-

U

-unchecked_store [in backend.Mem]
-union [in lib.Sets]
-unique_labels [in backend.Linearizeproof]
-unsigned [in lib.Integers]
-update [in backend.Mem]
-update [in backend.Parallelmove]
-update_instr [in backend.RTLgen]
-

V

-valid_block [in backend.Mem]
-valid_outcome [in backend.Linearizeproof]
-valid_pointer [in backend.Mem]
-valnum [in backend.CSE]
-valnum_reg [in backend.CSE]
-valnum_regs [in backend.CSE]
-Value [in backend.Parallelmove]
-valu_agree [in backend.CSEproof]
-val_cond_reg [in backend.PPC]
-val_match_approx [in backend.Constpropproof]
-val_normalized [in backend.Cminorgenproof]
-var_addr [in backend.Cminorgen]
-var_get [in backend.Cminorgen]
-var_set [in backend.Cminorgen]
-Vfalse [in backend.Values]
-Vmone [in backend.Values]
-Vone [in backend.Values]
-Vtrue [in backend.Values]
-Vzero [in backend.Values]
-

W

-wf_equation [in backend.CSEproof]
-wf_numbering [in backend.CSEproof]
-wf_rhs [in backend.CSEproof]
-wordsize [in lib.Integers]
-wt_content [in backend.Machtyping]
-wt_frame [in backend.Machtyping]
-wt_function [in backend.LTLtyping]
-wt_function [in backend.Lineartyping]
-wt_instrs [in backend.Stackingtyping]
-wt_program [in backend.Lineartyping]
-wt_program [in backend.RTLtyping]
-wt_program [in backend.LTLtyping]
-wt_program [in backend.Machtyping]
-wt_regset [in backend.RTLtyping]
-wt_regset [in backend.Machtyping]
-

X

-xcombine_l [in lib.Maps]
-xcombine_r [in lib.Maps]
-xelements [in lib.Maps]
-xget [in lib.Maps]
-xkeys [in lib.Maps]
-xmap [in lib.Maps]
-xor [in backend.Cmconstr]
-xor [in backend.Values]
-xor [in lib.Integers]
-xorimm [in backend.PPCgen]
-

Z

-Zdiv_round [in lib.Integers]
-zeq [in lib.Coqlib]
-zero [in lib.Integers]
-zle [in lib.Coqlib]
-zlt [in lib.Coqlib]
-Zmod_round [in lib.Integers]
-ztonat [in backend.Mem]
-Z_bin_decomp [in lib.Integers]
-Z_of_bits [in lib.Integers]
-Z_one_bits [in lib.Integers]
-Z_shift_add [in lib.Integers]
-

-

Module Index

-

A

-Approx [in backend.Constprop]
-

B

-BACKWARD_DATAFLOW_SOLVER [in backend.Kildall]
-Backward_Dataflow_Solver [in backend.Kildall]
-BBlock_solver [in backend.Kildall]
-BBLOCK_SOLVER [in backend.Kildall]
-

D

-D [in backend.Constprop]
-Dataflow_Solver [in backend.Kildall]
-DATAFLOW_SOLVER [in backend.Kildall]
-DS [in backend.Kildall]
-DS [in backend.Constprop]
-DS [in backend.Linearize]
-DS [in backend.Allocation]
-

E

-ELEMENT [in lib.union_find]
-EMap [in lib.Maps]
-EQUALITY_TYPE [in lib.Maps]
-

F

-Float [in lib.Floats]
-

G

-Genv [in backend.Globalenvs]
-GENV [in backend.Globalenvs]
-

I

-Identset [in backend.Cminorgen]
-IMap [in lib.Maps]
-IndexedMreg [in backend.Locations]
-INDEXED_TYPE [in lib.Maps]
-Int [in lib.Integers]
-

L

-L [in backend.Kildall]
-L [in backend.Kildall]
-L [in backend.Kildall]
-L [in backend.Kildall]
-L [in backend.Kildall]
-L [in backend.Kildall]
-L [in backend.Kildall]
-L [in backend.Kildall]
-L [in backend.Kildall]
-LBoolean [in lib.Lattice]
-LFlat [in lib.Lattice]
-Loc [in backend.Locations]
-Locmap [in backend.Locations]
-LPMap [in lib.Lattice]
-

M

-MakeSet [in lib.Sets]
-MAP [in lib.Maps]
-MAP [in lib.union_find]
-mymap [in backend.RTLtyping]
-myreg [in backend.RTLtyping]
-

N

-NIndexed [in lib.Maps]
-NMap [in lib.Maps]
-Numbering [in backend.CSE]
-

O

-OrderedIndexed [in lib.Ordered]
-OrderedMreg [in backend.InterfGraph]
-OrderedPair [in lib.Ordered]
-OrderedPositive [in lib.Ordered]
-OrderedReg [in backend.InterfGraph]
-OrderedRegMreg [in backend.InterfGraph]
-OrderedRegReg [in backend.InterfGraph]
-ORDERED_TYPE_WITH_TOP [in backend.Kildall]
-

P

-PMap [in lib.Maps]
-PregEq [in backend.PPC]
-Pregmap [in backend.PPC]
-PTree [in lib.Maps]
-

R

-Reg [in backend.Registers]
-RegEq [in backend.Mach]
-Regmap [in backend.Mach]
-Regmap [in backend.Registers]
-Regset [in backend.Registers]
-

S

-SEMILATTICE [in lib.Lattice]
-SEMILATTICE_WITH_TOP [in lib.Lattice]
-SetDepRegMreg [in backend.InterfGraph]
-SetDepRegReg [in backend.InterfGraph]
-SetRegMreg [in backend.InterfGraph]
-SetRegReg [in backend.InterfGraph]
-Solver [in backend.CSE]
-

T

-TREE [in lib.Maps]
-

U

-Uf [in backend.RTLtyping]
-UNIONFIND [in lib.union_find]
-Unionfind [in lib.union_find]
-

V

-Val [in backend.Values]
-ValnumEq [in backend.CSEproof]
-VMap [in backend.CSEproof]
-

Z

-ZIndexed [in lib.Maps]
-ZMap [in lib.Maps]
-

-

Library Index

-

A

-Allocation
-Allocproof
-Allocproof_aux
-Alloctyping
-Alloctyping_aux
-AST
-

C

-Cmconstr
-Cmconstrproof
-Cminor
-Cminorgen
-Cminorgenproof
-Coloring
-Coloringproof
-Constprop
-Constpropproof
-Conventions
-Coqlib
-CSE
-CSEproof
-Csharpminor
-

F

-Floats
-

G

-Globalenvs
-

I

-Inclusion
-Integers
-InterfGraph
-

K

-Kildall
-

L

-Lattice
-Linear
-Linearize
-Linearizeproof
-Linearizetyping
-Lineartyping
-Locations
-LTL
-LTLtyping
-

M

-Mach
-Machabstr
-Machabstr2mach
-Machtyping
-Main
-Maps
-Mem
-

O

-Op
-Ordered
-

P

-Parallelmove
-PPC
-PPCgen
-PPCgenproof
-PPCgenproof1
-

R

-Registers
-RTL
-RTLgen
-RTLgenproof
-RTLgenproof1
-RTLtyping
-

S

-Sets
-Stacking
-Stackingproof
-Stackingtyping
-

T

-Tunneling
-Tunnelingproof
-Tunnelingtyping
-

U

-union_find
-

V

-Values
-

- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Global IndexABCDEFGHIJKLMNOPQRSTUVWXYZ_(3806 entries)
Axiom IndexABCDEFGHIJKLMNOPQRSTUVWXYZ_(39 entries)
Lemma IndexABCDEFGHIJKLMNOPQRSTUVWXYZ_(1753 entries)
Constructor IndexABCDEFGHIJKLMNOPQRSTUVWXYZ_(700 entries)
Inductive IndexABCDEFGHIJKLMNOPQRSTUVWXYZ_(155 entries)
Definition IndexABCDEFGHIJKLMNOPQRSTUVWXYZ_(1017 entries)
Module IndexABCDEFGHIJKLMNOPQRSTUVWXYZ_(78 entries)
Library IndexABCDEFGHIJKLMNOPQRSTUVWXYZ_(64 entries)
-
This page has been generated by coqdoc - - \ No newline at end of file + + + + +

The Compcert certified compiler back-end

+

Commented Coq development

+

Version 0.2, 2006-01-07

+ +

Introduction

+ +

The Compcert back-end is a compiler that generates PowerPC assembly +code from a low-level intermediate language called Cminor and a +slightly more expressive intermediate language called Csharpminor. +The particularity of this compiler is that it is written mostly within +the specification language of the Coq proof assistant, and its +correctness --- the fact that the generated assembly code is +semantically equivalent to its source program --- was entirely proved +within the Coq proof assistant.

+ +

A high-level overview of the Compcert back-end and its proof of +correctness can be found in the following paper:

+Xavier Leroy, Formal +certification of a compiler back-end, or: programming a compiler with +a proof assistant. Proceedings of the POPL 2006 symposium. + +

This Web site gives a commented listing of the underlying Coq +specifications and proofs. Proof scripts and the parts of the +compiler written directly in Caml are omitted. This development is a +work in progress; some parts may have changed since the overview paper +above was written.

+ +

This document and all Coq source files referenced from it are +copyright 2005, 2006 Institut National de Recherche en Informatique et +en Automatique (INRIA) and distributed under the terms of the GNU General Public +License version 2.

+ +

Table of contents

+ +

General-purpose libraries, data structures and algorithms

+ + + +

Definitions and properties used in many parts of the development

+ + + +

Source, intermediate and target languages: syntax and semantics

+ + + +

Compiler passes

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
PassSource & targetCompiler codeCorrectness proof
Recognition of operators
and addressing modes		Cminor to CminorSelSelectionSelectionproof
Construction of the CFG,
3-address code generation		Cminor to RTLRTLgenRTLgenspec
+ RTLgenproof
Constant propagationRTL to RTLConstpropConstpropproof
Common subexpression eliminationRTL to RTLCSECSEproof
Register allocation by coloring
of an interference graph		RTL to LTLInterfGraph
+ Coloring
+ Allocation
+ Coloringproof
+ Allocproof
Branch tunnelingLTL to LTLTunnelingTunnelingproof
Linearization of the CFGLTL to LTLinLinearizeLinearizeproof
Spilling, reloading, calling conventionsLTLin to LinearConventions
+ Reload		Parallelmove
+ Reloadproof
Laying out the activation recordsLinear to MachBounds
+ Stacking		Stackingproof
Storing the activation records in memoryMach to Mach(none) + PPCgenretaddr
+ Machabstr2mach
Emission of PowerPC assemblyMach to PPCPPCgenPPCgenproof1
+ PPCgenproof
+ +

Type systems

+ +Trivial type systems are used to statically capture well-formedness +conditions on the intermediate languages. + +Proofs that compiler passes are type-preserving: + + +

All together

+ + + +
+
Xavier.Leroy@inria.fr
+
+ + + diff --git a/doc/removeproofs b/doc/removeproofs index 0ebe3a8b..82809ba6 100755 --- a/doc/removeproofs +++ b/doc/removeproofs @@ -2,7 +2,7 @@ for i in $*; do mv $i $i.bak - sed -e '/Proof<\/code>\./,/Qed<\/code>\./d' $i.bak > $i + sed -e '/Proof<\/code> *\./,/\(Qed\|Defined\)<\/code> *\./d' $i.bak > $i rm $i.bak done diff --git a/doc/style.css b/doc/style.css index 9c1eb491..dced2fff 100644 --- a/doc/style.css +++ b/doc/style.css @@ -26,7 +26,9 @@ tr { background-color : White } # .doc { background-color :#66ff66 } .doc { margin-left: -5%; } .docright { margin-left: 40%; } -h1 { margin-left: -10%; text-align: right; } +div.doc code { color : #008000; font-weight: bold } +h1.libtitle { text-align: center; } +h1 { margin-left: -5%; } h2 { margin-left: -5%; } h3,h4,h5,h6 { margin-left: -3%; } hr { margin-left: -10%; margin-right:-10%; } diff --git a/extraction/.depend b/extraction/.depend index 53f84687..956c4d33 100644 --- a/extraction/.depend +++ b/extraction/.depend @@ -8,20 +8,20 @@ ../caml/CMlexer.cmi ../caml/CMlexer.cmx: ../caml/Camlcoq.cmx ../caml/CMparser.cmx \ ../caml/CMlexer.cmi -../caml/CMparser.cmo: Op.cmi Integers.cmi Datatypes.cmi Cminor.cmi \ - Cmconstr.cmi ../caml/Camlcoq.cmo CList.cmi BinPos.cmi BinInt.cmi AST.cmi \ +../caml/CMparser.cmo: Integers.cmi Datatypes.cmi Cminor.cmi \ + ../caml/Camlcoq.cmo CList.cmi BinPos.cmi BinInt.cmi AST.cmi \ ../caml/CMparser.cmi -../caml/CMparser.cmx: Op.cmx Integers.cmx Datatypes.cmx Cminor.cmx \ - Cmconstr.cmx ../caml/Camlcoq.cmx CList.cmx BinPos.cmx BinInt.cmx AST.cmx \ +../caml/CMparser.cmx: Integers.cmx Datatypes.cmx Cminor.cmx \ + ../caml/Camlcoq.cmx CList.cmx BinPos.cmx BinInt.cmx AST.cmx \ ../caml/CMparser.cmi ../caml/CMtypecheck.cmo: Op.cmi Integers.cmi Datatypes.cmi Cminor.cmi \ ../caml/Camlcoq.cmo CList.cmi AST.cmi ../caml/CMtypecheck.cmi ../caml/CMtypecheck.cmx: Op.cmx Integers.cmx Datatypes.cmx Cminor.cmx \ ../caml/Camlcoq.cmx CList.cmx AST.cmx ../caml/CMtypecheck.cmi -../caml/Camlcoq.cmo: Integers.cmi Datatypes.cmi CList.cmi BinPos.cmi \ - BinInt.cmi -../caml/Camlcoq.cmx: Integers.cmx Datatypes.cmx CList.cmx BinPos.cmx \ - BinInt.cmx +../caml/Camlcoq.cmo: Integers.cmi Datatypes.cmi CString.cmi CList.cmi \ + BinPos.cmi BinInt.cmi Ascii.cmi +../caml/Camlcoq.cmx: Integers.cmx Datatypes.cmx CString.cmx CList.cmx \ + BinPos.cmx BinInt.cmx Ascii.cmx ../caml/Cil2Csyntax.cmo: Datatypes.cmi Csyntax.cmi ../caml/Camlcoq.cmo \ CList.cmi AST.cmi ../caml/Cil2Csyntax.cmx: Datatypes.cmx Csyntax.cmx ../caml/Camlcoq.cmx \ @@ -35,15 +35,11 @@ ../caml/Floataux.cmo: Integers.cmi ../caml/Camlcoq.cmo ../caml/Floataux.cmx: Integers.cmx ../caml/Camlcoq.cmx ../caml/Main2.cmo: ../caml/PrintPPC.cmi ../caml/PrintCsyntax.cmo Main.cmi \ - Datatypes.cmi Csyntax.cmi ../caml/Cil2Csyntax.cmo ../caml/CMtypecheck.cmi \ + Errors.cmi Csyntax.cmi ../caml/Cil2Csyntax.cmo ../caml/CMtypecheck.cmi \ ../caml/CMparser.cmi ../caml/CMlexer.cmi ../caml/Main2.cmx: ../caml/PrintPPC.cmx ../caml/PrintCsyntax.cmx Main.cmx \ - Datatypes.cmx Csyntax.cmx ../caml/Cil2Csyntax.cmx ../caml/CMtypecheck.cmx \ + Errors.cmx Csyntax.cmx ../caml/Cil2Csyntax.cmx ../caml/CMtypecheck.cmx \ ../caml/CMparser.cmx ../caml/CMlexer.cmx -../caml/PrintCshm.cmo: Integers.cmi Datatypes.cmi Csharpminor.cmi \ - ../caml/Camlcoq.cmo CList.cmi AST.cmi -../caml/PrintCshm.cmx: Integers.cmx Datatypes.cmx Csharpminor.cmx \ - ../caml/Camlcoq.cmx CList.cmx AST.cmx ../caml/PrintCsyntax.cmo: Datatypes.cmi Csyntax.cmi ../caml/Camlcoq.cmo \ CList.cmi AST.cmi ../caml/PrintCsyntax.cmx: Datatypes.cmx Csyntax.cmx ../caml/Camlcoq.cmx \ @@ -52,32 +48,40 @@ AST.cmi ../caml/PrintPPC.cmi ../caml/PrintPPC.cmx: PPC.cmx Datatypes.cmx ../caml/Camlcoq.cmx CList.cmx \ AST.cmx ../caml/PrintPPC.cmi -../caml/RTLgenaux.cmo: Cminor.cmi -../caml/RTLgenaux.cmx: Cminor.cmx +../caml/RTLgenaux.cmo: Switch.cmi Integers.cmi Datatypes.cmi CminorSel.cmi \ + CList.cmi +../caml/RTLgenaux.cmx: Switch.cmx Integers.cmx Datatypes.cmx CminorSel.cmx \ + CList.cmx ../caml/RTLtypingaux.cmo: Registers.cmi RTL.cmi Op.cmi Maps.cmi Datatypes.cmi \ ../caml/Camlcoq.cmo CList.cmi AST.cmi ../caml/RTLtypingaux.cmx: Registers.cmx RTL.cmx Op.cmx Maps.cmx Datatypes.cmx \ ../caml/Camlcoq.cmx CList.cmx AST.cmx -AST.cmi: Specif.cmi Integers.cmi Floats.cmi Datatypes.cmi Coqlib.cmi \ - CList.cmi BinPos.cmi BinInt.cmi -Allocation.cmi: Specif.cmi Registers.cmi RTLtyping.cmi RTL.cmi \ - Parallelmove.cmi Op.cmi Maps.cmi Locations.cmi LTL.cmi Datatypes.cmi \ - Conventions.cmi Coloring.cmi CList.cmi BinPos.cmi AST.cmi +AST.cmi: Specif.cmi Integers.cmi Floats.cmi Errors.cmi Datatypes.cmi \ + Coqlib.cmi CString.cmi CList.cmi BinPos.cmi BinInt.cmi Ascii.cmi +Allocation.cmi: Specif.cmi Registers.cmi RTLtyping.cmi RTL.cmi Op.cmi \ + Maps.cmi Locations.cmi LTL.cmi Errors.cmi Datatypes.cmi Coloring.cmi \ + CString.cmi CList.cmi BinPos.cmi Ascii.cmi AST.cmi +Ascii.cmi: Specif.cmi Peano.cmi Datatypes.cmi Bool.cmi BinPos.cmi BinInt.cmi: Datatypes.cmi BinPos.cmi BinNat.cmi BinNat.cmi: Specif.cmi Datatypes.cmi BinPos.cmi BinPos.cmi: Peano.cmi Datatypes.cmi Bool.cmi: Specif.cmi Datatypes.cmi +Bounds.cmi: Zmax.cmi Locations.cmi Linear.cmi Conventions.cmi CList.cmi \ + BinPos.cmi BinInt.cmi AST.cmi CInt.cmi: Zmax.cmi ZArith_dec.cmi Specif.cmi BinPos.cmi BinInt.cmi CList.cmi: Specif.cmi Datatypes.cmi CSE.cmi: Specif.cmi Registers.cmi RTL.cmi Op.cmi Maps.cmi Integers.cmi \ Floats.cmi Datatypes.cmi Coqlib.cmi CList.cmi BinPos.cmi AST.cmi -Cmconstr.cmi: Specif.cmi Op.cmi Integers.cmi Datatypes.cmi Compare_dec.cmi \ - Cminor.cmi CList.cmi BinPos.cmi BinInt.cmi AST.cmi -Cminor.cmi: Values.cmi Op.cmi Maps.cmi Integers.cmi Globalenvs.cmi \ - Datatypes.cmi CList.cmi BinInt.cmi AST.cmi -Cminorgen.cmi: Zmax.cmi Specif.cmi OrderedType.cmi Ordered.cmi Op.cmi Mem.cmi \ - Maps.cmi Integers.cmi Datatypes.cmi Csharpminor.cmi Coqlib.cmi Cminor.cmi \ - Cmconstr.cmi CList.cmi CInt.cmi BinPos.cmi BinInt.cmi AST.cmi +CString.cmi: Specif.cmi Datatypes.cmi Ascii.cmi +Cminor.cmi: Values.cmi Specif.cmi Mem.cmi Maps.cmi Integers.cmi \ + Globalenvs.cmi Floats.cmi Datatypes.cmi CList.cmi BinPos.cmi BinInt.cmi \ + AST.cmi +CminorSel.cmi: Op.cmi Integers.cmi Globalenvs.cmi Datatypes.cmi CList.cmi \ + BinInt.cmi AST.cmi +Cminorgen.cmi: Zmax.cmi Specif.cmi OrderedType.cmi Ordered.cmi Mem.cmi \ + Maps.cmi Integers.cmi Errors.cmi Datatypes.cmi Csharpminor.cmi Coqlib.cmi \ + Cminor.cmi CString.cmi CList.cmi CInt.cmi BinPos.cmi BinInt.cmi Ascii.cmi \ + AST.cmi Coloring.cmi: Specif.cmi Registers.cmi RTLtyping.cmi RTL.cmi Op.cmi Maps.cmi \ Locations.cmi InterfGraph.cmi Datatypes.cmi Coqlib.cmi Conventions.cmi \ CList.cmi BinInt.cmi AST.cmi @@ -88,15 +92,19 @@ Conventions.cmi: Locations.cmi Datatypes.cmi Coqlib.cmi CList.cmi BinPos.cmi \ BinInt.cmi AST.cmi Coqlib.cmi: Zdiv.cmi ZArith_dec.cmi Wf.cmi Specif.cmi Datatypes.cmi CList.cmi \ BinPos.cmi BinInt.cmi -Csharpminor.cmi: Zmax.cmi Values.cmi Specif.cmi Mem.cmi Maps.cmi Integers.cmi \ - Globalenvs.cmi Floats.cmi Datatypes.cmi CList.cmi BinPos.cmi BinInt.cmi \ +Csharpminor.cmi: Zmax.cmi Values.cmi Mem.cmi Maps.cmi Integers.cmi \ + Globalenvs.cmi Floats.cmi Datatypes.cmi Cminor.cmi CList.cmi BinInt.cmi \ AST.cmi -Cshmgen.cmi: Peano.cmi Integers.cmi Floats.cmi Datatypes.cmi Csyntax.cmi \ - Csharpminor.cmi CList.cmi AST.cmi -Csyntax.cmi: Zmax.cmi Specif.cmi Integers.cmi Floats.cmi Datatypes.cmi \ - Coqlib.cmi CList.cmi BinPos.cmi BinInt.cmi AST.cmi +Cshmgen.cmi: Peano.cmi Integers.cmi Floats.cmi Errors.cmi Datatypes.cmi \ + Csyntax.cmi Csharpminor.cmi Cminor.cmi CString.cmi CList.cmi Ascii.cmi \ + AST.cmi +Csyntax.cmi: Zmax.cmi Specif.cmi Integers.cmi Floats.cmi Errors.cmi \ + Datatypes.cmi Coqlib.cmi CString.cmi CList.cmi BinPos.cmi BinInt.cmi \ + Ascii.cmi AST.cmi Ctyping.cmi: Specif.cmi Maps.cmi Datatypes.cmi Csyntax.cmi Coqlib.cmi \ CList.cmi AST.cmi +EqNat.cmi: Specif.cmi Datatypes.cmi +Errors.cmi: Datatypes.cmi CString.cmi CList.cmi BinPos.cmi FSetAVL.cmi: Wf.cmi Specif.cmi Peano.cmi OrderedType.cmi Datatypes.cmi \ CList.cmi CInt.cmi BinPos.cmi BinInt.cmi FSetFacts.cmi: Specif.cmi Setoid.cmi FSetInterface.cmi Datatypes.cmi @@ -110,34 +118,36 @@ Integers.cmi: Zpower.cmi Zdiv.cmi Specif.cmi Datatypes.cmi Coqlib.cmi \ InterfGraph.cmi: Specif.cmi Registers.cmi OrderedType.cmi Locations.cmi \ Datatypes.cmi Coqlib.cmi CList.cmi CInt.cmi BinPos.cmi BinInt.cmi Iteration.cmi: Wf.cmi Specif.cmi Datatypes.cmi Coqlib.cmi BinPos.cmi -Kildall.cmi: Specif.cmi Setoid.cmi OrderedType.cmi Maps.cmi Lattice.cmi \ - Iteration.cmi Datatypes.cmi Coqlib.cmi CList.cmi CInt.cmi BinPos.cmi \ - BinInt.cmi -LTL.cmi: Values.cmi Specif.cmi Op.cmi Maps.cmi Locations.cmi Integers.cmi \ - Globalenvs.cmi Datatypes.cmi Conventions.cmi CList.cmi BinPos.cmi \ - BinInt.cmi AST.cmi +Kildall.cmi: Specif.cmi Setoid.cmi OrderedType.cmi Ordered.cmi Maps.cmi \ + Lattice.cmi Iteration.cmi Datatypes.cmi Coqlib.cmi CList.cmi CInt.cmi \ + BinPos.cmi BinInt.cmi +LTL.cmi: Values.cmi Specif.cmi Op.cmi Mem.cmi Maps.cmi Locations.cmi \ + Integers.cmi Globalenvs.cmi Datatypes.cmi Conventions.cmi CList.cmi \ + BinPos.cmi BinInt.cmi AST.cmi +LTLin.cmi: Values.cmi Specif.cmi Op.cmi Mem.cmi Locations.cmi Integers.cmi \ + Globalenvs.cmi Datatypes.cmi Coqlib.cmi CList.cmi BinPos.cmi BinInt.cmi \ + AST.cmi Lattice.cmi: Specif.cmi Maps.cmi FSetInterface.cmi Datatypes.cmi Bool.cmi \ BinPos.cmi -Linear.cmi: Values.cmi Specif.cmi Op.cmi Locations.cmi Integers.cmi \ +Linear.cmi: Values.cmi Specif.cmi Op.cmi Mem.cmi Locations.cmi Integers.cmi \ Globalenvs.cmi Datatypes.cmi Coqlib.cmi CList.cmi BinPos.cmi BinInt.cmi \ AST.cmi -Linearize.cmi: Specif.cmi Op.cmi Maps.cmi Linear.cmi Lattice.cmi LTL.cmi \ +Linearize.cmi: Specif.cmi Op.cmi Maps.cmi Lattice.cmi LTLin.cmi LTL.cmi \ Datatypes.cmi Coqlib.cmi CList.cmi BinPos.cmi AST.cmi -Lineartyping.cmi: Zmax.cmi Locations.cmi Linear.cmi Datatypes.cmi \ - Conventions.cmi CList.cmi BinPos.cmi BinInt.cmi AST.cmi Locations.cmi: Values.cmi Specif.cmi Datatypes.cmi Coqlib.cmi BinPos.cmi \ BinInt.cmi AST.cmi -Mach.cmi: Zmax.cmi Zdiv.cmi Values.cmi Specif.cmi Op.cmi Mem.cmi \ - Locations.cmi Integers.cmi Globalenvs.cmi Datatypes.cmi Coqlib.cmi \ - CList.cmi BinPos.cmi BinInt.cmi AST.cmi -Main.cmi: Tunneling.cmi Stacking.cmi RTLgen.cmi PPCgen.cmi PPC.cmi \ - Linearize.cmi Datatypes.cmi Ctyping.cmi Csyntax.cmi Cshmgen.cmi \ - Constprop.cmi Cminorgen.cmi Cminor.cmi CSE.cmi Allocation.cmi AST.cmi +Mach.cmi: Zmax.cmi Zdiv.cmi Values.cmi Specif.cmi Op.cmi Locations.cmi \ + Integers.cmi Globalenvs.cmi Datatypes.cmi Coqlib.cmi CList.cmi BinPos.cmi \ + BinInt.cmi AST.cmi +Main.cmi: Tunneling.cmi Stacking.cmi Selection.cmi Reload.cmi RTLgen.cmi \ + RTL.cmi PPCgen.cmi PPC.cmi Linearize.cmi Errors.cmi Datatypes.cmi \ + Ctyping.cmi Csyntax.cmi Cshmgen.cmi Constprop.cmi Cminorgen.cmi \ + Cminor.cmi CString.cmi CSE.cmi Ascii.cmi Allocation.cmi AST.cmi Maps.cmi: Specif.cmi Datatypes.cmi Coqlib.cmi CList.cmi BinPos.cmi BinNat.cmi \ BinInt.cmi Mem.cmi: Zmax.cmi Values.cmi Specif.cmi Integers.cmi Datatypes.cmi Coqlib.cmi \ CList.cmi BinPos.cmi BinInt.cmi AST.cmi -Op.cmi: Values.cmi Specif.cmi Integers.cmi Globalenvs.cmi Floats.cmi \ +Op.cmi: Values.cmi Specif.cmi Mem.cmi Integers.cmi Globalenvs.cmi Floats.cmi \ Datatypes.cmi CList.cmi Bool.cmi BinPos.cmi BinInt.cmi AST.cmi Ordered.cmi: Specif.cmi OrderedType.cmi Maps.cmi Datatypes.cmi Coqlib.cmi \ BinPos.cmi @@ -145,24 +155,32 @@ OrderedType.cmi: Specif.cmi Datatypes.cmi PPC.cmi: Values.cmi Specif.cmi Mem.cmi Integers.cmi Globalenvs.cmi Floats.cmi \ Datatypes.cmi Coqlib.cmi CList.cmi BinPos.cmi BinInt.cmi AST.cmi PPCgen.cmi: Specif.cmi PPC.cmi Op.cmi Mach.cmi Locations.cmi Integers.cmi \ - Datatypes.cmi Coqlib.cmi CList.cmi Bool.cmi BinPos.cmi BinInt.cmi AST.cmi + Errors.cmi Datatypes.cmi Coqlib.cmi CString.cmi CList.cmi Bool.cmi \ + BinPos.cmi BinInt.cmi Ascii.cmi AST.cmi Parallelmove.cmi: Parmov.cmi Locations.cmi Datatypes.cmi CList.cmi AST.cmi Parmov.cmi: Specif.cmi Peano.cmi Datatypes.cmi CList.cmi Peano.cmi: Datatypes.cmi -RTL.cmi: Values.cmi Registers.cmi Op.cmi Maps.cmi Integers.cmi Globalenvs.cmi \ - Datatypes.cmi CList.cmi BinPos.cmi BinInt.cmi AST.cmi -RTLgen.cmi: Specif.cmi Registers.cmi RTL.cmi Op.cmi Maps.cmi Integers.cmi \ - Datatypes.cmi Coqlib.cmi Cminor.cmi CList.cmi BinPos.cmi AST.cmi -RTLtyping.cmi: Specif.cmi Registers.cmi RTL.cmi Op.cmi Maps.cmi Datatypes.cmi \ - Coqlib.cmi CList.cmi AST.cmi +RTL.cmi: Values.cmi Registers.cmi Op.cmi Mem.cmi Maps.cmi Integers.cmi \ + Globalenvs.cmi Datatypes.cmi CList.cmi BinPos.cmi BinInt.cmi AST.cmi +RTLgen.cmi: Switch.cmi Specif.cmi Registers.cmi RTL.cmi Op.cmi Maps.cmi \ + Integers.cmi Errors.cmi Datatypes.cmi Coqlib.cmi CminorSel.cmi \ + CString.cmi CList.cmi BinPos.cmi Ascii.cmi AST.cmi +RTLtyping.cmi: Specif.cmi Registers.cmi RTL.cmi Op.cmi Maps.cmi Errors.cmi \ + Datatypes.cmi Coqlib.cmi Conventions.cmi CString.cmi CList.cmi BinPos.cmi \ + BinInt.cmi Ascii.cmi AST.cmi Registers.cmi: Specif.cmi OrderedType.cmi Ordered.cmi Maps.cmi Datatypes.cmi \ Coqlib.cmi CList.cmi CInt.cmi BinPos.cmi BinInt.cmi AST.cmi +Reload.cmi: Specif.cmi Parallelmove.cmi Op.cmi Locations.cmi Linear.cmi \ + LTLin.cmi Datatypes.cmi Conventions.cmi CList.cmi AST.cmi +Selection.cmi: Specif.cmi Op.cmi Integers.cmi Datatypes.cmi Compare_dec.cmi \ + CminorSel.cmi Cminor.cmi CList.cmi BinPos.cmi BinInt.cmi AST.cmi Setoid.cmi: Datatypes.cmi Specif.cmi: Datatypes.cmi -Stacking.cmi: Specif.cmi Op.cmi Mach.cmi Locations.cmi Lineartyping.cmi \ - Linear.cmi Integers.cmi Datatypes.cmi Coqlib.cmi Conventions.cmi \ - CList.cmi BinPos.cmi BinInt.cmi AST.cmi +Stacking.cmi: Specif.cmi Op.cmi Mach.cmi Locations.cmi Linear.cmi \ + Integers.cmi Errors.cmi Datatypes.cmi Coqlib.cmi Conventions.cmi \ + CString.cmi CList.cmi Bounds.cmi BinPos.cmi BinInt.cmi Ascii.cmi AST.cmi Sumbool.cmi: Specif.cmi Datatypes.cmi +Switch.cmi: Integers.cmi EqNat.cmi Datatypes.cmi CList.cmi Tunneling.cmi: Maps.cmi LTL.cmi Datatypes.cmi AST.cmi Values.cmi: Specif.cmi Integers.cmi Floats.cmi Datatypes.cmi Coqlib.cmi \ BinPos.cmi BinInt.cmi AST.cmi @@ -175,18 +193,20 @@ Zeven.cmi: Specif.cmi Datatypes.cmi BinPos.cmi BinInt.cmi Zmax.cmi: Datatypes.cmi BinInt.cmi Zmisc.cmi: Datatypes.cmi BinPos.cmi BinInt.cmi Zpower.cmi: Zmisc.cmi Datatypes.cmi BinPos.cmi BinInt.cmi -AST.cmo: Specif.cmi Integers.cmi Floats.cmi Datatypes.cmi Coqlib.cmi \ - CList.cmi BinPos.cmi BinInt.cmi AST.cmi -AST.cmx: Specif.cmx Integers.cmx Floats.cmx Datatypes.cmx Coqlib.cmx \ - CList.cmx BinPos.cmx BinInt.cmx AST.cmi -Allocation.cmo: Specif.cmi Registers.cmi RTLtyping.cmi RTL.cmi \ - Parallelmove.cmi Op.cmi Maps.cmi Locations.cmi Lattice.cmi LTL.cmi \ - Kildall.cmi Datatypes.cmi Conventions.cmi Coloring.cmi CList.cmi \ - BinPos.cmi AST.cmi Allocation.cmi -Allocation.cmx: Specif.cmx Registers.cmx RTLtyping.cmx RTL.cmx \ - Parallelmove.cmx Op.cmx Maps.cmx Locations.cmx Lattice.cmx LTL.cmx \ - Kildall.cmx Datatypes.cmx Conventions.cmx Coloring.cmx CList.cmx \ - BinPos.cmx AST.cmx Allocation.cmi +AST.cmo: Specif.cmi Integers.cmi Floats.cmi Errors.cmi Datatypes.cmi \ + Coqlib.cmi CString.cmi CList.cmi BinPos.cmi BinInt.cmi Ascii.cmi AST.cmi +AST.cmx: Specif.cmx Integers.cmx Floats.cmx Errors.cmx Datatypes.cmx \ + Coqlib.cmx CString.cmx CList.cmx BinPos.cmx BinInt.cmx Ascii.cmx AST.cmi +Allocation.cmo: Specif.cmi Registers.cmi RTLtyping.cmi RTL.cmi Op.cmi \ + Maps.cmi Locations.cmi Lattice.cmi LTL.cmi Kildall.cmi Errors.cmi \ + Datatypes.cmi Coloring.cmi CString.cmi CList.cmi BinPos.cmi Ascii.cmi \ + AST.cmi Allocation.cmi +Allocation.cmx: Specif.cmx Registers.cmx RTLtyping.cmx RTL.cmx Op.cmx \ + Maps.cmx Locations.cmx Lattice.cmx LTL.cmx Kildall.cmx Errors.cmx \ + Datatypes.cmx Coloring.cmx CString.cmx CList.cmx BinPos.cmx Ascii.cmx \ + AST.cmx Allocation.cmi +Ascii.cmo: Specif.cmi Peano.cmi Datatypes.cmi Bool.cmi BinPos.cmi Ascii.cmi +Ascii.cmx: Specif.cmx Peano.cmx Datatypes.cmx Bool.cmx BinPos.cmx Ascii.cmi BinInt.cmo: Datatypes.cmi BinPos.cmi BinNat.cmi BinInt.cmi BinInt.cmx: Datatypes.cmx BinPos.cmx BinNat.cmx BinInt.cmi BinNat.cmo: Specif.cmi Datatypes.cmi BinPos.cmi BinNat.cmi @@ -195,6 +215,10 @@ BinPos.cmo: Peano.cmi Datatypes.cmi BinPos.cmi BinPos.cmx: Peano.cmx Datatypes.cmx BinPos.cmi Bool.cmo: Specif.cmi Datatypes.cmi Bool.cmi Bool.cmx: Specif.cmx Datatypes.cmx Bool.cmi +Bounds.cmo: Zmax.cmi Locations.cmi Linear.cmi Conventions.cmi CList.cmi \ + BinPos.cmi BinInt.cmi AST.cmi Bounds.cmi +Bounds.cmx: Zmax.cmx Locations.cmx Linear.cmx Conventions.cmx CList.cmx \ + BinPos.cmx BinInt.cmx AST.cmx Bounds.cmi CInt.cmo: Zmax.cmi ZArith_dec.cmi Specif.cmi BinPos.cmi BinInt.cmi CInt.cmi CInt.cmx: Zmax.cmx ZArith_dec.cmx Specif.cmx BinPos.cmx BinInt.cmx CInt.cmi CList.cmo: Specif.cmi Datatypes.cmi CList.cmi @@ -205,22 +229,26 @@ CSE.cmo: Specif.cmi Registers.cmi RTL.cmi Op.cmi Maps.cmi Kildall.cmi \ CSE.cmx: Specif.cmx Registers.cmx RTL.cmx Op.cmx Maps.cmx Kildall.cmx \ Integers.cmx Floats.cmx Datatypes.cmx Coqlib.cmx CList.cmx BinPos.cmx \ AST.cmx CSE.cmi -Cmconstr.cmo: Specif.cmi Op.cmi Integers.cmi Datatypes.cmi Compare_dec.cmi \ - Cminor.cmi CList.cmi BinPos.cmi BinInt.cmi AST.cmi Cmconstr.cmi -Cmconstr.cmx: Specif.cmx Op.cmx Integers.cmx Datatypes.cmx Compare_dec.cmx \ - Cminor.cmx CList.cmx BinPos.cmx BinInt.cmx AST.cmx Cmconstr.cmi -Cminor.cmo: Values.cmi Op.cmi Maps.cmi Integers.cmi Globalenvs.cmi \ - Datatypes.cmi CList.cmi BinInt.cmi AST.cmi Cminor.cmi -Cminor.cmx: Values.cmx Op.cmx Maps.cmx Integers.cmx Globalenvs.cmx \ - Datatypes.cmx CList.cmx BinInt.cmx AST.cmx Cminor.cmi -Cminorgen.cmo: Zmax.cmi Specif.cmi OrderedType.cmi Ordered.cmi Op.cmi Mem.cmi \ - Maps.cmi Integers.cmi FSetAVL.cmi Datatypes.cmi Csharpminor.cmi \ - Coqlib.cmi Cminor.cmi Cmconstr.cmi CList.cmi BinPos.cmi BinInt.cmi \ - AST.cmi Cminorgen.cmi -Cminorgen.cmx: Zmax.cmx Specif.cmx OrderedType.cmx Ordered.cmx Op.cmx Mem.cmx \ - Maps.cmx Integers.cmx FSetAVL.cmx Datatypes.cmx Csharpminor.cmx \ - Coqlib.cmx Cminor.cmx Cmconstr.cmx CList.cmx BinPos.cmx BinInt.cmx \ - AST.cmx Cminorgen.cmi +CString.cmo: Specif.cmi Datatypes.cmi Ascii.cmi CString.cmi +CString.cmx: Specif.cmx Datatypes.cmx Ascii.cmx CString.cmi +Cminor.cmo: Values.cmi Specif.cmi Mem.cmi Maps.cmi Integers.cmi \ + Globalenvs.cmi Floats.cmi Datatypes.cmi CList.cmi BinPos.cmi BinInt.cmi \ + AST.cmi Cminor.cmi +Cminor.cmx: Values.cmx Specif.cmx Mem.cmx Maps.cmx Integers.cmx \ + Globalenvs.cmx Floats.cmx Datatypes.cmx CList.cmx BinPos.cmx BinInt.cmx \ + AST.cmx Cminor.cmi +CminorSel.cmo: Op.cmi Integers.cmi Globalenvs.cmi Datatypes.cmi CList.cmi \ + BinInt.cmi AST.cmi CminorSel.cmi +CminorSel.cmx: Op.cmx Integers.cmx Globalenvs.cmx Datatypes.cmx CList.cmx \ + BinInt.cmx AST.cmx CminorSel.cmi +Cminorgen.cmo: Zmax.cmi Specif.cmi OrderedType.cmi Ordered.cmi Mem.cmi \ + Maps.cmi Integers.cmi FSetAVL.cmi Errors.cmi Datatypes.cmi \ + Csharpminor.cmi Coqlib.cmi Cminor.cmi CString.cmi CList.cmi BinPos.cmi \ + BinInt.cmi Ascii.cmi AST.cmi Cminorgen.cmi +Cminorgen.cmx: Zmax.cmx Specif.cmx OrderedType.cmx Ordered.cmx Mem.cmx \ + Maps.cmx Integers.cmx FSetAVL.cmx Errors.cmx Datatypes.cmx \ + Csharpminor.cmx Coqlib.cmx Cminor.cmx CString.cmx CList.cmx BinPos.cmx \ + BinInt.cmx Ascii.cmx AST.cmx Cminorgen.cmi Coloring.cmo: Specif.cmi Registers.cmi RTLtyping.cmi RTL.cmi Op.cmi Maps.cmi \ Locations.cmi InterfGraph.cmi Datatypes.cmi Coqlib.cmi Conventions.cmi \ ../caml/Coloringaux.cmi CList.cmi BinInt.cmi AST.cmi Coloring.cmi @@ -243,26 +271,34 @@ Coqlib.cmo: Zdiv.cmi ZArith_dec.cmi Wf.cmi Specif.cmi Datatypes.cmi CList.cmi \ BinPos.cmi BinInt.cmi Coqlib.cmi Coqlib.cmx: Zdiv.cmx ZArith_dec.cmx Wf.cmx Specif.cmx Datatypes.cmx CList.cmx \ BinPos.cmx BinInt.cmx Coqlib.cmi -Csharpminor.cmo: Zmax.cmi Values.cmi Specif.cmi Mem.cmi Maps.cmi Integers.cmi \ - Globalenvs.cmi Floats.cmi Datatypes.cmi CList.cmi BinPos.cmi BinInt.cmi \ +Csharpminor.cmo: Zmax.cmi Values.cmi Mem.cmi Maps.cmi Integers.cmi \ + Globalenvs.cmi Floats.cmi Datatypes.cmi Cminor.cmi CList.cmi BinInt.cmi \ AST.cmi Csharpminor.cmi -Csharpminor.cmx: Zmax.cmx Values.cmx Specif.cmx Mem.cmx Maps.cmx Integers.cmx \ - Globalenvs.cmx Floats.cmx Datatypes.cmx CList.cmx BinPos.cmx BinInt.cmx \ +Csharpminor.cmx: Zmax.cmx Values.cmx Mem.cmx Maps.cmx Integers.cmx \ + Globalenvs.cmx Floats.cmx Datatypes.cmx Cminor.cmx CList.cmx BinInt.cmx \ AST.cmx Csharpminor.cmi -Cshmgen.cmo: Peano.cmi Integers.cmi Floats.cmi Datatypes.cmi Csyntax.cmi \ - Csharpminor.cmi CList.cmi AST.cmi Cshmgen.cmi -Cshmgen.cmx: Peano.cmx Integers.cmx Floats.cmx Datatypes.cmx Csyntax.cmx \ - Csharpminor.cmx CList.cmx AST.cmx Cshmgen.cmi -Csyntax.cmo: Zmax.cmi Specif.cmi Integers.cmi Floats.cmi Datatypes.cmi \ - Coqlib.cmi CList.cmi BinPos.cmi BinInt.cmi AST.cmi Csyntax.cmi -Csyntax.cmx: Zmax.cmx Specif.cmx Integers.cmx Floats.cmx Datatypes.cmx \ - Coqlib.cmx CList.cmx BinPos.cmx BinInt.cmx AST.cmx Csyntax.cmi +Cshmgen.cmo: Peano.cmi Integers.cmi Floats.cmi Errors.cmi Datatypes.cmi \ + Csyntax.cmi Csharpminor.cmi Cminor.cmi CString.cmi CList.cmi Ascii.cmi \ + AST.cmi Cshmgen.cmi +Cshmgen.cmx: Peano.cmx Integers.cmx Floats.cmx Errors.cmx Datatypes.cmx \ + Csyntax.cmx Csharpminor.cmx Cminor.cmx CString.cmx CList.cmx Ascii.cmx \ + AST.cmx Cshmgen.cmi +Csyntax.cmo: Zmax.cmi Specif.cmi Integers.cmi Floats.cmi Errors.cmi \ + Datatypes.cmi Coqlib.cmi CString.cmi CList.cmi BinPos.cmi BinInt.cmi \ + Ascii.cmi AST.cmi Csyntax.cmi +Csyntax.cmx: Zmax.cmx Specif.cmx Integers.cmx Floats.cmx Errors.cmx \ + Datatypes.cmx Coqlib.cmx CString.cmx CList.cmx BinPos.cmx BinInt.cmx \ + Ascii.cmx AST.cmx Csyntax.cmi Ctyping.cmo: Specif.cmi Maps.cmi Datatypes.cmi Csyntax.cmi Coqlib.cmi \ CList.cmi AST.cmi Ctyping.cmi Ctyping.cmx: Specif.cmx Maps.cmx Datatypes.cmx Csyntax.cmx Coqlib.cmx \ CList.cmx AST.cmx Ctyping.cmi Datatypes.cmo: Datatypes.cmi Datatypes.cmx: Datatypes.cmi +EqNat.cmo: Specif.cmi Datatypes.cmi EqNat.cmi +EqNat.cmx: Specif.cmx Datatypes.cmx EqNat.cmi +Errors.cmo: Datatypes.cmi CString.cmi CList.cmi BinPos.cmi Errors.cmi +Errors.cmx: Datatypes.cmx CString.cmx CList.cmx BinPos.cmx Errors.cmi FSetAVL.cmo: Wf.cmi Specif.cmi Peano.cmi OrderedType.cmi FSetList.cmi \ Datatypes.cmi CList.cmi CInt.cmi BinPos.cmi BinInt.cmi FSetAVL.cmi FSetAVL.cmx: Wf.cmx Specif.cmx Peano.cmx OrderedType.cmx FSetList.cmx \ @@ -299,58 +335,60 @@ Iteration.cmo: Wf.cmi Specif.cmi Datatypes.cmi Coqlib.cmi BinPos.cmi \ Iteration.cmi Iteration.cmx: Wf.cmx Specif.cmx Datatypes.cmx Coqlib.cmx BinPos.cmx \ Iteration.cmi -Kildall.cmo: Specif.cmi Setoid.cmi OrderedType.cmi Maps.cmi Lattice.cmi \ - Iteration.cmi FSetFacts.cmi FSetAVL.cmi Datatypes.cmi Coqlib.cmi \ - CList.cmi BinPos.cmi BinInt.cmi Kildall.cmi -Kildall.cmx: Specif.cmx Setoid.cmx OrderedType.cmx Maps.cmx Lattice.cmx \ - Iteration.cmx FSetFacts.cmx FSetAVL.cmx Datatypes.cmx Coqlib.cmx \ - CList.cmx BinPos.cmx BinInt.cmx Kildall.cmi -LTL.cmo: Values.cmi Specif.cmi Op.cmi Maps.cmi Locations.cmi Integers.cmi \ - Globalenvs.cmi Datatypes.cmi Conventions.cmi CList.cmi BinPos.cmi \ - BinInt.cmi AST.cmi LTL.cmi -LTL.cmx: Values.cmx Specif.cmx Op.cmx Maps.cmx Locations.cmx Integers.cmx \ - Globalenvs.cmx Datatypes.cmx Conventions.cmx CList.cmx BinPos.cmx \ - BinInt.cmx AST.cmx LTL.cmi +Kildall.cmo: Specif.cmi Setoid.cmi OrderedType.cmi Ordered.cmi Maps.cmi \ + Lattice.cmi Iteration.cmi FSetFacts.cmi FSetAVL.cmi Datatypes.cmi \ + Coqlib.cmi CList.cmi BinPos.cmi BinInt.cmi Kildall.cmi +Kildall.cmx: Specif.cmx Setoid.cmx OrderedType.cmx Ordered.cmx Maps.cmx \ + Lattice.cmx Iteration.cmx FSetFacts.cmx FSetAVL.cmx Datatypes.cmx \ + Coqlib.cmx CList.cmx BinPos.cmx BinInt.cmx Kildall.cmi +LTL.cmo: Values.cmi Specif.cmi Op.cmi Mem.cmi Maps.cmi Locations.cmi \ + Integers.cmi Globalenvs.cmi Datatypes.cmi Conventions.cmi CList.cmi \ + BinPos.cmi BinInt.cmi AST.cmi LTL.cmi +LTL.cmx: Values.cmx Specif.cmx Op.cmx Mem.cmx Maps.cmx Locations.cmx \ + Integers.cmx Globalenvs.cmx Datatypes.cmx Conventions.cmx CList.cmx \ + BinPos.cmx BinInt.cmx AST.cmx LTL.cmi +LTLin.cmo: Values.cmi Specif.cmi Op.cmi Mem.cmi Locations.cmi Integers.cmi \ + Globalenvs.cmi Datatypes.cmi Coqlib.cmi CList.cmi BinPos.cmi BinInt.cmi \ + AST.cmi LTLin.cmi +LTLin.cmx: Values.cmx Specif.cmx Op.cmx Mem.cmx Locations.cmx Integers.cmx \ + Globalenvs.cmx Datatypes.cmx Coqlib.cmx CList.cmx BinPos.cmx BinInt.cmx \ + AST.cmx LTLin.cmi Lattice.cmo: Specif.cmi Maps.cmi FSetInterface.cmi Datatypes.cmi Bool.cmi \ BinPos.cmi Lattice.cmi Lattice.cmx: Specif.cmx Maps.cmx FSetInterface.cmx Datatypes.cmx Bool.cmx \ BinPos.cmx Lattice.cmi -Linear.cmo: Values.cmi Specif.cmi Op.cmi Locations.cmi Integers.cmi \ +Linear.cmo: Values.cmi Specif.cmi Op.cmi Mem.cmi Locations.cmi Integers.cmi \ Globalenvs.cmi Datatypes.cmi Coqlib.cmi CList.cmi BinPos.cmi BinInt.cmi \ AST.cmi Linear.cmi -Linear.cmx: Values.cmx Specif.cmx Op.cmx Locations.cmx Integers.cmx \ +Linear.cmx: Values.cmx Specif.cmx Op.cmx Mem.cmx Locations.cmx Integers.cmx \ Globalenvs.cmx Datatypes.cmx Coqlib.cmx CList.cmx BinPos.cmx BinInt.cmx \ AST.cmx Linear.cmi -Linearize.cmo: Specif.cmi Op.cmi Maps.cmi Linear.cmi Lattice.cmi LTL.cmi \ +Linearize.cmo: Specif.cmi Op.cmi Maps.cmi Lattice.cmi LTLin.cmi LTL.cmi \ Kildall.cmi Datatypes.cmi Coqlib.cmi CList.cmi BinPos.cmi AST.cmi \ Linearize.cmi -Linearize.cmx: Specif.cmx Op.cmx Maps.cmx Linear.cmx Lattice.cmx LTL.cmx \ +Linearize.cmx: Specif.cmx Op.cmx Maps.cmx Lattice.cmx LTLin.cmx LTL.cmx \ Kildall.cmx Datatypes.cmx Coqlib.cmx CList.cmx BinPos.cmx AST.cmx \ Linearize.cmi -Lineartyping.cmo: Zmax.cmi Locations.cmi Linear.cmi Datatypes.cmi \ - Conventions.cmi CList.cmi BinPos.cmi BinInt.cmi AST.cmi Lineartyping.cmi -Lineartyping.cmx: Zmax.cmx Locations.cmx Linear.cmx Datatypes.cmx \ - Conventions.cmx CList.cmx BinPos.cmx BinInt.cmx AST.cmx Lineartyping.cmi Locations.cmo: Values.cmi Specif.cmi Datatypes.cmi Coqlib.cmi BinPos.cmi \ BinInt.cmi AST.cmi Locations.cmi Locations.cmx: Values.cmx Specif.cmx Datatypes.cmx Coqlib.cmx BinPos.cmx \ BinInt.cmx AST.cmx Locations.cmi Logic.cmo: Logic.cmi Logic.cmx: Logic.cmi -Mach.cmo: Zmax.cmi Zdiv.cmi Values.cmi Specif.cmi Op.cmi Mem.cmi Maps.cmi \ +Mach.cmo: Zmax.cmi Zdiv.cmi Values.cmi Specif.cmi Op.cmi Maps.cmi \ Locations.cmi Integers.cmi Globalenvs.cmi Datatypes.cmi Coqlib.cmi \ CList.cmi BinPos.cmi BinInt.cmi AST.cmi Mach.cmi -Mach.cmx: Zmax.cmx Zdiv.cmx Values.cmx Specif.cmx Op.cmx Mem.cmx Maps.cmx \ +Mach.cmx: Zmax.cmx Zdiv.cmx Values.cmx Specif.cmx Op.cmx Maps.cmx \ Locations.cmx Integers.cmx Globalenvs.cmx Datatypes.cmx Coqlib.cmx \ CList.cmx BinPos.cmx BinInt.cmx AST.cmx Mach.cmi -Main.cmo: Tunneling.cmi Stacking.cmi RTLgen.cmi PPCgen.cmi PPC.cmi \ - Linearize.cmi Datatypes.cmi Ctyping.cmi Csyntax.cmi Cshmgen.cmi \ - Constprop.cmi Cminorgen.cmi Cminor.cmi CSE.cmi Allocation.cmi AST.cmi \ - Main.cmi -Main.cmx: Tunneling.cmx Stacking.cmx RTLgen.cmx PPCgen.cmx PPC.cmx \ - Linearize.cmx Datatypes.cmx Ctyping.cmx Csyntax.cmx Cshmgen.cmx \ - Constprop.cmx Cminorgen.cmx Cminor.cmx CSE.cmx Allocation.cmx AST.cmx \ - Main.cmi +Main.cmo: Tunneling.cmi Stacking.cmi Selection.cmi Reload.cmi RTLgen.cmi \ + RTL.cmi PPCgen.cmi PPC.cmi Linearize.cmi Errors.cmi Datatypes.cmi \ + Ctyping.cmi Csyntax.cmi Cshmgen.cmi Constprop.cmi Cminorgen.cmi \ + Cminor.cmi CString.cmi CSE.cmi Ascii.cmi Allocation.cmi AST.cmi Main.cmi +Main.cmx: Tunneling.cmx Stacking.cmx Selection.cmx Reload.cmx RTLgen.cmx \ + RTL.cmx PPCgen.cmx PPC.cmx Linearize.cmx Errors.cmx Datatypes.cmx \ + Ctyping.cmx Csyntax.cmx Cshmgen.cmx Constprop.cmx Cminorgen.cmx \ + Cminor.cmx CString.cmx CSE.cmx Ascii.cmx Allocation.cmx AST.cmx Main.cmi Maps.cmo: Specif.cmi Datatypes.cmi Coqlib.cmi CList.cmi BinPos.cmi BinNat.cmi \ BinInt.cmi Maps.cmi Maps.cmx: Specif.cmx Datatypes.cmx Coqlib.cmx CList.cmx BinPos.cmx BinNat.cmx \ @@ -359,9 +397,9 @@ Mem.cmo: Zmax.cmi Values.cmi Specif.cmi Integers.cmi Datatypes.cmi Coqlib.cmi \ CList.cmi BinPos.cmi BinInt.cmi AST.cmi Mem.cmi Mem.cmx: Zmax.cmx Values.cmx Specif.cmx Integers.cmx Datatypes.cmx Coqlib.cmx \ CList.cmx BinPos.cmx BinInt.cmx AST.cmx Mem.cmi -Op.cmo: Values.cmi Specif.cmi Integers.cmi Globalenvs.cmi Floats.cmi \ +Op.cmo: Values.cmi Specif.cmi Mem.cmi Integers.cmi Globalenvs.cmi Floats.cmi \ Datatypes.cmi CList.cmi Bool.cmi BinPos.cmi BinInt.cmi AST.cmi Op.cmi -Op.cmx: Values.cmx Specif.cmx Integers.cmx Globalenvs.cmx Floats.cmx \ +Op.cmx: Values.cmx Specif.cmx Mem.cmx Integers.cmx Globalenvs.cmx Floats.cmx \ Datatypes.cmx CList.cmx Bool.cmx BinPos.cmx BinInt.cmx AST.cmx Op.cmi Ordered.cmo: Specif.cmi OrderedType.cmi Maps.cmi Datatypes.cmi Coqlib.cmi \ BinPos.cmi Ordered.cmi @@ -376,11 +414,11 @@ PPC.cmx: Values.cmx Specif.cmx Mem.cmx Maps.cmx Integers.cmx Globalenvs.cmx \ Floats.cmx Datatypes.cmx Coqlib.cmx CList.cmx BinPos.cmx BinInt.cmx \ AST.cmx PPC.cmi PPCgen.cmo: Specif.cmi PPC.cmi Op.cmi Mach.cmi Locations.cmi Integers.cmi \ - Datatypes.cmi Coqlib.cmi CList.cmi Bool.cmi BinPos.cmi BinInt.cmi AST.cmi \ - PPCgen.cmi + Errors.cmi Datatypes.cmi Coqlib.cmi CString.cmi CList.cmi Bool.cmi \ + BinPos.cmi BinInt.cmi Ascii.cmi AST.cmi PPCgen.cmi PPCgen.cmx: Specif.cmx PPC.cmx Op.cmx Mach.cmx Locations.cmx Integers.cmx \ - Datatypes.cmx Coqlib.cmx CList.cmx Bool.cmx BinPos.cmx BinInt.cmx AST.cmx \ - PPCgen.cmi + Errors.cmx Datatypes.cmx Coqlib.cmx CString.cmx CList.cmx Bool.cmx \ + BinPos.cmx BinInt.cmx Ascii.cmx AST.cmx PPCgen.cmi Parallelmove.cmo: Parmov.cmi Locations.cmi Datatypes.cmi CList.cmi AST.cmi \ Parallelmove.cmi Parallelmove.cmx: Parmov.cmx Locations.cmx Datatypes.cmx CList.cmx AST.cmx \ @@ -389,38 +427,60 @@ Parmov.cmo: Specif.cmi Peano.cmi Datatypes.cmi CList.cmi Parmov.cmi Parmov.cmx: Specif.cmx Peano.cmx Datatypes.cmx CList.cmx Parmov.cmi Peano.cmo: Datatypes.cmi Peano.cmi Peano.cmx: Datatypes.cmx Peano.cmi -RTL.cmo: Values.cmi Registers.cmi Op.cmi Maps.cmi Integers.cmi Globalenvs.cmi \ - Datatypes.cmi CList.cmi BinPos.cmi BinInt.cmi AST.cmi RTL.cmi -RTL.cmx: Values.cmx Registers.cmx Op.cmx Maps.cmx Integers.cmx Globalenvs.cmx \ - Datatypes.cmx CList.cmx BinPos.cmx BinInt.cmx AST.cmx RTL.cmi -RTLgen.cmo: Specif.cmi Registers.cmi ../caml/RTLgenaux.cmo RTL.cmi Op.cmi \ - Maps.cmi Integers.cmi Datatypes.cmi Coqlib.cmi Cminor.cmi CList.cmi \ - BinPos.cmi AST.cmi RTLgen.cmi -RTLgen.cmx: Specif.cmx Registers.cmx ../caml/RTLgenaux.cmx RTL.cmx Op.cmx \ - Maps.cmx Integers.cmx Datatypes.cmx Coqlib.cmx Cminor.cmx CList.cmx \ - BinPos.cmx AST.cmx RTLgen.cmi +RTL.cmo: Values.cmi Registers.cmi Op.cmi Mem.cmi Maps.cmi Integers.cmi \ + Globalenvs.cmi Datatypes.cmi CList.cmi BinPos.cmi BinInt.cmi AST.cmi \ + RTL.cmi +RTL.cmx: Values.cmx Registers.cmx Op.cmx Mem.cmx Maps.cmx Integers.cmx \ + Globalenvs.cmx Datatypes.cmx CList.cmx BinPos.cmx BinInt.cmx AST.cmx \ + RTL.cmi +RTLgen.cmo: Switch.cmi Specif.cmi Registers.cmi ../caml/RTLgenaux.cmo RTL.cmi \ + Op.cmi Maps.cmi Integers.cmi Errors.cmi Datatypes.cmi Coqlib.cmi \ + CminorSel.cmi CString.cmi CList.cmi BinPos.cmi Ascii.cmi AST.cmi \ + RTLgen.cmi +RTLgen.cmx: Switch.cmx Specif.cmx Registers.cmx ../caml/RTLgenaux.cmx RTL.cmx \ + Op.cmx Maps.cmx Integers.cmx Errors.cmx Datatypes.cmx Coqlib.cmx \ + CminorSel.cmx CString.cmx CList.cmx BinPos.cmx Ascii.cmx AST.cmx \ + RTLgen.cmi RTLtyping.cmo: Specif.cmi Registers.cmi ../caml/RTLtypingaux.cmo RTL.cmi \ - Op.cmi Maps.cmi Datatypes.cmi Coqlib.cmi CList.cmi AST.cmi RTLtyping.cmi + Op.cmi Maps.cmi Errors.cmi Datatypes.cmi Coqlib.cmi Conventions.cmi \ + CString.cmi CList.cmi BinPos.cmi BinInt.cmi Ascii.cmi AST.cmi \ + RTLtyping.cmi RTLtyping.cmx: Specif.cmx Registers.cmx ../caml/RTLtypingaux.cmx RTL.cmx \ - Op.cmx Maps.cmx Datatypes.cmx Coqlib.cmx CList.cmx AST.cmx RTLtyping.cmi + Op.cmx Maps.cmx Errors.cmx Datatypes.cmx Coqlib.cmx Conventions.cmx \ + CString.cmx CList.cmx BinPos.cmx BinInt.cmx Ascii.cmx AST.cmx \ + RTLtyping.cmi Registers.cmo: Specif.cmi OrderedType.cmi Ordered.cmi Maps.cmi FSetAVL.cmi \ Datatypes.cmi Coqlib.cmi CList.cmi BinPos.cmi BinInt.cmi AST.cmi \ Registers.cmi Registers.cmx: Specif.cmx OrderedType.cmx Ordered.cmx Maps.cmx FSetAVL.cmx \ Datatypes.cmx Coqlib.cmx CList.cmx BinPos.cmx BinInt.cmx AST.cmx \ Registers.cmi +Reload.cmo: Specif.cmi Parallelmove.cmi Op.cmi Locations.cmi Linear.cmi \ + LTLin.cmi Datatypes.cmi Conventions.cmi CList.cmi AST.cmi Reload.cmi +Reload.cmx: Specif.cmx Parallelmove.cmx Op.cmx Locations.cmx Linear.cmx \ + LTLin.cmx Datatypes.cmx Conventions.cmx CList.cmx AST.cmx Reload.cmi +Selection.cmo: Specif.cmi Op.cmi Integers.cmi Datatypes.cmi Compare_dec.cmi \ + CminorSel.cmi Cminor.cmi CList.cmi BinPos.cmi BinInt.cmi AST.cmi \ + Selection.cmi +Selection.cmx: Specif.cmx Op.cmx Integers.cmx Datatypes.cmx Compare_dec.cmx \ + CminorSel.cmx Cminor.cmx CList.cmx BinPos.cmx BinInt.cmx AST.cmx \ + Selection.cmi Setoid.cmo: Datatypes.cmi Setoid.cmi Setoid.cmx: Datatypes.cmx Setoid.cmi Specif.cmo: Datatypes.cmi Specif.cmi Specif.cmx: Datatypes.cmx Specif.cmi -Stacking.cmo: Specif.cmi Op.cmi Mach.cmi Locations.cmi Lineartyping.cmi \ - Linear.cmi Integers.cmi Datatypes.cmi Coqlib.cmi Conventions.cmi \ - CList.cmi BinPos.cmi BinInt.cmi AST.cmi Stacking.cmi -Stacking.cmx: Specif.cmx Op.cmx Mach.cmx Locations.cmx Lineartyping.cmx \ - Linear.cmx Integers.cmx Datatypes.cmx Coqlib.cmx Conventions.cmx \ - CList.cmx BinPos.cmx BinInt.cmx AST.cmx Stacking.cmi +Stacking.cmo: Specif.cmi Op.cmi Mach.cmi Locations.cmi Linear.cmi \ + Integers.cmi Errors.cmi Datatypes.cmi Coqlib.cmi Conventions.cmi \ + CString.cmi CList.cmi Bounds.cmi BinPos.cmi BinInt.cmi Ascii.cmi AST.cmi \ + Stacking.cmi +Stacking.cmx: Specif.cmx Op.cmx Mach.cmx Locations.cmx Linear.cmx \ + Integers.cmx Errors.cmx Datatypes.cmx Coqlib.cmx Conventions.cmx \ + CString.cmx CList.cmx Bounds.cmx BinPos.cmx BinInt.cmx Ascii.cmx AST.cmx \ + Stacking.cmi Sumbool.cmo: Specif.cmi Datatypes.cmi Sumbool.cmi Sumbool.cmx: Specif.cmx Datatypes.cmx Sumbool.cmi +Switch.cmo: Integers.cmi EqNat.cmi Datatypes.cmi CList.cmi Switch.cmi +Switch.cmx: Integers.cmx EqNat.cmx Datatypes.cmx CList.cmx Switch.cmi Tunneling.cmo: Maps.cmi LTL.cmi Datatypes.cmi AST.cmi Tunneling.cmi Tunneling.cmx: Maps.cmx LTL.cmx Datatypes.cmx AST.cmx Tunneling.cmi Values.cmo: Specif.cmi Integers.cmi Floats.cmi Datatypes.cmi Coqlib.cmi \ diff --git a/extraction/Makefile b/extraction/Makefile index 69b5f572..cb7f4c5a 100644 --- a/extraction/Makefile +++ b/extraction/Makefile @@ -1,32 +1,36 @@ FILES=\ - Datatypes.ml Logic.ml Wf.ml Peano.ml Specif.ml Compare_dec.ml \ + Datatypes.ml Logic.ml Wf.ml Peano.ml Specif.ml Compare_dec.ml EqNat.ml \ Bool.ml CList.ml Sumbool.ml Setoid.ml BinPos.ml BinNat.ml BinInt.ml \ ZArith_dec.ml Zeven.ml Zmax.ml Zmisc.ml Zbool.ml Zpower.ml Zdiv.ml \ + Ascii.ml CString.ml \ OrderedType.ml FSetInterface.ml FSetFacts.ml FSetList.ml \ CInt.ml FSetAVL.ml \ - Coqlib.ml Maps.ml Ordered.ml AST.ml Iteration.ml Integers.ml \ + Coqlib.ml Maps.ml Ordered.ml Errors.ml AST.ml Iteration.ml Integers.ml \ ../caml/Camlcoq.ml ../caml/Floataux.ml Floats.ml Parmov.ml Values.ml \ Mem.ml Globalenvs.ml \ - Csyntax.ml Ctyping.ml Csharpminor.ml Cshmgen.ml \ - Op.ml Cminor.ml Cmconstr.ml \ + Csyntax.ml Ctyping.ml Cminor.ml Csharpminor.ml Cshmgen.ml \ Cminorgen.ml \ + Op.ml CminorSel.ml \ + Selection.ml \ Registers.ml RTL.ml \ - ../caml/RTLgenaux.ml RTLgen.ml \ + Switch.ml ../caml/RTLgenaux.ml RTLgen.ml \ Locations.ml Conventions.ml \ ../caml/RTLtypingaux.ml RTLtyping.ml \ Lattice.ml Kildall.ml \ Constprop.ml CSE.ml \ - LTL.ml \ + LTL.ml LTLin.ml \ InterfGraph.ml ../caml/Coloringaux.ml Coloring.ml \ - Parallelmove.ml Allocation.ml \ - Tunneling.ml Linear.ml Lineartyping.ml Linearize.ml \ - Mach.ml Stacking.ml \ + Allocation.ml \ + Tunneling.ml Linear.ml Linearize.ml \ + Parallelmove.ml Reload.ml \ + Mach.ml Bounds.ml Stacking.ml \ PPC.ml PPCgen.ml \ Main.ml \ ../caml/Cil2Csyntax.ml \ ../caml/CMparser.ml ../caml/CMlexer.ml ../caml/CMtypecheck.ml \ ../caml/PrintCsyntax.ml ../caml/PrintPPC.ml \ ../caml/Main2.ml +# ../caml/Configuration.ml ../caml/Driver.ml EXTRACTEDFILES:=$(filter-out ../caml/%, $(FILES)) GENFILES:=$(EXTRACTEDFILES) $(EXTRACTEDFILES:.ml=.mli) @@ -58,13 +62,15 @@ extraction: @echo "Fixing file names..." @mv list.ml CList.ml @mv list.mli CList.mli + @mv string.ml CString.ml + @mv string.mli CString.mli @mv int.ml CInt.ml @mv int.mli CInt.mli @for i in $(GENFILES); do \ j=`./uncapitalize $$i`; \ test -f $$i || (test -f $$j && mv $$j $$i); \ done - @echo "Conversion List -> CList and Int -> CInt..." + @echo "Conversion List -> CList, String -> CString, Int -> CInt..." @./convert $(GENFILES) @echo "Patching files..." @for i in *.patch; do patch < $$i; done diff --git a/extraction/convert b/extraction/convert index a29178a1..b3d25336 100755 --- a/extraction/convert +++ b/extraction/convert @@ -1,6 +1,7 @@ #!/usr/bin/perl -pi s/\bList\b/CList/g; +s/\bString\b/CString/g; s/\bInt\.Z_as_Int\b/CInt.Z_as_Int/g; s/\bInt\.Int\b/CInt.Int/g; s/\bInt\.MoreInt\b/CInt.MoreInt/g; diff --git a/extraction/extraction.v b/extraction/extraction.v index 47c6f36c..cc33c981 100644 --- a/extraction/extraction.v +++ b/extraction/extraction.v @@ -38,6 +38,7 @@ Extract Constant Iteration.GenIter.iterate => (* RTLgen *) +Extract Constant RTLgen.compile_switch => "RTLgenaux.compile_switch". Extract Constant RTLgen.more_likely => "RTLgenaux.more_likely". (* RTLtyping *) diff --git a/lib/Coqlib.v b/lib/Coqlib.v index 184fe28f..7bee366b 100644 --- a/lib/Coqlib.v +++ b/lib/Coqlib.v @@ -23,6 +23,8 @@ Axiom proof_irrelevance: (** * Useful tactics *) +Ltac inv H := inversion H; clear H; subst. + Ltac predSpec pred predspec x y := generalize (predspec x y); case (pred x y); intro. @@ -753,6 +755,44 @@ Proof. generalize list_norepet_app; firstorder. Qed. +(** [is_tail l1 l2] holds iff [l2] is of the form [l ++ l1] for some [l]. *) + +Inductive is_tail (A: Set): list A -> list A -> Prop := + | is_tail_refl: + forall c, is_tail c c + | is_tail_cons: + forall i c1 c2, is_tail c1 c2 -> is_tail c1 (i :: c2). + +Lemma is_tail_in: + forall (A: Set) (i: A) c1 c2, is_tail (i :: c1) c2 -> In i c2. +Proof. + induction c2; simpl; intros. + inversion H. + inversion H. tauto. right; auto. +Qed. + +Lemma is_tail_cons_left: + forall (A: Set) (i: A) c1 c2, is_tail (i :: c1) c2 -> is_tail c1 c2. +Proof. + induction c2; intros; inversion H. + constructor. constructor. constructor. auto. +Qed. + +Hint Resolve is_tail_refl is_tail_cons is_tail_in is_tail_cons_left: coqlib. + +Lemma is_tail_incl: + forall (A: Set) (l1 l2: list A), is_tail l1 l2 -> incl l1 l2. +Proof. + induction 1; eauto with coqlib. +Qed. + +Lemma is_tail_trans: + forall (A: Set) (l1 l2: list A), + is_tail l1 l2 -> forall (l3: list A), is_tail l2 l3 -> is_tail l1 l3. +Proof. + induction 1; intros. auto. apply IHis_tail. eapply is_tail_cons_left; eauto. +Qed. + (** [list_forall2 P [x1 ... xN] [y1 ... yM] holds iff [N = M] and [P xi yi] holds for all [i]. *) diff --git a/lib/Iteration.v b/lib/Iteration.v index 3c4b5998..85c5ded8 100644 --- a/lib/Iteration.v +++ b/lib/Iteration.v @@ -1,6 +1,5 @@ (* Bounded and unbounded iterators *) -Require Recdef. Require Import Coqlib. Require Import Classical. Require Import Max. @@ -72,15 +71,51 @@ Fixpoint iterate (a: A) : B := Definition num_iterations := 1000000000000%positive. -Function iter (niter: positive) (s: A) {wf Plt niter} : option B := - if peq niter xH then None else - match step s with - | inl res => Some res - | inr s' => iter (Ppred niter) s' - end. +(** The simple definition of bounded iteration is: +<< +Fixpoint iterate (niter: nat) (a: A) {struct niter} : option B := + match niter with + | O => None + | S niter' => + match step a with + | inl b => b + | inr a' => iterate niter' a' + end + end. +>> + This function is structural recursive over the parameter [niter] + (number of iterations), represented here as a Peano integer (type [nat]). + However, we want to use very large values of [niter]. As Peano integers, + these values would be much too large to fit in memory. Therefore, + we must express iteration counts as a binary integer (type [positive]). + However, Peano induction over type [positive] is not structural recursion, + so we cannot define [iterate] as a Coq fixpoint and must use + Noetherian recursion instead. *) + +Definition iter_step (x: positive) + (next: forall y, Plt y x -> A -> option B) + (s: A) : option B := + match peq x xH with + | left EQ => None + | right NOTEQ => + match step s with + | inl res => Some res + | inr s' => next (Ppred x) (Ppred_Plt x NOTEQ) s' + end + end. + +Definition iter: positive -> A -> option B := + Fix Plt_wf (fun _ => A -> option B) iter_step. + +(** We then prove the expected unrolling equations for [iter]. *) + +Remark unroll_iter: + forall x, iter x = iter_step x (fun y _ => iter y). Proof. - intros. apply Ppred_Plt. auto. - apply Plt_wf. + unfold iter; apply (Fix_eq Plt_wf (fun _ => A -> option B) iter_step). + intros. unfold iter_step. apply extensionality. intro s. + case (peq x xH); intro. auto. + rewrite H. auto. Qed. (** The [iterate] function is defined as [iter] up to @@ -100,10 +135,13 @@ Hypothesis step_prop: Lemma iter_prop: forall n a b, P a -> iter n a = Some b -> Q b. Proof. - intros n a. functional induction (iter n a); intros. - discriminate. - inversion H0; subst b. generalize (step_prop s H). rewrite e0. auto. - apply IHo. generalize (step_prop s H). rewrite e0. auto. auto. + apply (well_founded_ind Plt_wf + (fun p => forall a b, P a -> iter p a = Some b -> Q b)). + intros until b. intro. rewrite unroll_iter. + unfold iter_step. case (peq x 1); intro. congruence. + generalize (step_prop a H0). + case (step a); intros. congruence. + apply H with (Ppred x) a0. apply Ppred_Plt; auto. auto. auto. Qed. Lemma iterate_prop: diff --git a/lib/Parmov.v b/lib/Parmov.v index cd24dd96..c244b8b6 100644 --- a/lib/Parmov.v +++ b/lib/Parmov.v @@ -34,30 +34,57 @@ ## *) +Require Import Relations. Require Import Coqlib. Require Recdef. Section PARMOV. +(** * Registers, moves, and their semantics *) + +(** The development is parameterized by the type of registers, + equipped with a decidable equality. *) + Variable reg: Set. +Variable reg_eq : forall (r1 r2: reg), {r1=r2} + {r1<>r2}. + +(** The [temp] function maps every register [r] to the register that + should be used to save the value of [r] temporarily while performing + a cyclic assignment involving [r]. In the simplest case, there is + only one such temporary register [rtemp] and [temp] is the constant + function [fun r => rtemp]. In more realistic cases, different temporary + registers can be used to hold different values. In the case of Compcert, + we have two temporary registers, one for integer values and the other + for floating-point values, and [temp] returns the appropriate temporary + depending on the type of its argument. *) + Variable temp: reg -> reg. +(** A set of moves is a list of pairs of registers, of the form + (source, destination). *) + Definition moves := (list (reg * reg))%type. (* src -> dst *) Definition srcs (m: moves) := List.map (@fst reg reg) m. Definition dests (m: moves) := List.map (@snd reg reg) m. -(* Semantics of moves *) +(** ** Semantics of moves *) + +(** The dynamic semantics of moves is given in terms of environments. + An environment is a mapping of registers to their current values. *) Variable val: Set. Definition env := reg -> val. -Variable reg_eq : forall (r1 r2: reg), {r1=r2} + {r1<>r2}. Lemma env_ext: forall (e1 e2: env), (forall r, e1 r = e2 r) -> e1 = e2. Proof (extensionality reg val). +(** The main operation over environments is update: it assigns + a value [v] to a register [r] and preserves the values of other + registers. *) + Definition update (r: reg) (v: val) (e: env) : env := fun r' => if reg_eq r' r then v else e r'. @@ -97,18 +124,32 @@ Proof. destruct (reg_eq r0 r); auto. Qed. +(** A list of moves [(src1, dst1), ..., (srcN, dstN)] can be given + three different semantics, as environment transformers. + The first semantics corresponds to a parallel assignment: + [dst1, ..., dstN] are set to the initial values of [src1, ..., srcN]. *) + Fixpoint exec_par (m: moves) (e: env) {struct m}: env := match m with | nil => e | (s, d) :: m' => update d (e s) (exec_par m' e) end. +(** The second semantics corresponds to a sequence of individual + assignments: first, [dst1] is set to the initial value of [src1]; + then, [dst2] is set to the current value of [src2] after the first + assignment; etc. *) + Fixpoint exec_seq (m: moves) (e: env) {struct m}: env := match m with | nil => e | (s, d) :: m' => exec_seq m' (update d (e s) e) end. +(** The third semantics is also sequential, but executes the moves + in reverse order, starting with [srcN, dstN] and finishing with + [src1, dst1]. *) + Fixpoint exec_seq_rev (m: moves) (e: env) {struct m}: env := match m with | nil => e @@ -117,50 +158,57 @@ Fixpoint exec_seq_rev (m: moves) (e: env) {struct m}: env := update d (e' s) e' end. -(* Specification of the parallel move *) +(** * Specification of the non-deterministic algorithm *) + +(** Rideau and Serpette's parallel move compilation algorithm is first + specified as a non-deterministic set of rewriting rules operating + over triples [(mu, sigma, tau)] of moves. We define these rules + as an inductive predicate [transition] relating triples of moves, + and its reflexive transitive closure [transitions]. *) + +Inductive state: Set := + State (mu: moves) (sigma: moves) (tau: moves) : state. Definition no_read (mu: moves) (d: reg) : Prop := ~In d (srcs mu). -Inductive transition: moves -> moves -> moves - -> moves -> moves -> moves -> Prop := +Inductive transition: state -> state -> Prop := | tr_nop: forall mu1 r mu2 sigma tau, - transition (mu1 ++ (r, r) :: mu2) sigma tau - (mu1 ++ mu2) sigma tau + transition (State (mu1 ++ (r, r) :: mu2) sigma tau) + (State (mu1 ++ mu2) sigma tau) | tr_start: forall mu1 s d mu2 tau, - transition (mu1 ++ (s, d) :: mu2) nil tau - (mu1 ++ mu2) ((s, d) :: nil) tau + transition (State (mu1 ++ (s, d) :: mu2) nil tau) + (State (mu1 ++ mu2) ((s, d) :: nil) tau) | tr_push: forall mu1 d r mu2 s sigma tau, - transition (mu1 ++ (d, r) :: mu2) ((s, d) :: sigma) tau - (mu1 ++ mu2) ((d, r) :: (s, d) :: sigma) tau + transition (State (mu1 ++ (d, r) :: mu2) ((s, d) :: sigma) tau) + (State (mu1 ++ mu2) ((d, r) :: (s, d) :: sigma) tau) | tr_loop: forall mu sigma s d tau, - transition mu (sigma ++ (s, d) :: nil) tau - mu (sigma ++ (temp s, d) :: nil) ((s, temp s) :: tau) + transition (State mu (sigma ++ (s, d) :: nil) tau) + (State mu (sigma ++ (temp s, d) :: nil) ((s, temp s) :: tau)) | tr_pop: forall mu s0 d0 s1 d1 sigma tau, no_read mu d1 -> d1 <> s0 -> - transition mu ((s1, d1) :: sigma ++ (s0, d0) :: nil) tau - mu (sigma ++ (s0, d0) :: nil) ((s1, d1) :: tau) + transition (State mu ((s1, d1) :: sigma ++ (s0, d0) :: nil) tau) + (State mu (sigma ++ (s0, d0) :: nil) ((s1, d1) :: tau)) | tr_last: forall mu s d tau, no_read mu d -> - transition mu ((s, d) :: nil) tau - mu nil ((s, d) :: tau). + transition (State mu ((s, d) :: nil) tau) + (State mu nil ((s, d) :: tau)). -Inductive transitions: moves -> moves -> moves - -> moves -> moves -> moves -> Prop := - | tr_refl: - forall mu sigma tau, - transitions mu sigma tau mu sigma tau - | tr_one: - forall mu1 sigma1 tau1 mu2 sigma2 tau2, - transition mu1 sigma1 tau1 mu2 sigma2 tau2 -> - transitions mu1 sigma1 tau1 mu2 sigma2 tau2 - | tr_trans: - forall mu1 sigma1 tau1 mu2 sigma2 tau2 mu3 sigma3 tau3, - transitions mu1 sigma1 tau1 mu2 sigma2 tau2 -> - transitions mu2 sigma2 tau2 mu3 sigma3 tau3 -> - transitions mu1 sigma1 tau1 mu3 sigma3 tau3. - -(* Well-formedness properties *) +Definition transitions: state -> state -> Prop := + clos_refl_trans state transition. + +(** ** Well-formedness properties of states *) + +(** A state [mu, sigma, tau] is well-formed if the following properties hold: + +- [mu] concatenated with [sigma] is a ``mill'', that is, no destination + appears twice (predicate [is_mill] below). +- No temporary register appears in [mu] (predicate [move_no_temp]). +- No temporary register appears in [sigma] except perhaps as the source + of the last move in [sigma] (predicate [temp_last]). +- [sigma] is a ``path'', that is, the source of a move is the destination + of the following move. +*) Definition is_mill (m: moves) : Prop := list_norepet (dests m). @@ -191,13 +239,16 @@ Inductive is_path: moves -> Prop := is_path m -> is_path ((s, d) :: m). -Definition state_wf (mu sigma tau: moves) : Prop := - is_mill (mu ++ sigma) - /\ move_no_temp mu - /\ temp_last sigma - /\ is_path sigma. +Inductive state_wf: state -> Prop := + | state_wf_intro: + forall mu sigma tau, + is_mill (mu ++ sigma) -> + move_no_temp mu -> + temp_last sigma -> + is_path sigma -> + state_wf (State mu sigma tau). -(* Some properties of srcs and dests *) +(** Some trivial properties of srcs and dests. *) Lemma dests_append: forall m1 m2, dests (m1 ++ m2) = dests m1 ++ dests m2. @@ -236,7 +287,7 @@ Proof. elim (IHs d); intros. split; congruence. congruence. Qed. -(* Some properties of is_mill and dests_disjoint *) +(** Some properties of [is_mill] and [dests_disjoint]. *) Definition dests_disjoint (m1 m2: moves) : Prop := list_disjoint (dests m1) (dests m2). @@ -313,7 +364,7 @@ Proof. apply list_norepet_app. Qed. -(* Some properties of move_no_temp *) +(** Some properties of [move_no_temp]. *) Lemma move_no_temp_append: forall m1 m2, @@ -329,7 +380,7 @@ Proof. intros; red; intros. apply H. rewrite <- List.In_rev. auto. Qed. -(* Some properties of temp_last *) +(** Some properties of [temp_last]. *) Lemma temp_last_change_last_source: forall s d s' sigma, @@ -369,7 +420,7 @@ Proof. apply in_or_app. auto. Qed. -(* Some properties of is_path *) +(** Some properties of [is_path]. *) Lemma is_path_pop: forall s d m, @@ -420,7 +471,8 @@ Proof. intro. elim H1. elim (H2 _ H3); intro. congruence. auto. Qed. -(* Populating a rewrite database. *) +(** To benefit from some proof automation, we populate a rewrite database + with some of the properties above. *) Lemma notin_dests_cons: forall x s d m, @@ -441,65 +493,76 @@ Hint Rewrite is_mill_cons is_mill_append dests_disjoint_append_left dests_disjoint_append_right notin_dests_cons notin_dests_append: pmov. -(* Preservation of well-formedness *) +(** ** Transitions preserve well-formedness *) Lemma transition_preserves_wf: - forall mu sigma tau mu' sigma' tau', - transition mu sigma tau mu' sigma' tau' -> - state_wf mu sigma tau -> state_wf mu' sigma' tau'. + forall st st', + transition st st' -> state_wf st -> state_wf st'. Proof. - induction 1; unfold state_wf; intros [A [B [C D]]]; - autorewrite with pmov in A; autorewrite with pmov. + induction 1; intro WF; inversion WF as [mu0 sigma0 tau0 A B C D]; + subst; + autorewrite with pmov in A; constructor; autorewrite with pmov. (* Nop *) - split. tauto. - split. red; intros. apply B. apply list_in_insert; auto. - split; auto. + tauto. + red; intros. apply B. apply list_in_insert; auto. + auto. auto. (* Start *) - split. tauto. - split. red; intros. apply B. apply list_in_insert; auto. - split. red. simpl. split. elim (B s d). auto. + tauto. + red; intros. apply B. apply list_in_insert; auto. + red. simpl. split. elim (B s d). auto. apply in_or_app. right. apply in_eq. red; simpl; tauto. constructor. exact I. constructor. (* Push *) - split. intuition. - split. red; intros. apply B. apply list_in_insert; auto. - split. elim (B d r). apply temp_last_push; auto. + intuition. + red; intros. apply B. apply list_in_insert; auto. + elim (B d r). apply temp_last_push; auto. apply in_or_app; right; apply in_eq. constructor. simpl. auto. auto. (* Loop *) - split. tauto. - split. auto. - split. eapply temp_last_change_last_source; eauto. + tauto. + auto. + eapply temp_last_change_last_source; eauto. eapply is_path_change_last_source; eauto. (* Pop *) - split. intuition. - split. auto. - split. eapply temp_last_pop; eauto. + intuition. + auto. + eapply temp_last_pop; eauto. eapply is_path_pop; eauto. (* Last *) - split. intuition. - split. auto. - split. unfold temp_last. simpl. auto. + intuition. + auto. + unfold temp_last. simpl. auto. constructor. Qed. Lemma transitions_preserve_wf: - forall mu sigma tau mu' sigma' tau', - transitions mu sigma tau mu' sigma' tau' -> - state_wf mu sigma tau -> state_wf mu' sigma' tau'. + forall st st', transitions st st' -> state_wf st -> state_wf st'. Proof. induction 1; intros; eauto. eapply transition_preserves_wf; eauto. Qed. -(* Properties of exec_ *) +(** ** Transitions preserve semantics *) + +(** We define the semantics of states as follows. + For a triple [mu, sigma, tau], we perform the moves [tau] in + reverse sequential order, then the moves [mu ++ sigma] in parallel. *) + +Definition statemove (st: state) (e: env) := + match st with + | State mu sigma tau => exec_par (mu ++ sigma) (exec_seq_rev tau e) + end. + +(** In preparation to showing that transitions preserve semantics, + we prove various properties of the parallel and sequential interpretations + of moves. *) Lemma exec_par_outside: forall m e r, ~In r (dests m) -> exec_par m e r = e r. @@ -609,12 +672,10 @@ Proof. intros. rewrite update_o. apply B. tauto. intuition. Qed. -(* Semantics of triples (mu, sigma, tau) *) - -Definition statemove (mu sigma tau: moves) (e: env) := - exec_par (mu ++ sigma) (exec_seq_rev tau e). - -(* Equivalence over non-temp regs *) +(** [env_equiv] is an equivalence relation between environments + capturing the fact that two environments assign the same values to + non-temporary registers, but can disagree on the values of temporary + registers. *) Definition env_equiv (e1 e2: env) : Prop := forall r, is_not_temp r -> e1 r = e2 r. @@ -657,15 +718,15 @@ Proof. apply IHm; auto. Qed. -(* Preservation of semantics by transformations. *) +(** The proof that transitions preserve semantics (up to the values of + temporary registers) follows. *) Lemma transition_preserves_semantics: - forall mu1 sigma1 tau1 mu2 sigma2 tau2 e, - transition mu1 sigma1 tau1 mu2 sigma2 tau2 -> - state_wf mu1 sigma1 tau1 -> - env_equiv (statemove mu2 sigma2 tau2 e) (statemove mu1 sigma1 tau1 e). + forall st st' e, + transition st st' -> state_wf st -> + env_equiv (statemove st' e) (statemove st e). Proof. - induction 1; intros [A [B [C D]]]. + induction 1; intro WF; inversion WF as [mu0 sigma0 tau0 A B C D]; subst; simpl. (* nop *) apply env_equiv_refl'. unfold statemove. @@ -728,134 +789,133 @@ Proof. Qed. Lemma transitions_preserve_semantics: - forall mu1 sigma1 tau1 mu2 sigma2 tau2 e, - transitions mu1 sigma1 tau1 mu2 sigma2 tau2 -> - state_wf mu1 sigma1 tau1 -> - env_equiv (statemove mu2 sigma2 tau2 e) (statemove mu1 sigma1 tau1 e). + forall st st' e, + transitions st st' -> state_wf st -> + env_equiv (statemove st' e) (statemove st e). Proof. induction 1; intros. - apply env_equiv_refl. eapply transition_preserves_semantics; eauto. - apply env_equiv_trans with (statemove mu2 sigma2 tau2 e). - apply IHtransitions2. eapply transitions_preserve_wf; eauto. - apply IHtransitions1. auto. + apply env_equiv_refl. + apply env_equiv_trans with (statemove y e); auto. + apply IHclos_refl_trans2. eapply transitions_preserve_wf; eauto. Qed. Lemma state_wf_start: forall mu, move_no_temp mu -> is_mill mu -> - state_wf mu nil nil. + state_wf (State mu nil nil). Proof. - split. rewrite <- app_nil_end. auto. - split. auto. - split. red. simpl. auto. + intros. constructor. rewrite <- app_nil_end. auto. + auto. + red. simpl. auto. constructor. Qed. +(** The main correctness result in this section is the following: + if we can transition repeatedly from an initial state [mu, nil, nil] + to a final state [nil, nil, tau], then the sequential execution + of the moves [rev tau] is semantically equivalent to the parallel + execution of the moves [mu]. *) + Theorem transitions_correctness: forall mu tau, move_no_temp mu -> is_mill mu -> - transitions mu nil nil nil nil tau -> + transitions (State mu nil nil) (State nil nil tau) -> forall e, env_equiv (exec_seq (List.rev tau) e) (exec_par mu e). Proof. intros. - generalize (transitions_preserve_semantics _ _ _ _ _ _ e H1 + generalize (transitions_preserve_semantics _ _ e H1 (state_wf_start _ H H0)). unfold statemove. simpl. rewrite <- app_nil_end. rewrite exec_seq_exec_seq_rev. auto. Qed. -(* Determinisation of the transition relation *) +(** * Determinisation of the transition relation *) + +(** We now define a deterministic variant [dtransition] of the + transition relation [transition]. [dtransition] is deterministic + in the sense that at most one transition applies to a given state. *) -Inductive dtransition: moves -> moves -> moves - -> moves -> moves -> moves -> Prop := +Inductive dtransition: state -> state -> Prop := | dtr_nop: forall r mu tau, - dtransition ((r, r) :: mu) nil tau - mu nil tau + dtransition (State ((r, r) :: mu) nil tau) + (State mu nil tau) | dtr_start: forall s d mu tau, s <> d -> - dtransition ((s, d) :: mu) nil tau - mu ((s, d) :: nil) tau + dtransition (State ((s, d) :: mu) nil tau) + (State mu ((s, d) :: nil) tau) | dtr_push: forall mu1 d r mu2 s sigma tau, no_read mu1 d -> - dtransition (mu1 ++ (d, r) :: mu2) ((s, d) :: sigma) tau - (mu1 ++ mu2) ((d, r) :: (s, d) :: sigma) tau + dtransition (State (mu1 ++ (d, r) :: mu2) ((s, d) :: sigma) tau) + (State (mu1 ++ mu2) ((d, r) :: (s, d) :: sigma) tau) | dtr_loop_pop: forall mu s r0 d sigma tau, no_read mu r0 -> - dtransition mu ((s, r0) :: sigma ++ (r0, d) :: nil) tau - mu (sigma ++ (temp r0, d) :: nil) ((s, r0) :: (r0, temp r0) :: tau) + dtransition (State mu ((s, r0) :: sigma ++ (r0, d) :: nil) tau) + (State mu (sigma ++ (temp r0, d) :: nil) ((s, r0) :: (r0, temp r0) :: tau)) | dtr_pop: forall mu s0 d0 s1 d1 sigma tau, no_read mu d1 -> d1 <> s0 -> - dtransition mu ((s1, d1) :: sigma ++ (s0, d0) :: nil) tau - mu (sigma ++ (s0, d0) :: nil) ((s1, d1) :: tau) + dtransition (State mu ((s1, d1) :: sigma ++ (s0, d0) :: nil) tau) + (State mu (sigma ++ (s0, d0) :: nil) ((s1, d1) :: tau)) | dtr_last: forall mu s d tau, no_read mu d -> - dtransition mu ((s, d) :: nil) tau - mu nil ((s, d) :: tau). + dtransition (State mu ((s, d) :: nil) tau) + (State mu nil ((s, d) :: tau)). -Inductive dtransitions: moves -> moves -> moves - -> moves -> moves -> moves -> Prop := - | dtr_refl: - forall mu sigma tau, - dtransitions mu sigma tau mu sigma tau - | dtr_one: - forall mu1 sigma1 tau1 mu2 sigma2 tau2, - dtransition mu1 sigma1 tau1 mu2 sigma2 tau2 -> - dtransitions mu1 sigma1 tau1 mu2 sigma2 tau2 - | dtr_trans: - forall mu1 sigma1 tau1 mu2 sigma2 tau2 mu3 sigma3 tau3, - dtransitions mu1 sigma1 tau1 mu2 sigma2 tau2 -> - dtransitions mu2 sigma2 tau2 mu3 sigma3 tau3 -> - dtransitions mu1 sigma1 tau1 mu3 sigma3 tau3. +Definition dtransitions: state -> state -> Prop := + clos_refl_trans state dtransition. + +(** Every deterministic transition corresponds to a sequence of + non-deterministic transitions. *) Lemma transition_determ: - forall mu1 sigma1 tau1 mu2 sigma2 tau2, - dtransition mu1 sigma1 tau1 mu2 sigma2 tau2 -> - state_wf mu1 sigma1 tau1 -> - transitions mu1 sigma1 tau1 mu2 sigma2 tau2. -Proof. - induction 1; intro. - apply tr_one. exact (tr_nop nil r mu nil tau). - apply tr_one. exact (tr_start nil s d mu tau). - apply tr_one. apply tr_push. - eapply tr_trans. - apply tr_one. + forall st st', + dtransition st st' -> + state_wf st -> + transitions st st'. +Proof. + induction 1; intro; unfold transitions. + apply rt_step. exact (tr_nop nil r mu nil tau). + apply rt_step. exact (tr_start nil s d mu tau). + apply rt_step. apply tr_push. + eapply rt_trans. + apply rt_step. change ((s, r0) :: sigma ++ (r0, d) :: nil) with (((s, r0) :: sigma) ++ (r0, d) :: nil). apply tr_loop. - apply tr_one. simpl. apply tr_pop. auto. - destruct H0 as [A [B [C D]]]. - generalize C. + apply rt_step. simpl. apply tr_pop. auto. + inv H0. generalize H6. change ((s, r0) :: sigma ++ (r0, d) :: nil) with (((s, r0) :: sigma) ++ (r0, d) :: nil). unfold temp_last; rewrite List.rev_unit. intros [E F]. elim (F s r0). unfold is_not_temp. auto. rewrite <- List.In_rev. apply in_eq. - apply tr_one. apply tr_pop. auto. auto. - apply tr_one. apply tr_last. auto. + apply rt_step. apply tr_pop. auto. auto. + apply rt_step. apply tr_last. auto. Qed. Lemma transitions_determ: - forall mu1 sigma1 tau1 mu2 sigma2 tau2, - dtransitions mu1 sigma1 tau1 mu2 sigma2 tau2 -> - state_wf mu1 sigma1 tau1 -> - transitions mu1 sigma1 tau1 mu2 sigma2 tau2. + forall st st', + dtransitions st st' -> + state_wf st -> + transitions st st'. Proof. - induction 1; intros. - apply tr_refl. + unfold transitions; induction 1; intros. eapply transition_determ; eauto. - eapply tr_trans. - apply IHdtransitions1. auto. - apply IHdtransitions2. eapply transitions_preserve_wf; eauto. + apply rt_refl. + apply rt_trans with y. auto. + apply IHclos_refl_trans2. + apply transitions_preserve_wf with x; auto. red; auto. Qed. +(** The semantic correctness of deterministic transitions follows. *) + Theorem dtransitions_correctness: forall mu tau, move_no_temp mu -> is_mill mu -> - dtransitions mu nil nil nil nil tau -> + dtransitions (State mu nil nil) (State nil nil tau) -> forall e, env_equiv (exec_seq (List.rev tau) e) (exec_par mu e). Proof. intros. @@ -863,7 +923,11 @@ Proof. apply transitions_determ. auto. apply state_wf_start; auto. Qed. -(* Transition function *) +(** * The compilation function *) + +(** We now define a function that takes a well-formed parallel move [mu] + and returns a sequence of elementary moves [tau] that is semantically + equivalent. We start by defining a number of auxiliary functions. *) Function split_move (m: moves) (r: reg) {struct m} : option (moves * reg * moves) := match m with @@ -893,8 +957,6 @@ Function replace_last_source (r: reg) (m: moves) {struct m} : moves := | s_d :: tl => s_d :: replace_last_source r tl end. -Inductive state : Set := State: moves -> moves -> moves -> state. - Definition final_state (st: state) : bool := match st with | State nil nil _ => true @@ -923,7 +985,7 @@ Function parmove_step (st: state) : state := end end. -(* Correctness properties of these functions *) +(** Here are the main correctness properties of these functions. *) Lemma split_move_charact: forall m r, @@ -966,54 +1028,50 @@ Proof. Qed. Lemma parmove_step_compatible: - forall mu sigma tau mu' sigma' tau', - final_state (State mu sigma tau) = false -> - parmove_step (State mu sigma tau) = State mu' sigma' tau' -> - dtransition mu sigma tau mu' sigma' tau'. + forall st, + final_state st = false -> + dtransition st (parmove_step st). Proof. - intros until tau'. intro NOTFINAL. - unfold parmove_step. + intros st NOTFINAL. destruct st as [mu sigma tau]. unfold parmove_step. case_eq mu; [intros MEQ | intros [ms md] mtl MEQ]. case_eq sigma; [intros SEQ | intros [ss sd] stl SEQ]. - subst mu sigma. discriminate. + subst mu sigma. simpl in NOTFINAL. discriminate. simpl. case_eq stl; [intros STLEQ | intros xx1 xx2 STLEQ]. - intro R; inversion R; clear R; subst. apply dtr_last. red; simpl; auto. elim (@exists_last _ stl). 2:congruence. intros sigma1 [[ss1 sd1] SEQ2]. rewrite <- STLEQ. clear STLEQ xx1 xx2. generalize (is_last_source_charact sd ss1 sd1 sigma1). rewrite SEQ2. destruct (is_last_source sd (sigma1 ++ (ss1, sd1) :: nil)). - intro. subst ss1. intro R; inversion R; clear R; subst. + intro. subst ss1. rewrite replace_last_source_charact. apply dtr_loop_pop. red; simpl; auto. - intro. intro R; inversion R; clear R; subst. - apply dtr_pop. red; simpl; auto. auto. + intro. apply dtr_pop. red; simpl; auto. auto. case_eq sigma; [intros SEQ | intros [ss sd] stl SEQ]. - destruct (reg_eq ms md); intro R; inversion R; clear R; subst. - apply dtr_nop. + destruct (reg_eq ms md). + subst. apply dtr_nop. apply dtr_start. auto. generalize (split_move_charact ((ms, md) :: mtl) sd). case (split_move ((ms, md) :: mtl) sd); [intros [[before r] after] | idtac]. - intros [MEQ2 NOREAD]. intro R; inversion R; clear R; subst. + intros [MEQ2 NOREAD]. rewrite MEQ2. apply dtr_push. auto. intro NOREAD. case_eq stl; [intros STLEQ | intros xx1 xx2 STLEQ]. - intro R; inversion R; clear R; subst. apply dtr_last. auto. elim (@exists_last _ stl). 2:congruence. intros sigma1 [[ss1 sd1] SEQ2]. rewrite <- STLEQ. clear STLEQ xx1 xx2. generalize (is_last_source_charact sd ss1 sd1 sigma1). rewrite SEQ2. destruct (is_last_source sd (sigma1 ++ (ss1, sd1) :: nil)). - intro. subst ss1. intro R; inversion R; clear R; subst. + intro. subst ss1. rewrite replace_last_source_charact. apply dtr_loop_pop. auto. - intro. intro R; inversion R; clear R; subst. - apply dtr_pop. auto. auto. + intro. apply dtr_pop. auto. auto. Qed. -(* Decreasing measure over states *) +(** The compilation function is obtained by iterating the [parmov_step] + function. To show that this iteration always terminates, we introduce + the following measure over states. *) Open Scope nat_scope. @@ -1023,9 +1081,8 @@ Definition measure (st: state) : nat := end. Lemma measure_decreasing_1: - forall mu1 sigma1 tau1 mu2 sigma2 tau2, - dtransition mu1 sigma1 tau1 mu2 sigma2 tau2 -> - measure (State mu2 sigma2 tau2) < measure (State mu1 sigma1 tau1). + forall st st', + dtransition st st' -> measure st' < measure st. Proof. induction 1; repeat (simpl; rewrite List.app_length); simpl; omega. Qed. @@ -1035,13 +1092,10 @@ Lemma measure_decreasing_2: final_state st = false -> measure (parmove_step st) < measure st. Proof. - intros. destruct st as [mu sigma tau]. - case_eq (parmove_step (State mu sigma tau)). intros mu' sigma' tau' EQ. - apply measure_decreasing_1. - apply parmove_step_compatible; auto. + intros. apply measure_decreasing_1. apply parmove_step_compatible; auto. Qed. -(* Compilation function for parallel moves *) +(** Compilation function for parallel moves. *) Function parmove_aux (st: state) {measure measure st} : moves := if final_state st @@ -1052,26 +1106,22 @@ Proof. Qed. Lemma parmove_aux_transitions: - forall mu sigma tau, - dtransitions mu sigma tau nil nil (parmove_aux (State mu sigma tau)). + forall st, + dtransitions st (State nil nil (parmove_aux st)). Proof. - assert (forall st, - match st with State mu sigma tau => - dtransitions mu sigma tau nil nil (parmove_aux st) - end). - intro st. functional induction (parmove_aux st). - destruct _x; destruct _x0; simpl in e; discriminate || apply dtr_refl. - case_eq (parmove_step st). intros mu' sigma' tau' PSTEP. - destruct st as [mu sigma tau]. - eapply dtr_trans. apply dtr_one. apply parmove_step_compatible; eauto. - rewrite PSTEP in IHm. auto. - - intros. apply (H (State mu sigma tau)). + unfold dtransitions. intro st. functional induction (parmove_aux st). + destruct _x; destruct _x0; simpl in e; discriminate || apply rt_refl. + eapply rt_trans. apply rt_step. apply parmove_step_compatible; eauto. + auto. Qed. Definition parmove (mu: moves) : moves := List.rev (parmove_aux (State mu nil nil)). +(** This is the main correctness theorem: the sequence of elementary + moves [parmove mu] is semantically equivalent to the parallel move + [mu] if the latter is well-formed. *) + Theorem parmove_correctness: forall mu, move_no_temp mu -> is_mill mu -> @@ -1082,6 +1132,10 @@ Proof. apply parmove_aux_transitions. Qed. +(** Here is an alternate formulation of [parmove], where the + parallel move problem is given as two separate lists of sources + and destinations. *) + Definition parmove2 (sl dl: list reg) : moves := parmove (List.combine sl dl). @@ -1111,7 +1165,13 @@ Proof. intros. transitivity (e1 r); auto. Qed. -(* Additional properties on the generated sequence of moves. *) +(** * Additional syntactic properties *) + +(** We now show an additional property of the sequence of moves + generated by [parmove mu]: any such move [s -> d] is either + already present in [mu], or of the form [temp s -> d] or [s -> temp s] + for some [s -> d] in [mu]. This syntactic property is useful + to show that [parmove] preserves typing, for instance. *) Section PROPERTIES. @@ -1145,36 +1205,23 @@ Qed. Hint Rewrite wf_moves_cons wf_moves_append: pmov. -Definition wf_state (mu sigma tau: moves) : Prop := - wf_moves mu /\ wf_moves sigma /\ wf_moves tau. +Inductive wf_state: state -> Prop := + | wf_state_intro: forall mu sigma tau, + wf_moves mu -> wf_moves sigma -> wf_moves tau -> + wf_state (State mu sigma tau). Lemma dtransition_preserves_wf_state: - forall mu1 sigma1 tau1 mu2 sigma2 tau2, - dtransition mu1 sigma1 tau1 mu2 sigma2 tau2 -> - wf_state mu1 sigma1 tau1 -> wf_state mu2 sigma2 tau2. + forall st st', + dtransition st st' -> wf_state st -> wf_state st'. Proof. - induction 1; intros [A [B C]]; unfold wf_state; - autorewrite with pmov in A; autorewrite with pmov in B; - autorewrite with pmov in C; autorewrite with pmov. - - tauto. - - tauto. - - tauto. - - intuition. apply wf_move_temp_left; auto. + induction 1; intro WF; inv WF; constructor; autorewrite with pmov in *; intuition. + apply wf_move_temp_left; auto. eapply wf_move_temp_right; eauto. - - intuition. - - intuition. Qed. Lemma dtransitions_preserve_wf_state: - forall mu1 sigma1 tau1 mu2 sigma2 tau2, - dtransitions mu1 sigma1 tau1 mu2 sigma2 tau2 -> - wf_state mu1 sigma1 tau1 -> wf_state mu2 sigma2 tau2. + forall st st', + dtransitions st st' -> wf_state st -> wf_state st'. Proof. induction 1; intros; eauto. eapply dtransition_preserves_wf_state; eauto. @@ -1186,14 +1233,14 @@ Lemma parmove_wf_moves: forall mu, wf_moves mu (parmove mu). Proof. intros. - assert (wf_state mu mu nil nil). - split. red; intros. apply wf_move_same. auto. - split. red; simpl; tauto. red; simpl; tauto. + assert (wf_state mu (State mu nil nil)). + constructor. red; intros. apply wf_move_same. auto. + red; simpl; tauto. red; simpl; tauto. generalize (dtransitions_preserve_wf_state mu - _ _ _ _ _ _ - (parmove_aux_transitions mu nil nil) H). - intros [A [B C]]. - unfold parmove. red; intros. apply C. + _ _ + (parmove_aux_transitions (State mu nil nil)) H). + intro WFS. inv WFS. + unfold parmove. red; intros. apply H5. rewrite List.In_rev. auto. Qed. diff --git a/runtime/Makefile b/runtime/Makefile new file mode 100644 index 00000000..c45c9fb8 --- /dev/null +++ b/runtime/Makefile @@ -0,0 +1,13 @@ +CFLAGS=-arch ppc -O1 -g -Wall +#CFLAGS=-O1 -g -Wall +OBJS=stdio.o calloc.o +LIB=libcompcert.a + +$(LIB): $(OBJS) + rm -f $(LIB) + ar rcs $(LIB) $(OBJS) + +stdio.o: stdio.h + +clean: + rm -f *.o $(LIB) diff --git a/runtime/calloc.c b/runtime/calloc.c new file mode 100644 index 00000000..2526cebf --- /dev/null +++ b/runtime/calloc.c @@ -0,0 +1,13 @@ +#include +#include +#include + +void * compcert_alloc(int sz) +{ + void * res = malloc(sz); + if (res == NULL) { + fprintf(stderr, "Out of memory in compcert_alloc().\n"); + abort(); + } + return res; +} diff --git a/runtime/stdio.c b/runtime/stdio.c new file mode 100644 index 00000000..c1532572 --- /dev/null +++ b/runtime/stdio.c @@ -0,0 +1,152 @@ +#include +#include +#define _INSIDE_COMPCERT_COMPATIBILITY_LIBRARY +#include "stdio.h" + +static compcert_FILE * compcert_alloc_file(FILE * f) +{ + struct compcert_FILE_ * r; + r = malloc(sizeof(struct compcert_FILE_)); + if (r == NULL) return NULL; + r->fstr = (void *) f; + return r; +} + +compcert_FILE * compcert_stdin; +compcert_FILE * compcert_stdout; +compcert_FILE * compcert_stderr; + +static __attribute__((constructor)) void compcert_stdio_init(void) +{ + compcert_stdin = compcert_alloc_file(stdin); + compcert_stdout = compcert_alloc_file(stdout); + compcert_stderr = compcert_alloc_file(stderr); +} + +void compcert_clearerr(compcert_FILE * f) +{ + clearerr((FILE *)(f->fstr)); +} + +int compcert_fclose(compcert_FILE * f) +{ + int errcode = fclose((FILE *)(f->fstr)); + free(f); + return errcode; +} + +int compcert_feof(compcert_FILE * f) +{ + return feof((FILE *)(f->fstr)); +} + +int compcert_ferror(compcert_FILE * f) +{ + return ferror((FILE *)(f->fstr)); +} + +int compcert_fflush(compcert_FILE * f) +{ + return fflush((FILE *)(f->fstr)); +} + +int compcert_fgetc(compcert_FILE * f) +{ + return fgetc((FILE *)(f->fstr)); +} + +char *compcert_fgets(char * s, int n, compcert_FILE * f) +{ + return fgets(s, n, (FILE *)(f->fstr)); +} + +compcert_FILE *compcert_fopen(const char * p, const char * m) +{ + FILE * f = fopen(p, m); + if (f == NULL) return NULL; + return compcert_alloc_file(f); +} + +int compcert_fprintf(compcert_FILE * f, const char * s, ...) +{ + va_list ap; + int retcode; + va_start(ap, s); + retcode = vfprintf((FILE *)(f->fstr), s, ap); + va_end(ap); + return retcode; +} + +int compcert_fputc(int c, compcert_FILE * f) +{ + return fputc(c, (FILE *)(f->fstr)); +} + +int compcert_fputs(const char * s, compcert_FILE * f) +{ + return fputs(s, (FILE *)(f->fstr)); +} + +size_t compcert_fread(void * s, size_t p, size_t q, compcert_FILE * f) +{ + return fread(s, p, q, (FILE *)(f->fstr)); +} + +compcert_FILE *compcert_freopen(const char * s, const char * m, + compcert_FILE * f) +{ + FILE * nf = freopen(s, m, (FILE *)(f->fstr)); + if (nf == NULL) return NULL; + f->fstr = nf; + return f; +} + +int compcert_fscanf(compcert_FILE * f, const char * s, ...) +{ + va_list ap; + int retcode; + va_start(ap, s); + retcode = vfscanf((FILE *)(f->fstr), s, ap); + va_end(ap); + return retcode; +} + +int compcert_fseek(compcert_FILE * f, long p, int q) +{ + return fseek((FILE *)(f->fstr), p, q); +} + +long compcert_ftell(compcert_FILE *f) +{ + return ftell((FILE *)(f->fstr)); +} + +size_t compcert_fwrite(const void * b, size_t p, size_t q, compcert_FILE * f) +{ + return fwrite(b, p, q, (FILE *)(f->fstr)); +} + +int compcert_getc(compcert_FILE * f) +{ + return getc((FILE *)(f->fstr)); +} + +int compcert_putc(int c , compcert_FILE * f) +{ + return putc(c, (FILE *)(f->fstr)); +} + +void compcert_rewind(compcert_FILE * f) +{ + rewind((FILE *)(f->fstr)); +} + +int compcert_ungetc(int c, compcert_FILE * f) +{ + return ungetc(c, (FILE *)(f->fstr)); +} + +int compcert_vfprintf(compcert_FILE * f, const char * s, va_list va) +{ + return vfprintf((FILE *)(f->fstr), s, va); +} diff --git a/runtime/stdio.h b/runtime/stdio.h new file mode 100644 index 00000000..2442dcb1 --- /dev/null +++ b/runtime/stdio.h @@ -0,0 +1,67 @@ +#ifndef _COMPCERT_STDIO_H +#define _COMPCERT_STDIO_H + +#include "/usr/include/stdio.h" + +typedef struct compcert_FILE_ { void * fstr; } compcert_FILE; + +extern compcert_FILE * compcert_stdin; +extern compcert_FILE * compcert_stdout; +extern compcert_FILE * compcert_stderr; +extern void compcert_clearerr(compcert_FILE *); +extern int compcert_fclose(compcert_FILE *); +extern int compcert_feof(compcert_FILE *); +extern int compcert_ferror(compcert_FILE *); +extern int compcert_fflush(compcert_FILE *); +extern int compcert_fgetc(compcert_FILE *); +extern char *compcert_fgets(char * , int, compcert_FILE *); +extern compcert_FILE *compcert_fopen(const char * , const char * ); +extern int compcert_fprintf(compcert_FILE * , const char * , ...); +extern int compcert_fputc(int, compcert_FILE *); +extern int compcert_fputs(const char * , compcert_FILE * ); +extern size_t compcert_fread(void * , size_t, size_t, compcert_FILE * ); +extern compcert_FILE *compcert_freopen(const char * , const char * , + compcert_FILE * ); +extern int compcert_fscanf(compcert_FILE * , const char * , ...); +extern int compcert_fseek(compcert_FILE *, long, int); +extern long compcert_ftell(compcert_FILE *); +extern size_t compcert_fwrite(const void * , size_t, size_t, compcert_FILE * ); +extern int compcert_getc(compcert_FILE *); +extern int compcert_putc(int, compcert_FILE *); +extern void compcert_rewind(compcert_FILE *); +extern int compcert_ungetc(int, compcert_FILE *); +extern int compcert_vfprintf(compcert_FILE *, const char *, va_list); + +#ifndef _INSIDE_COMPCERT_COMPATIBILITY_LIBRARY +#define FILE compcert_FILE +#undef stdin +#define stdin compcert_stdin +#undef stdout +#define stdout compcert_stdout +#undef stderr +#define stderr compcert_stderr +#define clearerr compcert_clearerr +#define fclose compcert_fclose +#define feof compcert_feof +#define ferror compcert_ferror +#define fflush compcert_fflush +#define fgetc compcert_fgetc +#define fgets compcert_fgets +#define fopen compcert_fopen +#define fprintf compcert_fprintf +#define fputc compcert_fputc +#define fputs compcert_fputs +#define fread compcert_fread +#define freopen compcert_freopen +#define fscanf compcert_fscanf +#define fseek compcert_fseek +#define ftell compcert_ftell +#define fwrite compcert_fwrite +#define getc compcert_getc +#define putc compcert_putc +#define rewind compcert_rewind +#define ungetc compcert_ungetc +#define vfprintf compcert_vfprintf +#endif + +#endif diff --git a/test/c/Makefile b/test/c/Makefile index 88969342..3f4ea40a 100644 --- a/test/c/Makefile +++ b/test/c/Makefile @@ -1,8 +1,7 @@ CCOMP=../../ccomp -CCOMPFLAGS=-dump-c -I../lib +CCOMPFLAGS=-stdlib ../../runtime -dclight -dasm CC=gcc -arch ppc - CFLAGS=-O1 -Wall LIBS= @@ -20,11 +19,11 @@ all: $(PROGS:%=%.compcert) all_gcc: $(PROGS:%=%.gcc) -%.compcert: %.s - $(CC) $(CFLAGS) -o $*.compcert $*.s ../lib/libcompcert.a $(LIBS) +%.compcert: %.c $(CCOMP) + $(CCOMP) $(CCOMPFLAGS) -o $*.compcert $*.c $(LIBS) %.s: %.c ../../ccomp - $(CCOMP) $(CCOMPFLAGS) $*.c + $(CCOMP) $(CCOMPFLAGS) -S $*.c %.gcc: %.c $(CC) $(CFLAGS) -o $*.gcc $*.c $(LIBS) diff --git a/test/c/knucleotide.c b/test/c/knucleotide.c index 955af7f9..f7438926 100644 --- a/test/c/knucleotide.c +++ b/test/c/knucleotide.c @@ -8,11 +8,7 @@ http://cvs.alioth.debian.org/cgi-bin/cvsweb.cgi/shootout/bench/Include/?cvsroot=shootout */ -#ifdef __COMPCERT__ -#include -#else #include -#endif #include #include #include diff --git a/test/c/mandelbrot.c b/test/c/mandelbrot.c index f4c0db1b..93aa8acb 100644 --- a/test/c/mandelbrot.c +++ b/test/c/mandelbrot.c @@ -10,11 +10,7 @@ compile flags: -O3 -ffast-math -march=pentium4 -funroll-loops */ -#ifdef __COMPCERT__ -#include -#else #include -#endif #include int main (int argc, char **argv) diff --git a/test/cminor/Makefile b/test/cminor/Makefile index 29ebf699..9d2dfdb9 100644 --- a/test/cminor/Makefile +++ b/test/cminor/Makefile @@ -1,4 +1,5 @@ CCOMP=../../ccomp +FLAGS=-S CPP=cpp -P CC=gcc CFLAGS=-arch ppc -g @@ -69,6 +70,11 @@ marksweep: marksweep.o maingc.o marksweepcheck.o clean:: rm -f stopcopy +switchtbl: switchtbl.o mainswitchtbl.o + $(CC) $(CFLAGS) -o switchtbl switchtbl.o mainswitchtbl.o +clean:: + rm -f switchtbl + .SUFFIXES: .SUFFIXES: .cmp .cm .s .o .c .S diff --git a/test/cminor/sha1.cmp b/test/cminor/sha1.cmp index ca245443..31c4b178 100644 --- a/test/cminor/sha1.cmp +++ b/test/cminor/sha1.cmp @@ -54,7 +54,7 @@ extern "memset" : int -> int -> int -> void "SHA1_transform"(ctx) : int -> void { - stack 320 + stack 320; var i, p, a, b, c, d, e, t; /* Convert buffer data to 16 big-endian integers */ diff --git a/test/cminor/switchtbl.cm b/test/cminor/switchtbl.cm new file mode 100644 index 00000000..07bda7ed --- /dev/null +++ b/test/cminor/switchtbl.cm @@ -0,0 +1,16 @@ +"f"(x): int -> int +{ + match (x) { + case 0: return 00; + case 1: return 11; + case 2: return 22; + case 3: return 33; + case 4: return 44; + case 5: return 55; + case 6: return 66; + case 7: return 77; + case 8: return 88; + case 9: return 99; +} +} + diff --git a/test/harness/mainlists.c b/test/harness/mainlists.c index ef11f6ef..281b919f 100644 --- a/test/harness/mainlists.c +++ b/test/harness/mainlists.c @@ -2,11 +2,6 @@ #include #include -void * compcert_alloc(int sz) -{ - return malloc(sz); -} - struct cons { int hd; struct cons * tl; }; typedef struct cons * list; diff --git a/test/harness/mainswitchtbl.c b/test/harness/mainswitchtbl.c new file mode 100644 index 00000000..24ba17e7 --- /dev/null +++ b/test/harness/mainswitchtbl.c @@ -0,0 +1,11 @@ +#include +#include + +extern int f(int); + +int main(int argc, char ** argv) +{ + int i; + for (i = 0; i < 10; i++) printf("%2d -> %2d\n", i, f(i)); + return 0; +} -- cgit