From 6d25b4f3fc23601b3a84b4a70aab40ba429ac4b9 Mon Sep 17 00:00:00 2001 From: xleroy Date: Tue, 30 Dec 2008 14:48:33 +0000 Subject: Reorganized the development, modularizing away machine-dependent parts. Started to merge the ARM code generator. Started to add support for PowerPC/EABI. Use ocamlbuild to construct executable from Caml files. git-svn-id: https://yquem.inria.fr/compcert/svn/compcert/trunk@930 fca1b0fc-160b-0410-b1d3-a4f43f01ea2e --- .depend | 135 ++-- Makefile | 59 +- arm/Asmgen.v | 554 ++++++++++++++ arm/Asmgenproof.v | 1246 +++++++++++++++++++++++++++++++ arm/Asmgenproof1.v | 1507 +++++++++++++++++++++++++++++++++++++ arm/Asmgenretaddr.v | 201 +++++ arm/Constprop.v | 1254 +++++++++++++++++++++++++++++++ arm/Constpropproof.v | 970 ++++++++++++++++++++++++ arm/Machregs.v | 80 ++ arm/Op.v | 1007 +++++++++++++++++++++++++ arm/Selection.v | 1394 ++++++++++++++++++++++++++++++++++ arm/Selectionproof.v | 1475 ++++++++++++++++++++++++++++++++++++ arm/linux/Conventions.v | 858 +++++++++++++++++++++ arm/linux/Stacklayout.v | 79 ++ backend/CMlexer.mli | 17 + backend/CMlexer.mll | 132 ++++ backend/CMparser.mly | 541 ++++++++++++++ backend/CMtypecheck.ml | 370 +++++++++ backend/CMtypecheck.mli | 19 + backend/CSE.v | 7 +- backend/Coloringaux.ml | 626 ++++++++++++++++ backend/Coloringaux.mli | 20 + backend/Constprop.v | 1093 --------------------------- backend/Constpropproof.v | 954 ------------------------ backend/Conventions.v | 805 -------------------- backend/Linear.v | 2 +- backend/Linearizeaux.ml | 85 +++ backend/Linearizeproof.v | 6 +- backend/Locations.v | 93 +-- backend/Machabstr.v | 6 +- backend/Machabstr2concr.v | 4 +- backend/Machconcr.v | 18 +- backend/Op.v | 906 ----------------------- backend/PPC.v | 843 --------------------- backend/PPCgen.v | 548 -------------- backend/PPCgenproof.v | 1393 ---------------------------------- backend/PPCgenproof1.v | 1686 ------------------------------------------ backend/PPCgenretaddr.v | 188 ----- backend/RTLgenaux.ml | 72 ++ backend/RTLtypingaux.ml | 156 ++++ backend/Reloadproof.v | 6 +- backend/Selection.v | 1196 ------------------------------ backend/Selectionproof.v | 1398 ---------------------------------- backend/Stacking.v | 55 +- backend/Stackingproof.v | 103 +-- backend/Stackingtyping.v | 1 + caml/CMlexer.mli | 17 - caml/CMlexer.mll | 132 ---- caml/CMparser.mly | 541 -------------- caml/CMtypecheck.ml | 370 --------- caml/CMtypecheck.mli | 19 - caml/Camlcoq.ml | 130 ---- caml/Cil2Csyntax.ml | 992 ------------------------- caml/Clflags.ml | 25 - caml/Coloringaux.ml | 625 ---------------- caml/Coloringaux.mli | 20 - caml/Driver.ml | 352 --------- caml/Floataux.ml | 39 - caml/Linearizeaux.ml | 85 --- caml/PrintCsyntax.ml | 501 ------------- caml/PrintPPC.ml | 532 ------------- caml/PrintPPC.mli | 13 - caml/RTLgenaux.ml | 72 -- caml/RTLtypingaux.ml | 156 ---- cfrontend/Cil2Csyntax.ml | 992 +++++++++++++++++++++++++ cfrontend/PrintCsyntax.ml | 501 +++++++++++++ common/Complements.v | 651 ---------------- common/Main.v | 305 -------- configure | 97 ++- coq | 5 +- driver/Clflags.ml | 25 + driver/Compiler.v | 305 ++++++++ driver/Complements.v | 648 ++++++++++++++++ driver/Driver.ml | 352 +++++++++ extraction/.depend | 529 ------------- extraction/Kildall.ml.patch | 4 +- extraction/Makefile | 117 +-- extraction/extraction.v | 22 +- lib/Camlcoq.ml | 130 ++++ lib/Floataux.ml | 39 + powerpc/Asm.v | 880 ++++++++++++++++++++++ powerpc/Asmgen.v | 510 +++++++++++++ powerpc/Asmgenproof.v | 1394 ++++++++++++++++++++++++++++++++++ powerpc/Asmgenproof1.v | 1632 ++++++++++++++++++++++++++++++++++++++++ powerpc/Asmgenretaddr.v | 188 +++++ powerpc/Constprop.v | 1093 +++++++++++++++++++++++++++ powerpc/Constpropproof.v | 954 ++++++++++++++++++++++++ powerpc/Machregs.v | 107 +++ powerpc/Op.v | 925 +++++++++++++++++++++++ powerpc/PrintAsm.ml | 532 +++++++++++++ powerpc/PrintAsm.mli | 13 + powerpc/Selection.v | 1196 ++++++++++++++++++++++++++++++ powerpc/Selectionproof.v | 1398 ++++++++++++++++++++++++++++++++++ powerpc/eabi/Conventions.v | 798 ++++++++++++++++++++ powerpc/eabi/Stacklayout.v | 79 ++ powerpc/macosx/Conventions.v | 805 ++++++++++++++++++++ powerpc/macosx/Stacklayout.v | 79 ++ 97 files changed, 28505 insertions(+), 17589 deletions(-) create mode 100644 arm/Asmgen.v create mode 100644 arm/Asmgenproof.v create mode 100644 arm/Asmgenproof1.v create mode 100644 arm/Asmgenretaddr.v create mode 100644 arm/Constprop.v create mode 100644 arm/Constpropproof.v create mode 100644 arm/Machregs.v create mode 100644 arm/Op.v create mode 100644 arm/Selection.v create mode 100644 arm/Selectionproof.v create mode 100644 arm/linux/Conventions.v create mode 100644 arm/linux/Stacklayout.v create mode 100644 backend/CMlexer.mli create mode 100644 backend/CMlexer.mll create mode 100644 backend/CMparser.mly create mode 100644 backend/CMtypecheck.ml create mode 100644 backend/CMtypecheck.mli create mode 100644 backend/Coloringaux.ml create mode 100644 backend/Coloringaux.mli delete mode 100644 backend/Constprop.v delete mode 100644 backend/Constpropproof.v delete mode 100644 backend/Conventions.v create mode 100644 backend/Linearizeaux.ml delete mode 100644 backend/Op.v delete mode 100644 backend/PPC.v delete mode 100644 backend/PPCgen.v delete mode 100644 backend/PPCgenproof.v delete mode 100644 backend/PPCgenproof1.v delete mode 100644 backend/PPCgenretaddr.v create mode 100644 backend/RTLgenaux.ml create mode 100644 backend/RTLtypingaux.ml delete mode 100644 backend/Selection.v delete mode 100644 backend/Selectionproof.v delete mode 100644 caml/CMlexer.mli delete mode 100644 caml/CMlexer.mll delete mode 100644 caml/CMparser.mly delete mode 100644 caml/CMtypecheck.ml delete mode 100644 caml/CMtypecheck.mli delete mode 100644 caml/Camlcoq.ml delete mode 100644 caml/Cil2Csyntax.ml delete mode 100644 caml/Clflags.ml delete mode 100644 caml/Coloringaux.ml delete mode 100644 caml/Coloringaux.mli delete mode 100644 caml/Driver.ml delete mode 100644 caml/Floataux.ml delete mode 100644 caml/Linearizeaux.ml delete mode 100644 caml/PrintCsyntax.ml delete mode 100644 caml/PrintPPC.ml delete mode 100644 caml/PrintPPC.mli delete mode 100644 caml/RTLgenaux.ml delete mode 100644 caml/RTLtypingaux.ml create mode 100644 cfrontend/Cil2Csyntax.ml create mode 100644 cfrontend/PrintCsyntax.ml delete mode 100644 common/Complements.v delete mode 100644 common/Main.v create mode 100644 driver/Clflags.ml create mode 100644 driver/Compiler.v create mode 100644 driver/Complements.v create mode 100644 driver/Driver.ml delete mode 100644 extraction/.depend create mode 100644 lib/Camlcoq.ml create mode 100644 lib/Floataux.ml create mode 100644 powerpc/Asm.v create mode 100644 powerpc/Asmgen.v create mode 100644 powerpc/Asmgenproof.v create mode 100644 powerpc/Asmgenproof1.v create mode 100644 powerpc/Asmgenretaddr.v create mode 100644 powerpc/Constprop.v create mode 100644 powerpc/Constpropproof.v create mode 100644 powerpc/Machregs.v create mode 100644 powerpc/Op.v create mode 100644 powerpc/PrintAsm.ml create mode 100644 powerpc/PrintAsm.mli create mode 100644 powerpc/Selection.v create mode 100644 powerpc/Selectionproof.v create mode 100644 powerpc/eabi/Conventions.v create mode 100644 powerpc/eabi/Stacklayout.v create mode 100644 powerpc/macosx/Conventions.v create mode 100644 powerpc/macosx/Stacklayout.v diff --git a/.depend b/.depend index be224c4..b0f9868 100644 --- a/.depend +++ b/.depend @@ -1,82 +1,85 @@ lib/Coqlib.vo: lib/Coqlib.v -lib/Maps.vo: lib/Maps.v lib/Coqlib.vo +lib/Floats.vo: lib/Floats.v lib/Coqlib.vo lib/Integers.vo +lib/Inclusion.vo: lib/Inclusion.v +lib/Integers.vo: lib/Integers.v lib/Coqlib.vo +lib/Iteration.vo: lib/Iteration.v lib/Coqlib.vo lib/Lattice.vo: lib/Lattice.v lib/Coqlib.vo lib/Maps.vo +lib/Maps.vo: lib/Maps.v lib/Coqlib.vo lib/Ordered.vo: lib/Ordered.v lib/Coqlib.vo lib/Maps.vo -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/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/Errors.vo: common/Errors.v lib/Coqlib.vo common/Events.vo: common/Events.v lib/Coqlib.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Mem.vo common/Globalenvs.vo: common/Globalenvs.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Mem.vo common/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/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 -common/Complements.vo: common/Complements.v lib/Coqlib.vo common/AST.vo lib/Integers.vo common/Values.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo cfrontend/Csyntax.vo cfrontend/Csem.vo backend/PPC.vo common/Main.vo common/Errors.vo +common/Values.vo: common/Values.v lib/Coqlib.vo common/AST.vo lib/Integers.vo lib/Floats.vo +$(ARCH)/$(VARIANT)/Conventions.vo: $(ARCH)/$(VARIANT)/Conventions.v lib/Coqlib.vo common/AST.vo backend/Locations.vo +$(ARCH)/$(VARIANT)/Stacklayout.vo: $(ARCH)/$(VARIANT)/Stacklayout.v lib/Coqlib.vo backend/Bounds.vo +$(ARCH)/Asmgenproof1.vo: $(ARCH)/Asmgenproof1.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Mem.vo common/Globalenvs.vo $(ARCH)/Op.vo backend/Locations.vo backend/Mach.vo backend/Machconcr.vo backend/Machtyping.vo $(ARCH)/Asm.vo $(ARCH)/Asmgen.vo $(ARCH)/$(VARIANT)/Conventions.vo +$(ARCH)/Asmgenproof.vo: $(ARCH)/Asmgenproof.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Mem.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Locations.vo backend/Mach.vo backend/Machconcr.vo backend/Machtyping.vo $(ARCH)/Asm.vo $(ARCH)/Asmgen.vo $(ARCH)/Asmgenretaddr.vo $(ARCH)/Asmgenproof1.vo +$(ARCH)/Asmgenretaddr.vo: $(ARCH)/Asmgenretaddr.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Mem.vo common/Globalenvs.vo $(ARCH)/Op.vo backend/Locations.vo backend/Mach.vo $(ARCH)/Asm.vo $(ARCH)/Asmgen.vo +$(ARCH)/Asmgen.vo: $(ARCH)/Asmgen.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Mem.vo common/Globalenvs.vo $(ARCH)/Op.vo backend/Locations.vo backend/Mach.vo $(ARCH)/Asm.vo +$(ARCH)/Asm.vo: $(ARCH)/Asm.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Mem.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo backend/Locations.vo $(ARCH)/$(VARIANT)/Stacklayout.vo $(ARCH)/$(VARIANT)/Conventions.vo +$(ARCH)/Constpropproof.vo: $(ARCH)/Constpropproof.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Events.vo common/Mem.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo lib/Lattice.vo backend/Kildall.vo $(ARCH)/Constprop.vo +$(ARCH)/Constprop.vo: $(ARCH)/Constprop.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Globalenvs.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo lib/Lattice.vo backend/Kildall.vo +$(ARCH)/Machregs.vo: $(ARCH)/Machregs.v lib/Coqlib.vo lib/Maps.vo common/AST.vo +$(ARCH)/Op.vo: $(ARCH)/Op.v lib/Coqlib.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Mem.vo common/Globalenvs.vo +$(ARCH)/Selectionproof.vo: $(ARCH)/Selectionproof.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Mem.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo backend/Cminor.vo $(ARCH)/Op.vo backend/CminorSel.vo $(ARCH)/Selection.vo +$(ARCH)/Selection.vo: $(ARCH)/Selection.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Mem.vo common/Globalenvs.vo backend/Cminor.vo $(ARCH)/Op.vo backend/CminorSel.vo +backend/Allocation.vo: backend/Allocation.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo lib/Lattice.vo common/AST.vo lib/Integers.vo common/Values.vo common/Globalenvs.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo backend/RTLtyping.vo backend/Kildall.vo backend/Locations.vo $(ARCH)/$(VARIANT)/Conventions.vo backend/Coloring.vo backend/LTL.vo +backend/Allocproof.vo: backend/Allocproof.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Mem.vo common/Events.vo common/Smallstep.vo common/Globalenvs.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo backend/RTLtyping.vo backend/Locations.vo $(ARCH)/$(VARIANT)/Conventions.vo backend/Coloring.vo backend/Coloringproof.vo backend/Allocation.vo backend/LTL.vo +backend/Alloctyping.vo: backend/Alloctyping.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo common/AST.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo backend/Locations.vo backend/LTL.vo backend/Coloring.vo backend/Coloringproof.vo backend/Allocation.vo backend/Allocproof.vo backend/RTLtyping.vo backend/LTLtyping.vo $(ARCH)/$(VARIANT)/Conventions.vo +backend/Bounds.vo: backend/Bounds.v lib/Coqlib.vo lib/Maps.vo common/AST.vo $(ARCH)/Op.vo backend/Locations.vo backend/Linear.vo backend/Lineartyping.vo $(ARCH)/$(VARIANT)/Conventions.vo +backend/CminorSel.vo: backend/CminorSel.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Events.vo common/Values.vo common/Mem.vo backend/Cminor.vo $(ARCH)/Op.vo common/Globalenvs.vo common/Switch.vo common/Smallstep.vo backend/Cminor.vo: backend/Cminor.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Events.vo common/Values.vo common/Mem.vo common/Globalenvs.vo common/Smallstep.vo common/Switch.vo -backend/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/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 common/Smallstep.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 common/Smallstep.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 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 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 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 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/Coloringproof.vo: backend/Coloringproof.v lib/Coqlib.vo lib/Maps.vo common/AST.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo backend/RTLtyping.vo backend/Locations.vo $(ARCH)/$(VARIANT)/Conventions.vo backend/InterfGraph.vo backend/Coloring.vo +backend/Coloring.vo: backend/Coloring.v lib/Coqlib.vo lib/Maps.vo common/AST.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo backend/RTLtyping.vo backend/Locations.vo $(ARCH)/$(VARIANT)/Conventions.vo backend/InterfGraph.vo +backend/CSEproof.vo: backend/CSEproof.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Mem.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo backend/Kildall.vo backend/CSE.vo +backend/CSE.vo: backend/CSE.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Mem.vo common/Globalenvs.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo backend/Kildall.vo backend/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/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 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/LTLtyping.vo backend/Conventions.vo -backend/Linearize.vo: backend/Linearize.v lib/Coqlib.vo lib/Maps.vo lib/Ordered.vo common/AST.vo common/Values.vo common/Globalenvs.vo common/Errors.vo 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 lib/Ordered.vo common/AST.vo lib/Integers.vo common/Values.vo common/Mem.vo common/Events.vo common/Globalenvs.vo common/Errors.vo common/Smallstep.vo 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/Errors.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/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/Stacking.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/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/Stacking.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/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 +backend/Kildall.vo: backend/Kildall.v lib/Coqlib.vo lib/Iteration.vo lib/Maps.vo lib/Lattice.vo lib/Ordered.vo +backend/Linearizeproof.vo: backend/Linearizeproof.v lib/Coqlib.vo lib/Maps.vo lib/Ordered.vo common/AST.vo lib/Integers.vo common/Values.vo common/Mem.vo common/Events.vo common/Globalenvs.vo common/Errors.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Locations.vo backend/LTL.vo backend/LTLtyping.vo backend/LTLin.vo backend/Linearize.vo lib/Lattice.vo +backend/Linearizetyping.vo: backend/Linearizetyping.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo common/AST.vo $(ARCH)/Op.vo backend/Locations.vo backend/LTL.vo backend/LTLtyping.vo backend/LTLin.vo backend/Linearize.vo backend/LTLintyping.vo $(ARCH)/$(VARIANT)/Conventions.vo +backend/Linearize.vo: backend/Linearize.v lib/Coqlib.vo lib/Maps.vo lib/Ordered.vo common/AST.vo common/Values.vo common/Globalenvs.vo common/Errors.vo $(ARCH)/Op.vo backend/Locations.vo backend/LTL.vo backend/LTLin.vo backend/Kildall.vo lib/Lattice.vo +backend/Lineartyping.vo: backend/Lineartyping.v lib/Coqlib.vo lib/Maps.vo common/AST.vo $(ARCH)/Op.vo backend/RTL.vo backend/Locations.vo backend/Linear.vo $(ARCH)/$(VARIANT)/Conventions.vo +backend/Linear.vo: backend/Linear.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Mem.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Locations.vo backend/LTL.vo $(ARCH)/$(VARIANT)/Conventions.vo +backend/Locations.vo: backend/Locations.v lib/Coqlib.vo lib/Maps.vo common/AST.vo common/Values.vo $(ARCH)/Machregs.vo +backend/LTLintyping.vo: backend/LTLintyping.v lib/Coqlib.vo lib/Maps.vo common/AST.vo $(ARCH)/Op.vo backend/RTL.vo backend/Locations.vo backend/LTLin.vo backend/LTLtyping.vo $(ARCH)/$(VARIANT)/Conventions.vo +backend/LTLin.vo: backend/LTLin.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Mem.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Locations.vo backend/LTL.vo $(ARCH)/$(VARIANT)/Conventions.vo +backend/LTLtyping.vo: backend/LTLtyping.v lib/Coqlib.vo lib/Maps.vo common/AST.vo $(ARCH)/Op.vo backend/RTL.vo backend/Locations.vo backend/LTL.vo $(ARCH)/$(VARIANT)/Conventions.vo +backend/LTL.vo: backend/LTL.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Events.vo common/Mem.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Locations.vo $(ARCH)/$(VARIANT)/Conventions.vo +backend/Machabstr2concr.vo: backend/Machabstr2concr.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Mem.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Locations.vo backend/Mach.vo backend/Machtyping.vo backend/Machabstr.vo backend/Machconcr.vo $(ARCH)/Asmgenretaddr.vo +backend/Machabstr.vo: backend/Machabstr.v lib/Coqlib.vo lib/Maps.vo common/AST.vo common/Mem.vo lib/Integers.vo common/Values.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Locations.vo $(ARCH)/$(VARIANT)/Conventions.vo backend/Mach.vo $(ARCH)/$(VARIANT)/Stacklayout.vo +backend/Machconcr.vo: backend/Machconcr.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Mem.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Locations.vo $(ARCH)/$(VARIANT)/Conventions.vo backend/Mach.vo $(ARCH)/$(VARIANT)/Stacklayout.vo $(ARCH)/Asmgenretaddr.vo +backend/Machtyping.vo: backend/Machtyping.v lib/Coqlib.vo lib/Maps.vo common/AST.vo common/Mem.vo lib/Integers.vo common/Values.vo common/Events.vo common/Globalenvs.vo $(ARCH)/Op.vo backend/Locations.vo $(ARCH)/$(VARIANT)/Conventions.vo backend/Mach.vo backend/Machabstr.vo +backend/Mach.vo: backend/Mach.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Mem.vo common/Events.vo common/Globalenvs.vo $(ARCH)/Op.vo backend/Locations.vo +backend/Parallelmove.vo: backend/Parallelmove.v lib/Coqlib.vo lib/Parmov.vo common/Values.vo common/Events.vo common/AST.vo backend/Locations.vo $(ARCH)/$(VARIANT)/Conventions.vo +backend/Registers.vo: backend/Registers.v lib/Coqlib.vo common/AST.vo lib/Maps.vo lib/Ordered.vo +backend/Reloadproof.vo: backend/Reloadproof.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Mem.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Locations.vo $(ARCH)/$(VARIANT)/Conventions.vo backend/Allocproof.vo backend/LTLin.vo backend/LTLintyping.vo backend/Linear.vo backend/Parallelmove.vo backend/Reload.vo +backend/Reloadtyping.vo: backend/Reloadtyping.v lib/Coqlib.vo lib/Maps.vo common/AST.vo $(ARCH)/Op.vo backend/Locations.vo backend/LTLin.vo backend/LTLintyping.vo backend/Linear.vo backend/Lineartyping.vo $(ARCH)/$(VARIANT)/Conventions.vo backend/Parallelmove.vo backend/Reload.vo backend/Reloadproof.vo +backend/Reload.vo: backend/Reload.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Globalenvs.vo $(ARCH)/Op.vo backend/Locations.vo backend/LTLin.vo $(ARCH)/$(VARIANT)/Conventions.vo backend/Parallelmove.vo backend/Linear.vo +backend/RTLgenproof.vo: backend/RTLgenproof.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Mem.vo common/Events.vo common/Smallstep.vo common/Globalenvs.vo common/Switch.vo backend/Registers.vo backend/Cminor.vo $(ARCH)/Op.vo backend/CminorSel.vo backend/RTL.vo backend/RTLgen.vo backend/RTLgenspec.vo common/Errors.vo +backend/RTLgenspec.vo: backend/RTLgenspec.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Events.vo common/Mem.vo common/Globalenvs.vo common/Switch.vo $(ARCH)/Op.vo backend/Registers.vo backend/CminorSel.vo backend/RTL.vo backend/RTLgen.vo +backend/RTLgen.vo: backend/RTLgen.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Switch.vo $(ARCH)/Op.vo backend/Registers.vo backend/CminorSel.vo backend/RTL.vo +backend/RTLtyping.vo: backend/RTLtyping.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo common/AST.vo $(ARCH)/Op.vo backend/Registers.vo backend/RTL.vo $(ARCH)/$(VARIANT)/Conventions.vo common/Globalenvs.vo common/Values.vo common/Mem.vo lib/Integers.vo common/Events.vo common/Smallstep.vo +backend/RTL.vo: backend/RTL.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo common/Values.vo common/Events.vo common/Mem.vo common/Globalenvs.vo common/Smallstep.vo $(ARCH)/Op.vo backend/Registers.vo +backend/Stackingproof.vo: backend/Stackingproof.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo common/AST.vo lib/Integers.vo common/Values.vo $(ARCH)/Op.vo common/Mem.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo backend/Locations.vo backend/Linear.vo backend/Lineartyping.vo backend/Mach.vo backend/Machabstr.vo backend/Bounds.vo $(ARCH)/$(VARIANT)/Conventions.vo $(ARCH)/$(VARIANT)/Stacklayout.vo backend/Stacking.vo +backend/Stackingtyping.vo: backend/Stackingtyping.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo lib/Integers.vo common/AST.vo $(ARCH)/Op.vo backend/Locations.vo $(ARCH)/$(VARIANT)/Conventions.vo backend/Linear.vo backend/Lineartyping.vo backend/Mach.vo backend/Machtyping.vo backend/Bounds.vo $(ARCH)/$(VARIANT)/Stacklayout.vo backend/Stacking.vo backend/Stackingproof.vo +backend/Stacking.vo: backend/Stacking.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo common/AST.vo lib/Integers.vo $(ARCH)/Op.vo backend/RTL.vo backend/Locations.vo backend/Linear.vo backend/Bounds.vo backend/Mach.vo $(ARCH)/$(VARIANT)/Conventions.vo $(ARCH)/$(VARIANT)/Stacklayout.vo +backend/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 $(ARCH)/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 $(ARCH)/Op.vo backend/Locations.vo backend/LTL.vo backend/LTLtyping.vo backend/Tunneling.vo backend/Tunnelingproof.vo +backend/Tunneling.vo: backend/Tunneling.v lib/Coqlib.vo lib/Maps.vo common/AST.vo common/Values.vo common/Globalenvs.vo $(ARCH)/Op.vo backend/Locations.vo backend/LTL.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 $(ARCH)/Op.vo backend/Cminor.vo cfrontend/Cminorgen.vo +cfrontend/Cminorgen.vo: cfrontend/Cminorgen.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo lib/Ordered.vo common/AST.vo lib/Integers.vo common/Mem.vo cfrontend/Csharpminor.vo $(ARCH)/Op.vo backend/Cminor.vo cfrontend/Csem.vo: cfrontend/Csem.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/AST.vo common/Mem.vo common/Events.vo common/Globalenvs.vo cfrontend/Csyntax.vo common/Smallstep.vo -cfrontend/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 common/Errors.vo lib/Integers.vo lib/Floats.vo common/AST.vo cfrontend/Csyntax.vo backend/Cminor.vo cfrontend/Csharpminor.vo +cfrontend/Csharpminor.vo: cfrontend/Csharpminor.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Mem.vo common/Events.vo common/Globalenvs.vo backend/Cminor.vo common/Smallstep.vo cfrontend/Cshmgenproof1.vo: cfrontend/Cshmgenproof1.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/AST.vo common/Values.vo common/Events.vo common/Mem.vo common/Globalenvs.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Ctyping.vo backend/Cminor.vo cfrontend/Csharpminor.vo cfrontend/Cshmgen.vo cfrontend/Cshmgenproof2.vo: cfrontend/Cshmgenproof2.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/AST.vo common/Values.vo common/Events.vo common/Mem.vo common/Globalenvs.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Ctyping.vo backend/Cminor.vo cfrontend/Csharpminor.vo cfrontend/Cshmgen.vo cfrontend/Cshmgenproof1.vo cfrontend/Cshmgenproof3.vo: cfrontend/Cshmgenproof3.v lib/Coqlib.vo common/Errors.vo lib/Maps.vo lib/Integers.vo lib/Floats.vo common/AST.vo common/Values.vo common/Events.vo common/Mem.vo common/Globalenvs.vo common/Smallstep.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Ctyping.vo backend/Cminor.vo cfrontend/Csharpminor.vo cfrontend/Cshmgen.vo cfrontend/Cshmgenproof1.vo cfrontend/Cshmgenproof2.vo -cfrontend/Csharpminor.vo: cfrontend/Csharpminor.v lib/Coqlib.vo lib/Maps.vo common/AST.vo lib/Integers.vo lib/Floats.vo common/Values.vo common/Mem.vo common/Events.vo common/Globalenvs.vo backend/Cminor.vo common/Smallstep.vo -cfrontend/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/Op.vo backend/Cminor.vo cfrontend/Cminorgen.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/Csyntax.vo: cfrontend/Csyntax.v lib/Coqlib.vo common/Errors.vo lib/Integers.vo lib/Floats.vo common/AST.vo +cfrontend/Ctyping.vo: cfrontend/Ctyping.v lib/Coqlib.vo lib/Maps.vo common/AST.vo cfrontend/Csyntax.vo +driver/Compiler.vo: driver/Compiler.v lib/Coqlib.vo lib/Maps.vo common/Errors.vo common/AST.vo common/Values.vo common/Smallstep.vo cfrontend/Csyntax.vo cfrontend/Csem.vo cfrontend/Csharpminor.vo backend/Cminor.vo backend/CminorSel.vo backend/RTL.vo backend/LTL.vo backend/LTLin.vo backend/Linear.vo backend/Mach.vo $(ARCH)/Asm.vo cfrontend/Cshmgen.vo cfrontend/Cminorgen.vo $(ARCH)/Selection.vo backend/RTLgen.vo $(ARCH)/Constprop.vo backend/CSE.vo backend/Allocation.vo backend/Tunneling.vo backend/Linearize.vo backend/Reload.vo backend/Stacking.vo $(ARCH)/Asmgen.vo cfrontend/Ctyping.vo backend/RTLtyping.vo backend/LTLtyping.vo backend/LTLintyping.vo backend/Lineartyping.vo backend/Machtyping.vo cfrontend/Cshmgenproof3.vo cfrontend/Cminorgenproof.vo $(ARCH)/Selectionproof.vo backend/RTLgenproof.vo $(ARCH)/Constpropproof.vo backend/CSEproof.vo backend/Allocproof.vo backend/Alloctyping.vo backend/Tunnelingproof.vo backend/Tunnelingtyping.vo backend/Linearizeproof.vo backend/Linearizetyping.vo backend/Reloadproof.vo backend/Reloadtyping.vo backend/Stackingproof.vo backend/Stackingtyping.vo backend/Machabstr2concr.vo $(ARCH)/Asmgenproof.vo +driver/Complements.vo: driver/Complements.v lib/Coqlib.vo common/AST.vo lib/Integers.vo common/Values.vo common/Events.vo common/Globalenvs.vo common/Smallstep.vo cfrontend/Csyntax.vo cfrontend/Csem.vo $(ARCH)/Asm.vo driver/Compiler.vo common/Errors.vo diff --git a/Makefile b/Makefile index 58d494c..c2ffceb 100644 --- a/Makefile +++ b/Makefile @@ -15,20 +15,31 @@ include Makefile.config COQC=coqc $(INCLUDES) COQDEP=coqdep $(INCLUDES) COQDOC=coqdoc +OCAMLBUILD=ocamlbuild +OCB_OPTIONS=\ + -no-hygiene \ + -I extraction $(INCLUDES) \ + -cflags -I,`pwd`/cil/obj/$(ARCHOS) \ + -lflags -I,`pwd`/cil/obj/$(ARCHOS) \ + -libs unix,str,cil -INCLUDES=-I lib -I common -I backend -I cfrontend +DIRS=lib common $(ARCH)/$(VARIANT) $(ARCH) backend cfrontend driver -# Files in lib/ +VPATH=$(DIRS) +GPATH=$(DIRS) +INCLUDES=$(patsubst %,-I %, $(DIRS)) + +# General-purpose libraries (in lib/) LIB=Coqlib.v Maps.v Lattice.v Ordered.v \ Iteration.v Integers.v Floats.v Parmov.v -# Files in common/ +# Parts common to the front-ends and the back-end (in common/) COMMON=Errors.v AST.v Events.v Globalenvs.v Mem.v Values.v \ - Smallstep.v Switch.v Main.v Complements.v + Smallstep.v Switch.v -# Files in backend/ +# Back-end modules (in backend/, $(ARCH)/, $(ARCH)/$(VARIANT)) BACKEND=\ Cminor.v Op.v CminorSel.v \ @@ -39,7 +50,7 @@ BACKEND=\ Kildall.v \ Constprop.v Constpropproof.v \ CSE.v CSEproof.v \ - Locations.v Conventions.v LTL.v LTLtyping.v \ + Machregs.v Locations.v Conventions.v LTL.v LTLtyping.v \ InterfGraph.v Coloring.v Coloringproof.v \ Allocation.v Allocproof.v Alloctyping.v \ Tunneling.v Tunnelingproof.v Tunnelingtyping.v \ @@ -48,29 +59,34 @@ BACKEND=\ Linear.v Lineartyping.v \ Parallelmove.v Reload.v Reloadproof.v Reloadtyping.v \ Mach.v Machabstr.v Machtyping.v \ - Bounds.v Stacking.v Stackingproof.v Stackingtyping.v \ + Bounds.v Stacklayout.v Stacking.v Stackingproof.v Stackingtyping.v \ Machconcr.v Machabstr2concr.v \ - PPC.v PPCgen.v PPCgenretaddr.v PPCgenproof1.v PPCgenproof.v + Asm.v Asmgen.v Asmgenretaddr.v Asmgenproof1.v Asmgenproof.v -# Files in cfrontend/ +# C front-end modules (in cfrontend/) CFRONTEND=Csyntax.v Csem.v Ctyping.v Cshmgen.v \ Cshmgenproof1.v Cshmgenproof2.v Cshmgenproof3.v \ Csharpminor.v Cminorgen.v Cminorgenproof.v -# All source files +# Putting everything together (in driver/) + +DRIVER=Compiler.v Complements.v -FILES=$(LIB:%=lib/%) $(COMMON:%=common/%) $(BACKEND:%=backend/%) $(CFRONTEND:%=cfrontend/%) +# All source files -FLATFILES=$(LIB) $(COMMON) $(BACKEND) $(CFRONTEND) +FILES=$(LIB) $(COMMON) $(BACKEND) $(CFRONTEND) $(DRIVER) proof: $(FILES:.v=.vo) +exec: + $(OCAMLBUILD) $(OCB_OPTIONS) Driver.native && mv Driver.native ccomp + all: $(MAKE) proof $(MAKE) -C cil - $(MAKE) -C extraction extraction - $(MAKE) -C extraction depend + $(MAKE) -C extraction + $(MAKE) exec $(MAKE) -C extraction $(MAKE) -C runtime @@ -78,8 +94,8 @@ documentation: doc/removeproofs @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) + $(FILES:%.v=--glob-from %.glob) $(FILES) + @cd doc; rm -f $(FILES) cp doc/coqdoc.css doc/html/coqdoc.css doc/removeproofs doc/html/*.html @@ -100,14 +116,19 @@ latexdoc: @$(COQC) -dump-glob doc/$(*F).glob $*.v depend: - $(COQDEP) $(FILES) > .depend + $(COQDEP) $(patsubst %, %/*.v, $(DIRS)) \ + | sed -e 's|$(ARCH)/$(VARIANT)/|$$(ARCH)/$$(VARIANT)/|g' \ + -e 's|$(ARCH)/|$$(ARCH)/|g' \ + > .depend install: - $(MAKE) -C extraction install + install -d $(BINDIR) + install ../ccomp $(BINDIR) $(MAKE) -C runtime install clean: - rm -f */*.vo *~ */*~ + rm -f $(patsubst %, %/*.vo, $(DIRS)) + rm -rf _build rm -rf doc/html doc/*.glob rm -f doc/removeproofs.ml doc/removeproofs $(MAKE) -C extraction clean diff --git a/arm/Asmgen.v b/arm/Asmgen.v new file mode 100644 index 0000000..a360bde --- /dev/null +++ b/arm/Asmgen.v @@ -0,0 +1,554 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Translation from Mach to ARM. *) + +Require Import Coqlib. +Require Import Maps. +Require Import Errors. +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 Asm. + +(** Translation of the LTL/Linear/Mach view of machine registers + to the ARM view. ARM has two different types for registers + (integer and float) while LTL et al have only one. The + [ireg_of] and [freg_of] are therefore partial in principle. + To keep things simpler, we make them return nonsensical + results when applied to a LTL register of the wrong type. + The proof in [ARMgenproof] will show that this never happens. + + Note that no LTL register maps to [IR14]. + This register is reserved as temporary, to be used + by the generated ARM code. *) + +Definition ireg_of (r: mreg) : ireg := + match r with + | R0 => IR0 | R1 => IR1 | R2 => IR2 | R3 => IR3 + | R4 => IR4 | R5 => IR5 | R6 => IR6 | R7 => IR7 + | R8 => IR8 | R9 => IR9 | R11 => IR11 + | IT1 => IR10 | IT2 => IR12 + | _ => IR0 (* should not happen *) + end. + +Definition freg_of (r: mreg) : freg := + match r with + | F0 => FR0 | F1 => FR1 + | F4 => FR4 | F5 => FR5 | F6 => FR6 | F7 => FR7 + | FT1 => FR2 | FT2 => FR3 + | _ => FR0 (* should not happen *) + end. + +(** Recognition of integer immediate arguments. +- For arithmetic operations, immediates are + 8-bit quantities zero-extended and rotated right by 0, 2, 4, ... 30 bits. +- For memory accesses of type [Mint32], immediate offsets are + 12-bit quantities plus a sign bit. +- For other memory accesses, immediate offsets are + 8-bit quantities plus a sign bit. *) + +Fixpoint is_immed_arith_aux (n: nat) (x msk: int) {struct n}: bool := + match n with + | O => false + | Datatypes.S n' => + Int.eq (Int.and x (Int.not msk)) Int.zero || + is_immed_arith_aux n' x (Int.ror msk (Int.repr 2)) + end. + +Definition is_immed_arith (x: int) : bool := + is_immed_arith_aux 16%nat x (Int.repr 255). + +Definition is_immed_mem_word (x: int) : bool := + Int.lt x (Int.repr 4096) && Int.lt (Int.repr (-4096)) x. + +Definition is_immed_mem_small (x: int) : bool := + Int.lt x (Int.repr 256) && Int.lt (Int.repr (-256)) x. + +Definition is_immed_mem_float (x: int) : bool := + Int.eq (Int.and x (Int.repr 3)) Int.zero + && Int.lt x (Int.repr 1024) && Int.lt (Int.repr (-1024)) x. + +(** Smart constructor for integer immediate arguments. *) + +Definition loadimm (r: ireg) (n: int) (k: code) := + if is_immed_arith n then + Pmov r (SOimm n) :: k + else if is_immed_arith (Int.not n) then + Pmvn r (SOimm (Int.not n)) :: k + else (* could be much improved! *) + Pmov r (SOimm (Int.and n (Int.repr 255))) :: + Porr r r (SOimm (Int.and n (Int.repr 65280))) :: + Porr r r (SOimm (Int.and n (Int.repr 16711680))) :: + Porr r r (SOimm (Int.and n (Int.repr 4278190080))) :: + k. + +Definition addimm (r1 r2: ireg) (n: int) (k: code) := + if is_immed_arith n then + Padd r1 r2 (SOimm n) :: k + else if is_immed_arith (Int.neg n) then + Psub r1 r2 (SOimm (Int.neg n)) :: k + else + Padd r1 r2 (SOimm (Int.and n (Int.repr 255))) :: + Padd r1 r1 (SOimm (Int.and n (Int.repr 65280))) :: + Padd r1 r1 (SOimm (Int.and n (Int.repr 16711680))) :: + Padd r1 r1 (SOimm (Int.and n (Int.repr 4278190080))) :: + k. + +Definition andimm (r1 r2: ireg) (n: int) (k: code) := + if is_immed_arith n then + Pand r1 r2 (SOimm n) :: k + else if is_immed_arith (Int.not n) then + Pbic r1 r2 (SOimm (Int.not n)) :: k + else + loadimm IR14 n (Pand r1 r2 (SOreg IR14) :: k). + +Definition makeimm (instr: ireg -> ireg -> shift_op -> instruction) + (r1 r2: ireg) (n: int) (k: code) := + if is_immed_arith n then + instr r1 r2 (SOimm n) :: k + else + loadimm IR14 n (instr r1 r2 (SOreg IR14) :: k). + +(** Translation of a shift immediate operation (type [Op.shift]) *) + +Definition transl_shift (s: shift) (r: ireg) : shift_op := + match s with + | Slsl n => SOlslimm r (s_amount n) + | Slsr n => SOlsrimm r (s_amount n) + | Sasr n => SOasrimm r (s_amount n) + | Sror n => SOrorimm r (s_amount n) + end. + +(** Translation of a condition. Prepends to [k] the instructions + that evaluate the condition and leave its boolean result in one of + the bits of the condition register. The bit in question is + determined by the [crbit_for_cond] function. *) + +Definition transl_cond + (cond: condition) (args: list mreg) (k: code) := + match cond, args with + | Ccomp c, a1 :: a2 :: nil => + Pcmp (ireg_of a1) (SOreg (ireg_of a2)) :: k + | Ccompu c, a1 :: a2 :: nil => + Pcmp (ireg_of a1) (SOreg (ireg_of a2)) :: k + | Ccompshift c s, a1 :: a2 :: nil => + Pcmp (ireg_of a1) (transl_shift s (ireg_of a2)) :: k + | Ccompushift c s, a1 :: a2 :: nil => + Pcmp (ireg_of a1) (transl_shift s (ireg_of a2)) :: k + | Ccompimm c n, a1 :: nil => + if is_immed_arith n then + Pcmp (ireg_of a1) (SOimm n) :: k + else + loadimm IR14 n (Pcmp (ireg_of a1) (SOreg IR14) :: k) + | Ccompuimm c n, a1 :: nil => + if is_immed_arith n then + Pcmp (ireg_of a1) (SOimm n) :: k + else + loadimm IR14 n (Pcmp (ireg_of a1) (SOreg IR14) :: k) + | Ccompf cmp, a1 :: a2 :: nil => + Pcmf (freg_of a1) (freg_of a2) :: k + | Cnotcompf cmp, a1 :: a2 :: nil => + Pcmf (freg_of a1) (freg_of a2) :: k + | _, _ => + k (**r never happens for well-typed code *) + end. + +Definition crbit_for_signed_cmp (cmp: comparison) := + match cmp with + | Ceq => CReq + | Cne => CRne + | Clt => CRlt + | Cle => CRle + | Cgt => CRgt + | Cge => CRge + end. + +Definition crbit_for_unsigned_cmp (cmp: comparison) := + match cmp with + | Ceq => CReq + | Cne => CRne + | Clt => CRlo + | Cle => CRls + | Cgt => CRhi + | Cge => CRhs + end. + +Definition crbit_for_float_cmp (cmp: comparison) := + match cmp with + | Ceq => CReq + | Cne => CRne + | Clt => CRmi + | Cle => CRls + | Cgt => CRgt + | Cge => CRge + end. + +Definition crbit_for_float_not_cmp (cmp: comparison) := + match cmp with + | Ceq => CRne + | Cne => CReq + | Clt => CRpl + | Cle => CRhi + | Cgt => CRle + | Cge => CRlt + end. + +Definition crbit_for_cond (cond: condition) := + match cond with + | Ccomp cmp => crbit_for_signed_cmp cmp + | Ccompu cmp => crbit_for_unsigned_cmp cmp + | Ccompshift cmp s => crbit_for_signed_cmp cmp + | Ccompushift cmp s => crbit_for_unsigned_cmp cmp + | Ccompimm cmp n => crbit_for_signed_cmp cmp + | Ccompuimm cmp n => crbit_for_unsigned_cmp cmp + | Ccompf cmp => crbit_for_float_cmp cmp + | Cnotcompf cmp => crbit_for_float_not_cmp cmp + end. + +(** Translation of the arithmetic operation [r <- op(args)]. + The corresponding instructions are prepended to [k]. *) + +Definition transl_op + (op: operation) (args: list mreg) (r: mreg) (k: code) := + match op, args with + | Omove, a1 :: nil => + match mreg_type a1 with + | Tint => Pmov (ireg_of r) (SOreg (ireg_of a1)) :: k + | Tfloat => Pmvfd (freg_of r) (freg_of a1) :: k + end + | Ointconst n, nil => + loadimm (ireg_of r) n k + | Ofloatconst f, nil => + Plifd (freg_of r) f :: k + | Oaddrsymbol s ofs, nil => + Ploadsymbol (ireg_of r) s ofs :: k + | Oaddrstack n, nil => + addimm (ireg_of r) IR13 n k + | Ocast8signed, a1 :: nil => + Pmov (ireg_of r) (SOlslimm (ireg_of a1) (Int.repr 24)) :: + Pmov (ireg_of r) (SOasrimm (ireg_of r) (Int.repr 24)) :: k + | Ocast8unsigned, a1 :: nil => + Pand (ireg_of r) (ireg_of a1) (SOimm (Int.repr 255)) :: k + | Ocast16signed, a1 :: nil => + Pmov (ireg_of r) (SOlslimm (ireg_of a1) (Int.repr 16)) :: + Pmov (ireg_of r) (SOasrimm (ireg_of r) (Int.repr 16)) :: k + | Ocast16unsigned, a1 :: nil => + Pmov (ireg_of r) (SOlslimm (ireg_of a1) (Int.repr 16)) :: + Pmov (ireg_of r) (SOlsrimm (ireg_of r) (Int.repr 16)) :: k + | Oadd, a1 :: a2 :: nil => + Padd (ireg_of r) (ireg_of a1) (SOreg (ireg_of a2)) :: k + | Oaddshift s, a1 :: a2 :: nil => + Padd (ireg_of r) (ireg_of a1) (transl_shift s (ireg_of a2)) :: k + | Oaddimm n, a1 :: nil => + addimm (ireg_of r) (ireg_of a1) n k + | Osub, a1 :: a2 :: nil => + Psub (ireg_of r) (ireg_of a1) (SOreg (ireg_of a2)) :: k + | Osubshift s, a1 :: a2 :: nil => + Psub (ireg_of r) (ireg_of a1) (transl_shift s (ireg_of a2)) :: k + | Orsubshift s, a1 :: a2 :: nil => + Prsb (ireg_of r) (ireg_of a1) (transl_shift s (ireg_of a2)) :: k + | Orsubimm n, a1 :: nil => + makeimm Prsb (ireg_of r) (ireg_of a1) n k + | Omul, a1 :: a2 :: nil => + if ireg_eq (ireg_of r) (ireg_of a1) + || ireg_eq (ireg_of r) (ireg_of a2) + then Pmul IR14 (ireg_of a1) (ireg_of a2) :: Pmov (ireg_of r) (SOreg IR14) :: k + else Pmul (ireg_of r) (ireg_of a1) (ireg_of a2) :: k + | Odiv, a1 :: a2 :: nil => + Psdiv (ireg_of r) (ireg_of a1) (ireg_of a2) :: k + | Odivu, a1 :: a2 :: nil => + Pudiv (ireg_of r) (ireg_of a1) (ireg_of a2) :: k + | Oand, a1 :: a2 :: nil => + Pand (ireg_of r) (ireg_of a1) (SOreg (ireg_of a2)) :: k + | Oandshift s, a1 :: a2 :: nil => + Pand (ireg_of r) (ireg_of a1) (transl_shift s (ireg_of a2)) :: k + | Oandimm n, a1 :: nil => + andimm (ireg_of r) (ireg_of a1) n k + | Oor, a1 :: a2 :: nil => + Porr (ireg_of r) (ireg_of a1) (SOreg (ireg_of a2)) :: k + | Oorshift s, a1 :: a2 :: nil => + Porr (ireg_of r) (ireg_of a1) (transl_shift s (ireg_of a2)) :: k + | Oorimm n, a1 :: nil => + makeimm Porr (ireg_of r) (ireg_of a1) n k + | Oxor, a1 :: a2 :: nil => + Peor (ireg_of r) (ireg_of a1) (SOreg (ireg_of a2)) :: k + | Oxorshift s, a1 :: a2 :: nil => + Peor (ireg_of r) (ireg_of a1) (transl_shift s (ireg_of a2)) :: k + | Oxorimm n, a1 :: nil => + makeimm Peor (ireg_of r) (ireg_of a1) n k + | Obic, a1 :: a2 :: nil => + Pbic (ireg_of r) (ireg_of a1) (SOreg (ireg_of a2)) :: k + | Obicshift s, a1 :: a2 :: nil => + Pbic (ireg_of r) (ireg_of a1) (transl_shift s (ireg_of a2)) :: k + | Onot, a1 :: nil => + Pmvn (ireg_of r) (SOreg (ireg_of a1)) :: k + | Onotshift s, a1 :: nil => + Pmvn (ireg_of r) (transl_shift s (ireg_of a1)) :: k + | Oshl, a1 :: a2 :: nil => + Pmov (ireg_of r) (SOlslreg (ireg_of a1) (ireg_of a2)) :: k + | Oshr, a1 :: a2 :: nil => + Pmov (ireg_of r) (SOasrreg (ireg_of a1) (ireg_of a2)) :: k + | Oshru, a1 :: a2 :: nil => + Pmov (ireg_of r) (SOlsrreg (ireg_of a1) (ireg_of a2)) :: k + | Oshift s, a1 :: nil => + Pmov (ireg_of r) (transl_shift s (ireg_of a1)) :: k + | Oshrximm n, a1 :: nil => + Pcmp (ireg_of a1) (SOimm Int.zero) :: + addimm IR14 (ireg_of a1) (Int.sub (Int.shl Int.one n) Int.one) + (Pmovc CRge IR14 (SOreg (ireg_of a1)) :: + Pmov (ireg_of r) (SOasrimm IR14 n) :: k) + | Onegf, a1 :: nil => + Pmnfd (freg_of r) (freg_of a1) :: k + | Oabsf, a1 :: nil => + Pabsd (freg_of r) (freg_of a1) :: k + | Oaddf, a1 :: a2 :: nil => + Padfd (freg_of r) (freg_of a1) (freg_of a2) :: k + | Osubf, a1 :: a2 :: nil => + Psufd (freg_of r) (freg_of a1) (freg_of a2) :: k + | Omulf, a1 :: a2 :: nil => + Pmufd (freg_of r) (freg_of a1) (freg_of a2) :: k + | Odivf, a1 :: a2 :: nil => + Pdvfd (freg_of r) (freg_of a1) (freg_of a2) :: k + | Osingleoffloat, a1 :: nil => + Pmvfs (freg_of r) (freg_of a1) :: k + | Ointoffloat, a1 :: nil => + Pfixz (ireg_of r) (freg_of a1) :: k + | Ointuoffloat, a1 :: nil => + Pfixzu (ireg_of r) (freg_of a1) :: k + | Ofloatofint, a1 :: nil => + Pfltd (freg_of r) (ireg_of a1) :: k + | Ofloatofintu, a1 :: nil => + Pfltud (freg_of r) (ireg_of a1) :: k + | Ocmp cmp, _ => + transl_cond cmp args + (Pmov (ireg_of r) (SOimm Int.zero) :: + Pmovc (crbit_for_cond cmp) (ireg_of r) (SOimm Int.one) :: + k) + | _, _ => + k (**r never happens for well-typed code *) + end. + +(** Common code to translate [Mload] and [Mstore] instructions. *) + +Definition transl_shift_addr (s: shift) (r: ireg) : shift_addr := + match s with + | Slsl n => SAlsl r (s_amount n) + | Slsr n => SAlsr r (s_amount n) + | Sasr n => SAasr r (s_amount n) + | Sror n => SAror r (s_amount n) + end. + +Definition transl_load_store + (mk_instr_imm: ireg -> int -> instruction) + (mk_instr_gen: option (ireg -> shift_addr -> instruction)) + (is_immed: int -> bool) + (addr: addressing) (args: list mreg) (k: code) : code := + match addr, args with + | Aindexed n, a1 :: nil => + if is_immed n then + mk_instr_imm (ireg_of a1) n :: k + else + addimm IR14 (ireg_of a1) n + (mk_instr_imm IR14 Int.zero :: k) + | Aindexed2, a1 :: a2 :: nil => + match mk_instr_gen with + | Some f => + f (ireg_of a1) (SAreg (ireg_of a2)) :: k + | None => + Padd IR14 (ireg_of a1) (SOreg (ireg_of a2)) :: + mk_instr_imm IR14 Int.zero :: k + end + | Aindexed2shift s, a1 :: a2 :: nil => + match mk_instr_gen with + | Some f => + f (ireg_of a1) (transl_shift_addr s (ireg_of a2)) :: k + | None => + Padd IR14 (ireg_of a1) (transl_shift s (ireg_of a2)) :: + mk_instr_imm IR14 Int.zero :: k + end + | Ainstack n, nil => + if is_immed n then + mk_instr_imm IR13 n :: k + else + addimm IR14 IR13 n + (mk_instr_imm IR14 Int.zero :: k) + | _, _ => + (* should not happen *) k + end. + +Definition transl_load_store_int + (mk_instr: ireg -> ireg -> shift_addr -> instruction) + (is_immed: int -> bool) + (rd: mreg) (addr: addressing) (args: list mreg) (k: code) := + transl_load_store + (fun r n => mk_instr (ireg_of rd) r (SAimm n)) + (Some (mk_instr (ireg_of rd))) + is_immed addr args k. + +Definition transl_load_store_float + (mk_instr: freg -> ireg -> int -> instruction) + (is_immed: int -> bool) + (rd: mreg) (addr: addressing) (args: list mreg) (k: code) := + transl_load_store + (mk_instr (freg_of rd)) + None + is_immed addr args k. + +Definition loadind_int (base: ireg) (ofs: int) (dst: ireg) (k: code) := + if is_immed_mem_word ofs then + Pldr dst base (SAimm ofs) :: k + else + addimm IR14 base ofs + (Pldr dst IR14 (SAimm Int.zero) :: k). + +Definition loadind_float (base: ireg) (ofs: int) (dst: freg) (k: code) := + if is_immed_mem_float ofs then + Pldfd dst base ofs :: k + else + addimm IR14 base ofs + (Pldfd dst IR14 Int.zero :: k). + +Definition loadind (base: ireg) (ofs: int) (ty: typ) (dst: mreg) (k: code) := + match ty with + | Tint => loadind_int base ofs (ireg_of dst) k + | Tfloat => loadind_float base ofs (freg_of dst) k + end. + +Definition storeind_int (src: ireg) (base: ireg) (ofs: int) (k: code) := + if is_immed_mem_word ofs then + Pstr src base (SAimm ofs) :: k + else + addimm IR14 base ofs + (Pstr src IR14 (SAimm Int.zero) :: k). + +Definition storeind_float (src: freg) (base: ireg) (ofs: int) (k: code) := + if is_immed_mem_float ofs then + Pstfd src base ofs :: k + else + addimm IR14 base ofs + (Pstfd src IR14 Int.zero :: k). + +Definition storeind (src: mreg) (base: ireg) (ofs: int) (ty: typ) (k: code) := + match ty with + | Tint => storeind_int (ireg_of src) base ofs k + | Tfloat => storeind_float (freg_of src) base ofs k + end. + +(** Translation of a Mach instruction. *) + +Definition transl_instr (f: Mach.function) (i: Mach.instruction) (k: code) := + match i with + | Mgetstack ofs ty dst => + loadind IR13 ofs ty dst k + | Msetstack src ofs ty => + storeind src IR13 ofs ty k + | Mgetparam ofs ty dst => + loadind_int IR13 f.(fn_link_ofs) IR14 (loadind IR14 ofs ty dst k) + | Mop op args res => + transl_op op args res k + | Mload chunk addr args dst => + match chunk with + | Mint8signed => + transl_load_store_int Pldrsb is_immed_mem_small dst addr args k + | Mint8unsigned => + transl_load_store_int Pldrb is_immed_mem_small dst addr args k + | Mint16signed => + transl_load_store_int Pldrsh is_immed_mem_small dst addr args k + | Mint16unsigned => + transl_load_store_int Pldrh is_immed_mem_small dst addr args k + | Mint32 => + transl_load_store_int Pldr is_immed_mem_word dst addr args k + | Mfloat32 => + transl_load_store_float Pldfs is_immed_mem_float dst addr args k + | Mfloat64 => + transl_load_store_float Pldfd is_immed_mem_float dst addr args k + end + | Mstore chunk addr args src => + match chunk with + | Mint8signed => + transl_load_store_int Pstrb is_immed_mem_small src addr args k + | Mint8unsigned => + transl_load_store_int Pstrb is_immed_mem_small src addr args k + | Mint16signed => + transl_load_store_int Pstrh is_immed_mem_small src addr args k + | Mint16unsigned => + transl_load_store_int Pstrh is_immed_mem_small src addr args k + | Mint32 => + transl_load_store_int Pstr is_immed_mem_word src addr args k + | Mfloat32 => + transl_load_store_float Pstfs is_immed_mem_float src addr args k + | Mfloat64 => + transl_load_store_float Pstfd is_immed_mem_float src addr args k + end + | Mcall sig (inl r) => + Pblreg (ireg_of r) :: k + | Mcall sig (inr symb) => + Pblsymb symb :: k + | Mtailcall sig (inl r) => + loadind_int IR13 f.(fn_retaddr_ofs) IR14 + (Pfreeframe f.(fn_link_ofs) :: Pbreg (ireg_of r) :: k) + | Mtailcall sig (inr symb) => + loadind_int IR13 f.(fn_retaddr_ofs) IR14 + (Pfreeframe f.(fn_link_ofs) :: Pbsymb symb :: k) + | Malloc => + Pallocblock :: k + | Mlabel lbl => + Plabel lbl :: k + | Mgoto lbl => + Pb lbl :: k + | Mcond cond args lbl => + transl_cond cond args (Pbc (crbit_for_cond cond) lbl :: k) + | Mreturn => + loadind_int IR13 f.(fn_retaddr_ofs) IR14 + (Pfreeframe f.(fn_link_ofs) :: Pbreg IR14 :: k) + end. + +Definition transl_code (f: Mach.function) (il: list Mach.instruction) := + List.fold_right (transl_instr f) nil il. + +(** Translation of a whole function. Note that we must check + that the generated code contains less than [2^32] instructions, + otherwise the offset part of the [PC] code pointer could wrap + around, leading to incorrect executions. *) + +Definition transl_function (f: Mach.function) := + Pallocframe (- f.(fn_framesize)) f.(fn_stacksize) f.(fn_link_ofs) :: + Pstr IR14 IR13 (SAimm f.(fn_retaddr_ofs)) :: + transl_code f f.(fn_code). + +Fixpoint code_size (c: code) : Z := + match c with + | nil => 0 + | instr :: c' => code_size c' + 1 + end. + +Open Local Scope string_scope. + +Definition transf_function (f: Mach.function) : res Asm.code := + let c := transl_function f in + if zlt Int.max_unsigned (code_size c) + then Errors.Error (msg "code size exceeded") + else Errors.OK c. + +Definition transf_fundef (f: Mach.fundef) : res Asm.fundef := + transf_partial_fundef transf_function f. + +Definition transf_program (p: Mach.program) : res Asm.program := + transform_partial_program transf_fundef p. + diff --git a/arm/Asmgenproof.v b/arm/Asmgenproof.v new file mode 100644 index 0000000..69a82de --- /dev/null +++ b/arm/Asmgenproof.v @@ -0,0 +1,1246 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Correctness proof for ARM code generation: main proof. *) + +Require Import Coqlib. +Require Import Maps. +Require Import Errors. +Require Import AST. +Require Import Integers. +Require Import Floats. +Require Import Values. +Require Import 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 Asm. +Require Import Asmgen. +Require Import Asmgenretaddr. +Require Import Asmgenproof1. + +Section PRESERVATION. + +Variable prog: Mach.program. +Variable tprog: Asm.program. +Hypothesis TRANSF: transf_program prog = Errors.OK tprog. + +Let ge := Genv.globalenv prog. +Let tge := Genv.globalenv tprog. + +Lemma symbols_preserved: + forall id, Genv.find_symbol tge id = Genv.find_symbol ge id. +Proof. + intros. unfold ge, tge. + apply Genv.find_symbol_transf_partial with transf_fundef. + exact TRANSF. +Qed. + +Lemma functions_translated: + forall b f, + Genv.find_funct_ptr ge b = Some f -> + exists tf, Genv.find_funct_ptr tge b = Some tf /\ transf_fundef f = Errors.OK tf. +Proof + (Genv.find_funct_ptr_transf_partial transf_fundef TRANSF). + +Lemma functions_transl: + forall f b, + Genv.find_funct_ptr ge b = Some (Internal f) -> + Genv.find_funct_ptr tge b = Some (Internal (transl_function f)). +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))); simpl; intro. + congruence. intro. inv B0. auto. +Qed. + +Lemma functions_transl_no_overflow: + forall b f, + Genv.find_funct_ptr ge b = Some (Internal f) -> + code_size (transl_function f) <= Int.max_unsigned. +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))); simpl; intro. + congruence. intro; omega. +Qed. + +(** * Properties of control flow *) + +Lemma find_instr_in: + forall c pos i, + find_instr pos c = Some i -> In i c. +Proof. + induction c; simpl. intros; discriminate. + intros until i. case (zeq pos 0); intros. + left; congruence. right; eauto. +Qed. + +Lemma find_instr_tail: + forall c1 i c2 pos, + code_tail pos c1 (i :: c2) -> + find_instr pos c1 = Some i. +Proof. + 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: + forall fn, code_size fn >= 0. +Proof. + induction fn; simpl; omega. +Qed. + +Remark code_tail_bounds: + forall fn ofs i c, + code_tail ofs fn (i :: c) -> 0 <= ofs < code_size fn. +Proof. + 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. +Proof. + 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. +Proof. + 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. +Qed. + +(** [transl_code_at_pc pc fn c] holds if the code pointer [pc] points + within the ARM code generated by translating Mach function [fn], + and [c] is the tail of the generated code at the position corresponding + to the code pointer [pc]. *) + +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 f 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 ARM executions + (predicate [exec_steps]) under adequate [transl_code_at_pc] hypotheses. *) + +Lemma exec_straight_steps_1: + forall fn c rs m c' rs' m', + exec_straight tge fn c rs m c' rs' m' -> + code_size fn <= Int.max_unsigned -> + forall b ofs, + rs#PC = Vptr b ofs -> + Genv.find_funct_ptr tge b = Some (Internal fn) -> + code_tail (Int.unsigned ofs) fn c -> + plus step tge (State rs m) E0 (State rs' m'). +Proof. + 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. + apply code_tail_next_int with i; auto. + traceEq. +Qed. + +Lemma exec_straight_steps_2: + forall fn c rs m c' rs' m', + exec_straight tge fn c rs m c' rs' m' -> + code_size fn <= Int.max_unsigned -> + forall b ofs, + rs#PC = Vptr b ofs -> + Genv.find_funct_ptr tge b = Some (Internal fn) -> + code_tail (Int.unsigned ofs) fn c -> + exists ofs', + rs'#PC = Vptr b ofs' + /\ code_tail (Int.unsigned ofs') fn c'. +Proof. + induction 1; intros. + 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_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 f 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 f c) rs m (transl_code f c') rs' m' -> + transl_code_at_pc (rs' PC) fb f c'. +Proof. + intros. inversion H. subst. + generalize (functions_transl_no_overflow _ _ H2). intro. + generalize (functions_transl _ _ H2). intro. + generalize (exec_straight_steps_2 _ _ _ _ _ _ _ + H0 H4 _ _ (sym_equal H1) H5 H3). + intros [ofs' [PC' CT']]. + rewrite PC'. constructor; auto. +Qed. + +(** Correctness of the return addresses predicted by + [ARMgen.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. *) + +Fixpoint find_label (lbl: label) (c: code) {struct c} : option code := + match c with + | nil => None + | instr :: c' => + if is_label lbl instr then Some c' else find_label lbl c' + end. + +Lemma label_pos_code_tail: + forall lbl c pos c', + find_label lbl c = Some c' -> + exists pos', + label_pos lbl pos c = Some pos' + /\ code_tail (pos' - pos) c c' + /\ pos < pos' <= pos + code_size c. +Proof. + induction c. + simpl; intros. discriminate. + simpl; intros until c'. + case (is_label lbl a). + intro EQ; injection EQ; intro; subst c'. + exists (pos + 1). split. auto. split. + 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. + replace (pos' - pos) with ((pos' - (pos + 1)) + 1) by omega. + constructor. auto. + omega. +Qed. + +(** The following lemmas show that the translation from Mach to ARM + preserves labels, in the sense that the following diagram commutes: +<< + translation + Mach code ------------------------ ARM instr sequence + | | + | Mach.find_label lbl find_label lbl | + | | + v v + Mach code tail ------------------- ARM instr seq tail + translation +>> + The proof demands many boring lemmas showing that ARM constructor + functions do not introduce new labels. +*) + +Section TRANSL_LABEL. + +Variable lbl: label. + +Remark loadimm_label: + forall r n k, find_label lbl (loadimm r n k) = find_label lbl k. +Proof. + intros. unfold loadimm. + destruct (is_immed_arith n). reflexivity. + destruct (is_immed_arith (Int.not n)); reflexivity. +Qed. +Hint Rewrite loadimm_label: labels. + +Remark addimm_label: + forall r1 r2 n k, find_label lbl (addimm r1 r2 n k) = find_label lbl k. +Proof. + intros; unfold addimm. + destruct (is_immed_arith n). reflexivity. + destruct (is_immed_arith (Int.neg n)). reflexivity. + autorewrite with labels. reflexivity. +Qed. +Hint Rewrite addimm_label: labels. + +Remark andimm_label: + forall r1 r2 n k, find_label lbl (andimm r1 r2 n k) = find_label lbl k. +Proof. + intros; unfold andimm. + destruct (is_immed_arith n). reflexivity. + destruct (is_immed_arith (Int.not n)). reflexivity. + autorewrite with labels. reflexivity. +Qed. +Hint Rewrite andimm_label: labels. + +Remark makeimm_Prsb_label: + forall r1 r2 n k, find_label lbl (makeimm Prsb r1 r2 n k) = find_label lbl k. +Proof. + intros; unfold makeimm. + destruct (is_immed_arith n). reflexivity. autorewrite with labels; auto. +Qed. +Remark makeimm_Porr_label: + forall r1 r2 n k, find_label lbl (makeimm Porr r1 r2 n k) = find_label lbl k. +Proof. + intros; unfold makeimm. + destruct (is_immed_arith n). reflexivity. autorewrite with labels; auto. +Qed. +Remark makeimm_Peor_label: + forall r1 r2 n k, find_label lbl (makeimm Peor r1 r2 n k) = find_label lbl k. +Proof. + intros; unfold makeimm. + destruct (is_immed_arith n). reflexivity. autorewrite with labels; auto. +Qed. +Hint Rewrite makeimm_Prsb_label makeimm_Porr_label makeimm_Peor_label: labels. + +Remark loadind_int_label: + forall base ofs dst k, find_label lbl (loadind_int base ofs dst k) = find_label lbl k. +Proof. + intros; unfold loadind_int. + destruct (is_immed_mem_word ofs); autorewrite with labels; auto. +Qed. + +Remark loadind_label: + forall base ofs ty dst k, find_label lbl (loadind base ofs ty dst k) = find_label lbl k. +Proof. + intros; unfold loadind. destruct ty. + apply loadind_int_label. + unfold loadind_float. + destruct (is_immed_mem_float ofs); autorewrite with labels; auto. +Qed. + +Remark storeind_int_label: + forall base ofs src k, find_label lbl (storeind_int src base ofs k) = find_label lbl k. +Proof. + intros; unfold storeind_int. + destruct (is_immed_mem_word ofs); autorewrite with labels; auto. +Qed. + +Remark storeind_label: + forall base ofs ty src k, find_label lbl (storeind src base ofs ty k) = find_label lbl k. +Proof. + intros; unfold storeind. destruct ty. + apply storeind_int_label. + unfold storeind_float. + destruct (is_immed_mem_float ofs); autorewrite with labels; auto. +Qed. +Hint Rewrite loadind_int_label loadind_label storeind_int_label storeind_label: labels. + +Remark transl_cond_label: + forall cond args k, find_label lbl (transl_cond cond args k) = find_label lbl k. +Proof. + intros; unfold transl_cond. + destruct cond; (destruct args; + [try reflexivity | destruct args; + [try reflexivity | destruct args; try reflexivity]]). + destruct (is_immed_arith i); autorewrite with labels; auto. + destruct (is_immed_arith i); autorewrite with labels; auto. +Qed. +Hint Rewrite transl_cond_label: labels. + +Remark transl_op_label: + forall op args r k, find_label lbl (transl_op op args r k) = find_label lbl k. +Proof. + intros; unfold transl_op; + 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 (ireg_eq (ireg_of r) (ireg_of m) || ireg_eq (ireg_of r) (ireg_of m0)); reflexivity. + transitivity (find_label lbl + (addimm IR14 (ireg_of m) (Int.sub (Int.shl Int.one i) Int.one) + (Pmovc CRge IR14 (SOreg (ireg_of m)) + :: Pmov (ireg_of r) (SOasrimm IR14 i) :: k))). + unfold find_label; auto. autorewrite with labels. reflexivity. +Qed. +Hint Rewrite transl_op_label: labels. + +Remark transl_load_store_label: + forall (mk_instr_imm: ireg -> int -> instruction) + (mk_instr_gen: option (ireg -> shift_addr -> instruction)) + (is_immed: int -> bool) + (addr: addressing) (args: list mreg) (k: code), + (forall r n, is_label lbl (mk_instr_imm r n) = false) -> + (match mk_instr_gen with + | None => True + | Some f => forall r sa, is_label lbl (f r sa) = false + end) -> + find_label lbl (transl_load_store mk_instr_imm mk_instr_gen is_immed addr args k) = find_label lbl k. +Proof. + intros; unfold transl_load_store. + destruct addr; destruct args; try (destruct args); try (destruct args); + try reflexivity. + destruct (is_immed i); autorewrite with labels; simpl; rewrite H; auto. + destruct mk_instr_gen. simpl. rewrite H0. auto. + simpl. rewrite H. auto. + destruct mk_instr_gen. simpl. rewrite H0. auto. + simpl. rewrite H. auto. + destruct (is_immed i); autorewrite with labels; simpl; rewrite H; auto. +Qed. +Hint Rewrite transl_load_store_label: labels. + +Lemma transl_instr_label: + forall f i k, + find_label lbl (transl_instr f i k) = + if Mach.is_label lbl i then Some k else find_label lbl k. +Proof. + intros. generalize (Mach.is_label_correct lbl i). + case (Mach.is_label lbl i); intro. + subst i. simpl. rewrite peq_true. auto. + destruct i; simpl; autorewrite with labels; try reflexivity. + unfold transl_load_store_int, transl_load_store_float. + destruct m; rewrite transl_load_store_label; intros; auto. + unfold transl_load_store_int, transl_load_store_float. + destruct m; rewrite transl_load_store_label; intros; auto. + destruct s0; reflexivity. + destruct s0; autorewrite with labels; reflexivity. + rewrite peq_false. auto. congruence. +Qed. + +Lemma transl_code_label: + forall f c, + find_label lbl (transl_code f c) = + option_map (transl_code f) (Mach.find_label lbl c). +Proof. + induction c; simpl; intros. + auto. rewrite transl_instr_label. + case (Mach.is_label lbl a). reflexivity. + auto. +Qed. + +Lemma transl_find_label: + forall f, + find_label lbl (transl_function f) = + option_map (transl_code f) (Mach.find_label lbl f.(fn_code)). +Proof. + intros. unfold transl_function. simpl. autorewrite with labels. apply transl_code_label. +Qed. + +End TRANSL_LABEL. + +(** A valid branch in a piece of Mach code translates to a valid ``go to'' + transition in the generated ARM code. *) + +Lemma find_label_goto_label: + forall f lbl rs m c' b ofs, + Genv.find_funct_ptr ge b = Some (Internal f) -> + rs PC = Vptr b ofs -> + 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) b f c' + /\ forall r, r <> PC -> rs'#r = rs#r. +Proof. + intros. + generalize (transl_find_label lbl f). + rewrite H1; simpl. intro. + generalize (label_pos_code_tail lbl (transl_function f) 0 + (transl_code f c') H2). + 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. + 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. + +(** * Memory properties *) + +(** We show that signed 8- and 16-bit stores can be performed + like unsigned stores. *) + +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 storev_8_signed_unsigned: + forall m a v, + Mem.storev Mint8signed m a v = Mem.storev Mint8unsigned m a v. +Proof. + intros. unfold storev. destruct a; auto. + unfold store. rewrite (in_bounds_equiv Mint8signed Mint8unsigned). + auto. auto. +Qed. + +Lemma storev_16_signed_unsigned: + forall m a v, + Mem.storev Mint16signed m a v = Mem.storev Mint16unsigned m a v. +Proof. + intros. unfold storev. destruct a; auto. + unfold store. rewrite (in_bounds_equiv Mint16signed Mint16unsigned). + auto. auto. +Qed. + +(** * Proof of semantic preservation *) + +(** Semantic preservation is proved using simulation diagrams + of the following form. +<< + st1 --------------- st2 + | | + t| *|t + | | + v v + st1'--------------- st2' +>> + The invariant is the [match_states] predicate below, which includes: +- The ARM code pointed by the PC register is the translation of + the current Mach code sequence. +- Mach register values and ARM register values agree. +*) + +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 -> Asm.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) + (Asm.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 IR14 = parent_ra s), + match_states (Machconcr.Callstate s fb ms m) + (Asm.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) + (Asm.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 f c1) rs1 m1 (transl_code f 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 ARM side. Actually, all Mach transitions + correspond to at least one ARM 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 (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; inv MS. + left; eapply exec_straight_steps; eauto with coqlib. + exists (nextinstr rs); split. + simpl. apply exec_straight_one. reflexivity. reflexivity. + apply agree_nextinstr; auto. +Qed. + +Lemma exec_Mgetstack_prop: + 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; 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. + generalize (loadind_correct tge (transl_function f) IR13 ofs ty + dst (transl_code f c) rs m v H H1). + intros [rs2 [EX [RES OTH]]]. + 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. +Qed. + +Lemma exec_Msetstack_prop: + 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; 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 rs) in H; auto. + assert (NOTE: IR13 <> IR14) by congruence. + generalize (storeind_correct tge (transl_function f) IR13 ofs ty + src (transl_code f c) rs m m' H H1 NOTE). + intros [rs2 [EX OTH]]. + 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 (s : list stackframe) (fb : block) (f: Mach.function) (sp parent : val) + (ofs : int) (ty : typ) (dst : mreg) (c : list Mach.instruction) + (ms : Mach.regset) (m : mem) (v : val), + Genv.find_funct_ptr ge fb = Some (Internal f) -> + load_stack m sp Tint f.(fn_link_ofs) = 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; inv MS. + assert (f0 = f) by congruence. subst f0. + exploit (loadind_int_correct tge (transl_function f) IR13 f.(fn_link_ofs) IR14 + rs m parent (loadind IR14 ofs ty dst (transl_code f c))). + rewrite <- (sp_val ms sp rs); auto. + intros [rs1 [EX1 [RES1 OTH1]]]. + exploit (loadind_correct tge (transl_function f) IR14 ofs ty dst + (transl_code f c) rs1 m v). + rewrite RES1. auto. + generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). + intro WTI. inversion WTI. auto. + intros [rs2 [EX2 [RES2 OTH2]]]. + left. eapply exec_straight_steps; eauto with coqlib. + exists rs2; split; simpl. + eapply exec_straight_trans; eauto. + apply agree_exten_2 with (rs1#(preg_of dst) <- v). + apply agree_set_mreg. + apply agree_exten_2 with rs; auto. + intros. case (preg_eq r (preg_of dst)); intro. + subst r. rewrite Pregmap.gss. auto. + rewrite Pregmap.gso; auto. +Qed. + +Lemma exec_Mop_prop: + 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; inv MS. + generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). + 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 (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; inv MS. + generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). + intro WTI; inv WTI. + assert (eval_addressing tge sp addr ms##args = Some a). + rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. + left; eapply exec_straight_steps; eauto with coqlib. + destruct chunk; simpl; simpl in H6; + (eapply transl_load_int_correct || eapply transl_load_float_correct); + eauto; intros; reflexivity. +Qed. + +Lemma exec_Mstore_prop: + forall (s : list stackframe) (fb : block) (sp : val) + (chunk : memory_chunk) (addr : addressing) (args : list mreg) + (src : mreg) (c : list Mach.instruction) (ms : mreg -> val) + (m m' : mem) (a : val), + eval_addressing ge sp addr ms ## args = Some a -> + storev chunk m a (ms src) = Some m' -> + exec_instr_prop (Machconcr.State s fb sp (Mstore chunk addr args src :: c) ms m) E0 + (Machconcr.State s fb sp c ms m'). +Proof. + intros; red; intros; inv MS. + generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). + intro WTI; inv WTI. + assert (eval_addressing tge sp addr ms##args = Some a). + rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. + left; eapply exec_straight_steps; eauto with coqlib. + destruct chunk; simpl; simpl in H6; + try (rewrite storev_8_signed_unsigned in H0); + try (rewrite storev_16_signed_unsigned in H0); + (eapply transl_store_int_correct || eapply transl_store_float_correct); + eauto; intros; reflexivity. +Qed. + +Lemma exec_Mcall_prop: + 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; inv MS. + assert (f0 = f) by congruence. subst f0. + generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). + intro WTI. inv WTI. + inv AT. + assert (NOOV: code_size (transl_function f) <= Int.max_unsigned). + eapply functions_transl_no_overflow; eauto. + assert (CT: code_tail (Int.unsigned (Int.add ofs Int.one)) (transl_function f) (transl_code f c)). + destruct ros; simpl in H5; eapply code_tail_next_int; eauto. + set (rs2 := rs #IR14 <- (Val.add rs#PC Vone) #PC <- (Vptr f' Int.zero)). + exploit return_address_offset_correct; eauto. constructor; eauto. + intro RA_EQ. + assert (ATLR: rs2 IR14 = Vptr fb ra). + rewrite RA_EQ. + change (rs2 IR14) with (Val.add (rs PC) Vone). + rewrite <- H2. reflexivity. + assert (AG3: agree ms sp rs2). + unfold rs2; auto 8 with ppcgen. + left; exists (State rs2 m); split. + apply plus_one. + destruct ros; simpl in H5. + econstructor. eauto. apply functions_transl. eexact H0. + eapply find_instr_tail. eauto. + simpl. rewrite <- (ireg_val ms sp rs); auto. + simpl in H. destruct (ms m0); try congruence. + generalize H; predSpec Int.eq Int.eq_spec i Int.zero; intros; inv H7. + auto. + econstructor. eauto. apply functions_transl. eexact H0. + eapply find_instr_tail. eauto. + simpl. unfold symbol_offset. rewrite symbols_preserved. + simpl in H. rewrite H. auto. + econstructor; eauto. + 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: function) (f' : block), + find_function_ptr ge ros ms = Some f' -> + Genv.find_funct_ptr ge fb = Some (Internal f) -> + load_stack m (Vptr stk soff) Tint f.(fn_link_ofs) = Some (parent_sp s) -> + load_stack m (Vptr stk soff) Tint f.(fn_retaddr_ofs) = Some (parent_ra s) -> + 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. + assert (f0 = f) by congruence. subst f0. + generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). + intro WTI. inv WTI. + set (call_instr := + match ros with inl r => Pbreg (ireg_of r) | inr symb => Pbsymb symb end). + assert (TR: transl_code f (Mtailcall sig ros :: c) = + loadind_int IR13 (fn_retaddr_ofs f) IR14 + (Pfreeframe (fn_link_ofs f) :: call_instr :: transl_code f c)). + unfold call_instr; destruct ros; auto. + destruct (loadind_int_correct tge (transl_function f) IR13 f.(fn_retaddr_ofs) IR14 + rs m (parent_ra s) + (Pfreeframe f.(fn_link_ofs) :: call_instr :: transl_code f c)) + as [rs1 [EXEC1 [RES1 OTH1]]]. + rewrite <- (sp_val ms (Vptr stk soff) rs); auto. + set (rs2 := nextinstr (rs1#IR13 <- (parent_sp s))). + assert (EXEC2: exec_straight tge (transl_function f) + (transl_code f (Mtailcall sig ros :: c)) rs m + (call_instr :: transl_code f c) rs2 (free m stk)). + rewrite TR. eapply exec_straight_trans. eexact EXEC1. + apply exec_straight_one. simpl. + rewrite OTH1; auto with ppcgen. + rewrite <- (sp_val ms (Vptr stk soff) rs); auto. + unfold load_stack in H1. simpl in H1. simpl. rewrite H1. auto. auto. + set (rs3 := rs2#PC <- (Vptr f' Int.zero)). + left. exists (State rs3 (free m stk)); split. + (* Execution *) + eapply plus_right'. eapply exec_straight_exec; eauto. + inv AT. exploit exec_straight_steps_2; eauto. + eapply functions_transl_no_overflow; eauto. + eapply functions_transl; eauto. + intros [ofs2 [RS2PC CT]]. + econstructor. eauto. eapply functions_transl; eauto. + eapply find_instr_tail; eauto. + unfold call_instr; destruct ros; simpl in H; simpl. + replace (rs2 (ireg_of m0)) with (Vptr f' Int.zero). auto. + unfold rs2. rewrite nextinstr_inv; auto with ppcgen. + rewrite Pregmap.gso. rewrite OTH1; auto with ppcgen. + rewrite <- (ireg_val ms (Vptr stk soff) rs); auto. + destruct (ms m0); try discriminate. + generalize H. predSpec Int.eq Int.eq_spec i Int.zero; intros; inv H9. + auto. + decEq. auto with ppcgen. decEq. auto with ppcgen. decEq. auto with ppcgen. + replace (symbol_offset tge i Int.zero) with (Vptr f' Int.zero). auto. + unfold symbol_offset. rewrite symbols_preserved. rewrite H. auto. + traceEq. + (* Match states *) + constructor; auto. + assert (AG1: agree ms (Vptr stk soff) rs1). + eapply agree_exten_2; eauto. + assert (AG2: agree ms (parent_sp s) rs2). + inv AG1. constructor. auto. intros. unfold rs2. + rewrite nextinstr_inv; auto with ppcgen. + rewrite Pregmap.gso. auto. auto with ppcgen. + unfold rs3. apply agree_exten_2 with rs2; auto. + intros. rewrite Pregmap.gso; auto. +Qed. + +Lemma exec_Malloc_prop: + 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 -> + 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; inv MS. + left; eapply exec_straight_steps; eauto with coqlib. + simpl. eapply transl_alloc_correct; eauto. +Qed. + +Lemma exec_Mgoto_prop: + 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; 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]]]. + 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 (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; inv MS. assert (f0 = f) by congruence. subst f0. + generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). + intro WTI. inv WTI. + pose (k1 := Pbc (crbit_for_cond cond) lbl :: transl_code f c). + generalize (transl_cond_correct tge (transl_function f) + cond args k1 ms sp rs m true H3 AG H). + simpl. intros [rs2 [EX [RES AG2]]]. + 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 _ _ _ FIND PC2 H1). + intros [rs3 [GOTO [AT3 INV3]]]. + left; exists (State rs3 m); split. + eapply plus_right'. + eapply exec_straight_steps_1; eauto. + econstructor; eauto. + eapply find_instr_tail. unfold k1 in CT2. eauto. + simpl. rewrite RES. simpl. auto. + traceEq. + econstructor; eauto. + eapply Mach.find_label_incl; eauto. + apply agree_exten_2 with rs2; auto. +Qed. + +Lemma exec_Mcond_false_prop: + 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; inv MS. + generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). + intro WTI. inversion WTI. + pose (k1 := Pbc (crbit_for_cond cond) lbl :: transl_code f c). + generalize (transl_cond_correct tge (transl_function f) + cond args k1 ms sp rs m false H1 AG H). + simpl. intros [rs2 [EX [RES AG2]]]. + left; eapply exec_straight_steps; eauto with coqlib. + exists (nextinstr rs2); split. + simpl. eapply exec_straight_trans. eexact EX. + unfold k1; apply exec_straight_one. + simpl. rewrite RES. reflexivity. + reflexivity. + auto with ppcgen. +Qed. + +Lemma exec_Mreturn_prop: + forall (s : list stackframe) (fb stk : block) (soff : int) + (c : list Mach.instruction) (ms : Mach.regset) (m : mem) (f: function), + Genv.find_funct_ptr ge fb = Some (Internal f) -> + load_stack m (Vptr stk soff) Tint f.(fn_link_ofs) = Some (parent_sp s) -> + load_stack m (Vptr stk soff) Tint f.(fn_retaddr_ofs) = Some (parent_ra s) -> + exec_instr_prop (Machconcr.State s fb (Vptr stk soff) (Mreturn :: c) ms m) E0 + (Returnstate s ms (free m stk)). +Proof. + intros; red; intros; inv MS. + assert (f0 = f) by congruence. subst f0. + exploit (loadind_int_correct tge (transl_function f) IR13 f.(fn_retaddr_ofs) IR14 + rs m (parent_ra s) + (Pfreeframe f.(fn_link_ofs) :: Pbreg IR14 :: transl_code f c)). + rewrite <- (sp_val ms (Vptr stk soff) rs); auto. + intros [rs1 [EXEC1 [RES1 OTH1]]]. + set (rs2 := nextinstr (rs1#IR13 <- (parent_sp s))). + assert (EXEC2: exec_straight tge (transl_function f) + (loadind_int IR13 (fn_retaddr_ofs f) IR14 + (Pfreeframe (fn_link_ofs f) :: Pbreg IR14 :: transl_code f c)) + rs m (Pbreg IR14 :: transl_code f c) rs2 (free m stk)). + eapply exec_straight_trans. eexact EXEC1. + apply exec_straight_one. simpl. rewrite OTH1; try congruence. + rewrite <- (sp_val ms (Vptr stk soff) rs); auto. + unfold load_stack in H0. simpl in H0; simpl; rewrite H0. reflexivity. + reflexivity. + set (rs3 := rs2#PC <- (parent_ra s)). + left; exists (State rs3 (free m stk)); split. + (* execution *) + eapply plus_right'. eapply exec_straight_exec; eauto. + inv AT. exploit exec_straight_steps_2; eauto. + eapply functions_transl_no_overflow; eauto. + eapply functions_transl; eauto. + intros [ofs2 [RS2PC CT]]. + econstructor. eauto. eapply functions_transl; eauto. + eapply find_instr_tail; eauto. + simpl. unfold rs3. decEq. decEq. unfold rs2. rewrite nextinstr_inv; auto with ppcgen. + traceEq. + (* match states *) + constructor. auto. + assert (AG1: agree ms (Vptr stk soff) rs1). + apply agree_exten_2 with rs; auto. + assert (AG2: agree ms (parent_sp s) rs2). + constructor. reflexivity. intros; unfold rs2. + rewrite nextinstr_inv; auto with ppcgen. + rewrite Pregmap.gso; auto with ppcgen. + inv AG1; auto. + unfold rs3. auto with ppcgen. + reflexivity. +Qed. + +Hypothesis wt_prog: wt_program prog. + +Lemma exec_function_internal_prop: + forall (s : list stackframe) (fb : block) (ms : Mach.regset) + (m : mem) (f : function) (m1 m2 m3 : mem) (stk : block), + Genv.find_funct_ptr ge fb = Some (Internal f) -> + alloc m (- fn_framesize f) (fn_stacksize f) = (m1, stk) -> + let sp := Vptr stk (Int.repr (- fn_framesize f)) in + store_stack m1 sp Tint f.(fn_link_ofs) (parent_sp s) = Some m2 -> + store_stack m2 sp Tint f.(fn_retaddr_ofs) (parent_ra s) = Some m3 -> + exec_instr_prop (Machconcr.Callstate s fb ms m) E0 + (Machconcr.State s fb sp (fn_code f) ms m3). +Proof. + 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#IR13 <- sp)). + set (rs3 := nextinstr rs2). + (* Execution of function prologue *) + assert (EXEC_PROLOGUE: + exec_straight tge (transl_function f) + (transl_function f) rs m + (transl_code f f.(fn_code)) rs3 m3). + unfold transl_function at 2. + apply exec_straight_two with rs2 m2. + unfold exec_instr. rewrite H0. fold sp. + rewrite <- (sp_val ms (parent_sp s) rs); auto. + unfold store_stack in H1. change Mint32 with (chunk_of_type Tint). rewrite H1. + auto. + unfold exec_instr. unfold eval_shift_addr. unfold exec_store. + change (rs2 IR13) with sp. change (rs2 IR14) with (rs IR14). rewrite ATLR. + unfold store_stack in H2. change Mint32 with (chunk_of_type Tint). rewrite H2. + auto. auto. auto. + (* Agreement at end of prologue *) + assert (AT3: transl_code_at_pc rs3#PC fb f f.(fn_code)). + change (rs3 PC) with (Val.add (Val.add (rs PC) Vone) Vone). + rewrite ATPC. simpl. constructor. auto. + eapply code_tail_next_int; auto. + eapply code_tail_next_int; auto. + 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. + repeat (rewrite Pregmap.gso). elim AG; auto. + auto with ppcgen. auto with ppcgen. + assert (AG3: agree ms sp rs3). + unfold rs3; auto with ppcgen. + left; exists (State rs3 m3); split. + (* execution *) + eapply exec_straight_steps_1; eauto. + change (Int.unsigned Int.zero) with 0. constructor. + (* match states *) + econstructor; eauto with coqlib. +Qed. + +Lemma exec_function_external_prop: + forall (s : list stackframe) (fb : block) (ms : Mach.regset) + (m : mem) (t0 : trace) (ms' : RegEq.t -> val) + (ef : external_function) (args : list val) (res : val), + 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; 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 IR14)) + m); split. + apply plus_one. eapply exec_step_external; eauto. + eapply extcall_arguments_match; eauto. + econstructor; eauto. + unfold loc_external_result. auto with ppcgen. +Qed. + +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; inv MS. inv STACKS. simpl in *. + right. split. omega. split. auto. + econstructor; eauto. rewrite ATPC; auto. +Qed. + +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 + exec_Mgetparam_prop + exec_Mop_prop + 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_Mreturn_prop + exec_function_internal_prop + exec_function_external_prop + exec_return_prop). + +Lemma transf_initial_states: + forall st1, Machconcr.initial_state prog st1 -> + exists st2, Asm.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 -> Asm.final_state st2 r. +Proof. + intros. inv H0. inv H. constructor. auto. + compute in H1. + rewrite (ireg_val _ _ _ R0 AG) in H1. auto. auto. +Qed. + +Theorem transf_program_correct: + forall (beh: program_behavior), + Machconcr.exec_program prog beh -> Asm.exec_program tprog beh. +Proof. + unfold Machconcr.exec_program, Asm.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/arm/Asmgenproof1.v b/arm/Asmgenproof1.v new file mode 100644 index 0000000..32fedf3 --- /dev/null +++ b/arm/Asmgenproof1.v @@ -0,0 +1,1507 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Correctness proof for ARM code generation: auxiliary results. *) + +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 Machconcr. +Require Import Machtyping. +Require Import Asm. +Require Import Asmgen. +Require Conventions. + +(** * Correspondence between Mach registers and PPC registers *) + +Hint Extern 2 (_ <> _) => discriminate: ppcgen. + +(** Mapping from Mach registers to PPC registers. *) + +Lemma preg_of_injective: + forall r1 r2, preg_of r1 = preg_of r2 -> r1 = r2. +Proof. + destruct r1; destruct r2; simpl; intros; reflexivity || discriminate. +Qed. + +(** Characterization of PPC registers that correspond to Mach registers. *) + +Definition is_data_reg (r: preg) : Prop := + match r with + | IR IR14 => False + | CR _ => False + | PC => False + | _ => True + end. + +Lemma ireg_of_is_data_reg: + forall (r: mreg), is_data_reg (ireg_of r). +Proof. + destruct r; exact I. +Qed. + +Lemma freg_of_is_data_reg: + forall (r: mreg), is_data_reg (ireg_of r). +Proof. + destruct r; exact I. +Qed. + +Lemma preg_of_is_data_reg: + forall (r: mreg), is_data_reg (preg_of r). +Proof. + destruct r; exact I. +Qed. + +Lemma ireg_of_not_IR13: + forall r, ireg_of r <> IR13. +Proof. + intro. case r; discriminate. +Qed. +Lemma ireg_of_not_IR14: + forall r, ireg_of r <> IR14. +Proof. + intro. case r; discriminate. +Qed. + +Hint Resolve ireg_of_not_IR13 ireg_of_not_IR14: ppcgen. + +Lemma preg_of_not: + forall r1 r2, ~(is_data_reg r2) -> preg_of r1 <> r2. +Proof. + intros; red; intro. subst r2. elim H. apply preg_of_is_data_reg. +Qed. +Hint Resolve preg_of_not: ppcgen. + +Lemma preg_of_not_IR13: + forall r, preg_of r <> IR13. +Proof. + intro. case r; discriminate. +Qed. +Hint Resolve preg_of_not_IR13: ppcgen. + +(** Agreement between Mach register sets and PPC register sets. *) + +Definition agree (ms: Mach.regset) (sp: val) (rs: Asm.regset) := + rs#IR13 = sp /\ forall r: mreg, ms r = rs#(preg_of r). + +Lemma preg_val: + forall ms sp rs r, + agree ms sp rs -> ms r = rs#(preg_of r). +Proof. + intros. elim H. auto. +Qed. + +Lemma ireg_val: + forall ms sp rs r, + agree ms sp rs -> + mreg_type r = Tint -> + ms r = rs#(ireg_of r). +Proof. + intros. elim H; intros. + generalize (H2 r). unfold preg_of. rewrite H0. auto. +Qed. + +Lemma freg_val: + forall ms sp rs r, + agree ms sp rs -> + mreg_type r = Tfloat -> + ms r = rs#(freg_of r). +Proof. + intros. elim H; intros. + generalize (H2 r). unfold preg_of. rewrite H0. auto. +Qed. + +Lemma sp_val: + forall ms sp rs, + agree ms sp rs -> + sp = rs#IR13. +Proof. + intros. elim H; auto. +Qed. + +Lemma agree_exten_1: + forall ms sp rs rs', + agree ms sp rs -> + (forall r, is_data_reg r -> rs'#r = rs#r) -> + agree ms sp rs'. +Proof. + unfold agree; intros. elim H; intros. + split. rewrite H0. auto. exact I. + intros. rewrite H0. auto. apply preg_of_is_data_reg. +Qed. + +Lemma agree_exten_2: + forall ms sp rs rs', + agree ms sp rs -> + (forall r, r <> PC -> r <> IR14 -> rs'#r = rs#r) -> + agree ms sp rs'. +Proof. + intros. eapply agree_exten_1; eauto. + intros. apply H0; red; intro; subst r; elim H1. +Qed. + +(** Preservation of register agreement under various assignments. *) + +Lemma agree_set_mreg: + forall ms sp rs r v, + agree ms sp rs -> + agree (Regmap.set r v ms) sp (rs#(preg_of r) <- v). +Proof. + unfold agree; intros. elim H; intros; clear H. + split. rewrite Pregmap.gso. auto. apply sym_not_eq. apply preg_of_not_IR13. + intros. unfold Regmap.set. case (RegEq.eq r0 r); intro. + subst r0. rewrite Pregmap.gss. auto. + rewrite Pregmap.gso. auto. red; intro. + elim n. apply preg_of_injective; auto. +Qed. +Hint Resolve agree_set_mreg: ppcgen. + +Lemma agree_set_mireg: + forall ms sp rs r v, + agree ms sp (rs#(preg_of r) <- v) -> + mreg_type r = Tint -> + agree ms sp (rs#(ireg_of r) <- v). +Proof. + intros. unfold preg_of in H. rewrite H0 in H. auto. +Qed. +Hint Resolve agree_set_mireg: ppcgen. + +Lemma agree_set_mfreg: + forall ms sp rs r v, + agree ms sp (rs#(preg_of r) <- v) -> + mreg_type r = Tfloat -> + agree ms sp (rs#(freg_of r) <- v). +Proof. + intros. unfold preg_of in H. rewrite H0 in H. auto. +Qed. +Hint Resolve agree_set_mfreg: ppcgen. + +Lemma agree_set_other: + forall ms sp rs r v, + agree ms sp rs -> + ~(is_data_reg r) -> + agree ms sp (rs#r <- v). +Proof. + intros. apply agree_exten_1 with rs. + auto. intros. apply Pregmap.gso. red; intro; subst r0; contradiction. +Qed. +Hint Resolve agree_set_other: ppcgen. + +Lemma agree_nextinstr: + forall ms sp rs, + agree ms sp rs -> agree ms sp (nextinstr rs). +Proof. + intros. unfold nextinstr. apply agree_set_other. auto. auto. +Qed. +Hint Resolve agree_nextinstr: ppcgen. + +Lemma agree_set_mireg_twice: + forall ms sp rs r v v', + agree ms sp rs -> + mreg_type r = Tint -> + agree (Regmap.set r v ms) sp (rs #(ireg_of r) <- v' #(ireg_of r) <- v). +Proof. + intros. replace (IR (ireg_of r)) with (preg_of r). elim H; intros. + split. repeat (rewrite Pregmap.gso; auto with ppcgen). + intros. case (mreg_eq r r0); intro. + subst r0. rewrite Regmap.gss. rewrite Pregmap.gss. auto. + assert (preg_of r <> preg_of r0). + red; intro. elim n. apply preg_of_injective. auto. + rewrite Regmap.gso; auto. + repeat (rewrite Pregmap.gso; auto). + unfold preg_of. rewrite H0. auto. +Qed. +Hint Resolve agree_set_mireg_twice: ppcgen. + +Lemma agree_set_twice_mireg: + forall ms sp rs r v v', + agree (Regmap.set r v' ms) sp rs -> + mreg_type r = Tint -> + agree (Regmap.set r v ms) sp (rs#(ireg_of r) <- v). +Proof. + intros. elim H; intros. + split. rewrite Pregmap.gso. auto. + generalize (ireg_of_not_IR13 r); congruence. + intros. generalize (H2 r0). + case (mreg_eq r0 r); intro. + subst r0. repeat rewrite Regmap.gss. unfold preg_of; rewrite H0. + rewrite Pregmap.gss. auto. + repeat rewrite Regmap.gso; auto. + rewrite Pregmap.gso. auto. + replace (IR (ireg_of r)) with (preg_of r). + red; intros. elim n. apply preg_of_injective; auto. + unfold preg_of. rewrite H0. auto. +Qed. +Hint Resolve agree_set_twice_mireg: ppcgen. + +Lemma agree_set_commut: + forall ms sp rs r1 r2 v1 v2, + r1 <> r2 -> + agree ms sp ((rs#r2 <- v2)#r1 <- v1) -> + agree ms sp ((rs#r1 <- v1)#r2 <- v2). +Proof. + intros. apply agree_exten_1 with ((rs#r2 <- v2)#r1 <- v1). auto. + intros. + case (preg_eq r r1); intro. + subst r1. rewrite Pregmap.gss. rewrite Pregmap.gso. rewrite Pregmap.gss. + auto. auto. + case (preg_eq r r2); intro. + subst r2. rewrite Pregmap.gss. rewrite Pregmap.gso. rewrite Pregmap.gss. + auto. auto. + repeat (rewrite Pregmap.gso; auto). +Qed. +Hint Resolve agree_set_commut: ppcgen. + +Lemma agree_nextinstr_commut: + forall ms sp rs r v, + agree ms sp (rs#r <- v) -> + r <> PC -> + agree ms sp ((nextinstr rs)#r <- v). +Proof. + intros. unfold nextinstr. apply agree_set_commut. auto. + apply agree_set_other. auto. auto. +Qed. +Hint Resolve agree_nextinstr_commut: ppcgen. + +Lemma agree_set_mireg_exten: + forall ms sp rs r v (rs': regset), + agree ms sp rs -> + mreg_type r = Tint -> + rs'#(ireg_of r) = v -> + (forall r', r' <> PC -> r' <> ireg_of r -> r' <> IR14 -> rs'#r' = rs#r') -> + agree (Regmap.set r v ms) sp rs'. +Proof. + intros. apply agree_exten_2 with (rs#(ireg_of r) <- v). + auto with ppcgen. + intros. unfold Pregmap.set. case (PregEq.eq r0 (ireg_of r)); intro. + subst r0. auto. apply H2; auto. +Qed. + +(** Useful properties of the PC and GPR0 registers. *) + +Lemma nextinstr_inv: + forall r rs, r <> PC -> (nextinstr rs)#r = rs#r. +Proof. + intros. unfold nextinstr. apply Pregmap.gso. auto. +Qed. +Hint Resolve nextinstr_inv: ppcgen. + +Lemma nextinstr_set_preg: + forall rs m v, + (nextinstr (rs#(preg_of m) <- v))#PC = Val.add rs#PC Vone. +Proof. + intros. unfold nextinstr. rewrite Pregmap.gss. + rewrite Pregmap.gso. auto. apply sym_not_eq. auto with ppcgen. +Qed. +Hint Resolve nextinstr_set_preg: ppcgen. + +(** Connection between Mach and Asm calling conventions for external + functions. *) + +Lemma extcall_arg_match: + forall ms sp rs m l v, + agree ms sp rs -> + Machconcr.extcall_arg ms m sp l v -> + Asm.extcall_arg rs m l v. +Proof. + intros. inv H0. + rewrite (preg_val _ _ _ r H). constructor. + rewrite (sp_val _ _ _ H) in H1. + destruct ty; unfold load_stack in H1. + econstructor. reflexivity. assumption. + econstructor. reflexivity. assumption. +Qed. + +Lemma extcall_args_match: + forall ms sp rs m, agree ms sp rs -> + forall ll vl, + Machconcr.extcall_args ms m sp ll vl -> + Asm.extcall_args rs m ll vl. +Proof. + induction 2; constructor; auto. eapply extcall_arg_match; eauto. +Qed. + +Lemma extcall_arguments_match: + forall ms m sp rs sg args, + agree ms sp rs -> + Machconcr.extcall_arguments ms m sp sg args -> + Asm.extcall_arguments rs m sg args. +Proof. + unfold Machconcr.extcall_arguments, Asm.extcall_arguments; intros. + eapply extcall_args_match; eauto. +Qed. + +(** * Execution of straight-line code *) + +Section STRAIGHTLINE. + +Variable ge: genv. +Variable fn: code. + +(** Straight-line code is composed of PPC instructions that execute + in sequence (no branches, no function calls and returns). + The following inductive predicate relates the machine states + before and after executing a straight-line sequence of instructions. + Instructions are taken from the first list instead of being fetched + from memory. *) + +Inductive exec_straight: code -> regset -> mem -> + code -> regset -> mem -> Prop := + | 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 -> + rs2#PC = Val.add rs1#PC Vone -> + exec_straight c rs2 m2 c' rs3 m3 -> + exec_straight (i :: c) rs1 m1 c' rs3 m3. + +Lemma exec_straight_trans: + forall c1 rs1 m1 c2 rs2 m2 c3 rs3 m3, + exec_straight c1 rs1 m1 c2 rs2 m2 -> + exec_straight c2 rs2 m2 c3 rs3 m3 -> + exec_straight c1 rs1 m1 c3 rs3 m3. +Proof. + induction 1; intros. + apply exec_straight_step with rs2 m2; auto. + apply exec_straight_step with rs2 m2; auto. +Qed. + +Lemma exec_straight_two: + forall i1 i2 c rs1 m1 rs2 m2 rs3 m3, + exec_instr ge fn i1 rs1 m1 = OK rs2 m2 -> + exec_instr ge fn i2 rs2 m2 = OK rs3 m3 -> + rs2#PC = Val.add rs1#PC Vone -> + rs3#PC = Val.add rs2#PC Vone -> + exec_straight (i1 :: i2 :: c) rs1 m1 c rs3 m3. +Proof. + intros. apply exec_straight_step with rs2 m2; auto. + apply exec_straight_one; auto. +Qed. + +Lemma exec_straight_three: + forall i1 i2 i3 c rs1 m1 rs2 m2 rs3 m3 rs4 m4, + exec_instr ge fn i1 rs1 m1 = OK rs2 m2 -> + exec_instr ge fn i2 rs2 m2 = OK rs3 m3 -> + exec_instr ge fn i3 rs3 m3 = OK rs4 m4 -> + rs2#PC = Val.add rs1#PC Vone -> + rs3#PC = Val.add rs2#PC Vone -> + rs4#PC = Val.add rs3#PC Vone -> + exec_straight (i1 :: i2 :: i3 :: c) rs1 m1 c rs4 m4. +Proof. + intros. apply exec_straight_step with rs2 m2; auto. + eapply exec_straight_two; eauto. +Qed. + +Lemma exec_straight_four: + forall i1 i2 i3 i4 c rs1 m1 rs2 m2 rs3 m3 rs4 m4 rs5 m5, + exec_instr ge fn i1 rs1 m1 = OK rs2 m2 -> + exec_instr ge fn i2 rs2 m2 = OK rs3 m3 -> + exec_instr ge fn i3 rs3 m3 = OK rs4 m4 -> + exec_instr ge fn i4 rs4 m4 = OK rs5 m5 -> + rs2#PC = Val.add rs1#PC Vone -> + rs3#PC = Val.add rs2#PC Vone -> + rs4#PC = Val.add rs3#PC Vone -> + rs5#PC = Val.add rs4#PC Vone -> + exec_straight (i1 :: i2 :: i3 :: i4 :: c) rs1 m1 c rs5 m5. +Proof. + intros. apply exec_straight_step with rs2 m2; auto. + eapply exec_straight_three; eauto. +Qed. + +(** * Correctness of ARM constructor functions *) + +(** Properties of comparisons. *) +(* +Lemma compare_float_spec: + forall rs v1 v2, + let rs1 := nextinstr (compare_float rs v1 v2) in + rs1#CR0_0 = Val.cmpf Clt v1 v2 + /\ rs1#CR0_1 = Val.cmpf Cgt v1 v2 + /\ rs1#CR0_2 = Val.cmpf Ceq v1 v2 + /\ forall r', r' <> PC -> r' <> CR0_0 -> r' <> CR0_1 -> + r' <> CR0_2 -> r' <> CR0_3 -> rs1#r' = rs#r'. +Proof. + intros. unfold rs1. + split. reflexivity. + split. reflexivity. + split. reflexivity. + intros. rewrite nextinstr_inv; auto. + unfold compare_float. repeat (rewrite Pregmap.gso; auto). +Qed. + +Lemma compare_sint_spec: + forall rs v1 v2, + let rs1 := nextinstr (compare_sint rs v1 v2) in + rs1#CR0_0 = Val.cmp Clt v1 v2 + /\ rs1#CR0_1 = Val.cmp Cgt v1 v2 + /\ rs1#CR0_2 = Val.cmp Ceq v1 v2 + /\ forall r', r' <> PC -> r' <> CR0_0 -> r' <> CR0_1 -> + r' <> CR0_2 -> r' <> CR0_3 -> rs1#r' = rs#r'. +Proof. + intros. unfold rs1. + split. reflexivity. + split. reflexivity. + split. reflexivity. + intros. rewrite nextinstr_inv; auto. + unfold compare_sint. repeat (rewrite Pregmap.gso; auto). +Qed. + +Lemma compare_uint_spec: + forall rs v1 v2, + let rs1 := nextinstr (compare_uint rs v1 v2) in + rs1#CR0_0 = Val.cmpu Clt v1 v2 + /\ rs1#CR0_1 = Val.cmpu Cgt v1 v2 + /\ rs1#CR0_2 = Val.cmpu Ceq v1 v2 + /\ forall r', r' <> PC -> r' <> CR0_0 -> r' <> CR0_1 -> + r' <> CR0_2 -> r' <> CR0_3 -> rs1#r' = rs#r'. +Proof. + intros. unfold rs1. + split. reflexivity. + split. reflexivity. + split. reflexivity. + intros. rewrite nextinstr_inv; auto. + unfold compare_uint. repeat (rewrite Pregmap.gso; auto). +Qed. +*) + +(** Loading a constant. *) + +Lemma loadimm_correct: + forall r n k rs m, + exists rs', + exec_straight (loadimm r n k) rs m k rs' m + /\ rs'#r = Vint n + /\ forall r': preg, r' <> r -> r' <> PC -> rs'#r' = rs#r'. +Proof. + intros. unfold loadimm. + case (is_immed_arith n). + (* single move *) + exists (nextinstr (rs#r <- (Vint n))). + split. apply exec_straight_one. reflexivity. reflexivity. + split. rewrite nextinstr_inv; auto with ppcgen. + apply Pregmap.gss. + intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto. + case (is_immed_arith (Int.not n)). + (* single move-complement *) + exists (nextinstr (rs#r <- (Vint n))). + split. apply exec_straight_one. + simpl. change (Int.xor (Int.not n) Int.mone) with (Int.not (Int.not n)). + rewrite Int.not_involutive. auto. + reflexivity. + split. rewrite nextinstr_inv; auto with ppcgen. + apply Pregmap.gss. + intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto. + (* mov - or - or - or *) + set (n1 := Int.and n (Int.repr 255)). + set (n2 := Int.and n (Int.repr 65280)). + set (n3 := Int.and n (Int.repr 16711680)). + set (n4 := Int.and n (Int.repr 4278190080)). + set (rs1 := nextinstr (rs#r <- (Vint n1))). + set (rs2 := nextinstr (rs1#r <- (Val.or rs1#r (Vint n2)))). + set (rs3 := nextinstr (rs2#r <- (Val.or rs2#r (Vint n3)))). + set (rs4 := nextinstr (rs3#r <- (Val.or rs3#r (Vint n4)))). + exists rs4. + split. apply exec_straight_four with rs1 m rs2 m rs3 m; auto. + split. unfold rs4. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss. + unfold rs3. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss. + unfold rs2. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss. + unfold rs1. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss. + repeat rewrite Val.or_assoc. simpl. decEq. + unfold n4, n3, n2, n1. repeat rewrite <- Int.and_or_distrib. + change (Int.and n Int.mone = n). apply Int.and_mone. + intros. + unfold rs4. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. + unfold rs3. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. + unfold rs2. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. + unfold rs1. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. +Qed. + +(** Add integer immediate. *) + +Lemma addimm_correct: + forall r1 r2 n k rs m, + exists rs', + exec_straight (addimm r1 r2 n k) rs m k rs' m + /\ rs'#r1 = Val.add rs#r2 (Vint n) + /\ forall r': preg, r' <> r1 -> r' <> PC -> rs'#r' = rs#r'. +Proof. + intros. unfold addimm. + (* addi *) + case (is_immed_arith n). + exists (nextinstr (rs#r1 <- (Val.add rs#r2 (Vint n)))). + split. apply exec_straight_one; auto. + split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. + intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto. + (* subi *) + case (is_immed_arith (Int.neg n)). + exists (nextinstr (rs#r1 <- (Val.sub rs#r2 (Vint (Int.neg n))))). + split. apply exec_straight_one; auto. + split. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss. + apply Val.sub_opp_add. + intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto. + (* general *) + set (n1 := Int.and n (Int.repr 255)). + set (n2 := Int.and n (Int.repr 65280)). + set (n3 := Int.and n (Int.repr 16711680)). + set (n4 := Int.and n (Int.repr 4278190080)). + set (rs1 := nextinstr (rs#r1 <- (Val.add rs#r2 (Vint n1)))). + set (rs2 := nextinstr (rs1#r1 <- (Val.add rs1#r1 (Vint n2)))). + set (rs3 := nextinstr (rs2#r1 <- (Val.add rs2#r1 (Vint n3)))). + set (rs4 := nextinstr (rs3#r1 <- (Val.add rs3#r1 (Vint n4)))). + exists rs4. + split. apply exec_straight_four with rs1 m rs2 m rs3 m; auto. + simpl. + split. unfold rs4. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss. + unfold rs3. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss. + unfold rs2. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss. + unfold rs1. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss. + repeat rewrite Val.add_assoc. simpl. decEq. decEq. + unfold n4, n3, n2, n1. repeat rewrite Int.add_and. + change (Int.and n Int.mone = n). apply Int.and_mone. + vm_compute; auto. + vm_compute; auto. + vm_compute; auto. + intros. + unfold rs4. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. + unfold rs3. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. + unfold rs2. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. + unfold rs1. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. +Qed. + +(* And integer immediate *) + +Lemma andimm_correct: + forall r1 r2 n k rs m, + r2 <> IR14 -> + exists rs', + exec_straight (andimm r1 r2 n k) rs m k rs' m + /\ rs'#r1 = Val.and rs#r2 (Vint n) + /\ forall r': preg, r' <> r1 -> r' <> IR14 -> r' <> PC -> rs'#r' = rs#r'. +Proof. + intros. unfold andimm. + (* andi *) + case (is_immed_arith n). + exists (nextinstr (rs#r1 <- (Val.and rs#r2 (Vint n)))). + split. apply exec_straight_one; auto. + split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. + intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto. + (* bici *) + case (is_immed_arith (Int.not n)). + exists (nextinstr (rs#r1 <- (Val.and rs#r2 (Vint n)))). + split. apply exec_straight_one; auto. simpl. + change (Int.xor (Int.not n) Int.mone) with (Int.not (Int.not n)). + rewrite Int.not_involutive. auto. + split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. + intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto. + (* general *) + exploit loadimm_correct. intros [rs' [A [B C]]]. + exists (nextinstr (rs'#r1 <- (Val.and rs#r2 (Vint n)))). + split. eapply exec_straight_trans. eauto. apply exec_straight_one. + simpl. rewrite B. rewrite C; auto with ppcgen. congruence. + auto. + split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. + intros. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. +Qed. + +(** Other integer immediate *) + +Lemma makeimm_correct: + forall (instr: ireg -> ireg -> shift_op -> instruction) + (sem: val -> val -> val) + r1 (r2: ireg) n k (rs : regset) m, + (forall c r1 r2 so rs m, + exec_instr ge c (instr r1 r2 so) rs m + = OK (nextinstr rs#r1 <- (sem rs#r2 (eval_shift_op so rs))) m) -> + r2 <> IR14 -> + exists rs', + exec_straight (makeimm instr r1 r2 n k) rs m k rs' m + /\ rs'#r1 = sem rs#r2 (Vint n) + /\ forall r': preg, r' <> r1 -> r' <> PC -> r' <> IR14 -> rs'#r' = rs#r'. +Proof. + intros. unfold makeimm. + case (is_immed_arith n). + (* one immed instr *) + exists (nextinstr (rs#r1 <- (sem rs#r2 (Vint n)))). + split. apply exec_straight_one. + change (Vint n) with (eval_shift_op (SOimm n) rs). auto. + auto. + split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. + intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto. + (* general case *) + exploit loadimm_correct. intros [rs' [A [B C]]]. + exists (nextinstr (rs'#r1 <- (sem rs#r2 (Vint n)))). + split. eapply exec_straight_trans. eauto. apply exec_straight_one. + rewrite <- B. rewrite <- (C r2). + change (rs' IR14) with (eval_shift_op (SOreg IR14) rs'). auto. + congruence. auto with ppcgen. auto. + split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. + intros. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto with ppcgen. +Qed. + +(** Indexed memory loads. *) + +Lemma loadind_int_correct: + forall (base: ireg) ofs dst (rs: regset) m v k, + Mem.loadv Mint32 m (Val.add rs#base (Vint ofs)) = Some v -> + exists rs', + exec_straight (loadind_int base ofs dst k) rs m k rs' m + /\ rs'#dst = v + /\ forall r, r <> PC -> r <> IR14 -> r <> dst -> rs'#r = rs#r. +Proof. + intros; unfold loadind_int. destruct (is_immed_mem_word ofs). + exists (nextinstr (rs#dst <- v)). + split. apply exec_straight_one. simpl. + unfold exec_load. rewrite H. auto. auto. + split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. + intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto. + exploit addimm_correct. intros [rs' [A [B C]]]. + exists (nextinstr (rs'#dst <- v)). + split. eapply exec_straight_trans. eauto. apply exec_straight_one. + simpl. unfold exec_load. rewrite B. + rewrite Val.add_assoc. simpl. rewrite Int.add_zero. + rewrite H. auto. + auto. + split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. + intros. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. +Qed. + +Lemma loadind_float_correct: + forall (base: ireg) ofs dst (rs: regset) m v k, + Mem.loadv Mfloat64 m (Val.add rs#base (Vint ofs)) = Some v -> + exists rs', + exec_straight (loadind_float base ofs dst k) rs m k rs' m + /\ rs'#dst = v + /\ forall r, r <> PC -> r <> IR14 -> r <> dst -> rs'#r = rs#r. +Proof. + intros; unfold loadind_float. destruct (is_immed_mem_float ofs). + exists (nextinstr (rs#dst <- v)). + split. apply exec_straight_one. simpl. + unfold exec_load. rewrite H. auto. auto. + split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. + intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto. + exploit addimm_correct. eauto. intros [rs' [A [B C]]]. + exists (nextinstr (rs'#dst <- v)). + split. eapply exec_straight_trans. eauto. apply exec_straight_one. + simpl. unfold exec_load. rewrite B. rewrite Val.add_assoc. simpl. + rewrite Int.add_zero. rewrite H. auto. auto. + split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. + intros. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. +Qed. + +Lemma loadind_correct: + forall (base: ireg) ofs ty dst k (rs: regset) m v, + Mem.loadv (chunk_of_type ty) m (Val.add rs#base (Vint ofs)) = Some v -> + mreg_type dst = ty -> + exists rs', + exec_straight (loadind base ofs ty dst k) rs m k rs' m + /\ rs'#(preg_of dst) = v + /\ forall r, r <> PC -> r <> IR14 -> r <> preg_of dst -> rs'#r = rs#r. +Proof. + intros. unfold loadind. + assert (preg_of dst <> PC). + unfold preg_of. case (mreg_type dst); discriminate. + unfold preg_of. rewrite H0. destruct ty. + apply loadind_int_correct; auto. + apply loadind_float_correct; auto. +Qed. + +(** Indexed memory stores. *) + +Lemma storeind_int_correct: + forall (base: ireg) ofs (src: ireg) (rs: regset) m m' k, + Mem.storev Mint32 m (Val.add rs#base (Vint ofs)) (rs#src) = Some m' -> + src <> IR14 -> + exists rs', + exec_straight (storeind_int src base ofs k) rs m k rs' m' + /\ forall r, r <> PC -> r <> IR14 -> rs'#r = rs#r. +Proof. + intros; unfold storeind_int. destruct (is_immed_mem_word ofs). + exists (nextinstr rs). + split. apply exec_straight_one. simpl. + unfold exec_store. rewrite H. auto. auto. + intros. rewrite nextinstr_inv; auto. + exploit addimm_correct. eauto. intros [rs' [A [B C]]]. + exists (nextinstr rs'). + split. eapply exec_straight_trans. eauto. apply exec_straight_one. + simpl. unfold exec_store. rewrite B. rewrite C. + rewrite Val.add_assoc. simpl. rewrite Int.add_zero. + rewrite H. auto. + congruence. auto with ppcgen. auto. + intros. rewrite nextinstr_inv; auto. +Qed. + +Lemma storeind_float_correct: + forall (base: ireg) ofs (src: freg) (rs: regset) m m' k, + Mem.storev Mfloat64 m (Val.add rs#base (Vint ofs)) (rs#src) = Some m' -> + base <> IR14 -> + exists rs', + exec_straight (storeind_float src base ofs k) rs m k rs' m' + /\ forall r, r <> PC -> r <> IR14 -> rs'#r = rs#r. +Proof. + intros; unfold storeind_float. destruct (is_immed_mem_float ofs). + exists (nextinstr rs). + split. apply exec_straight_one. simpl. + unfold exec_store. rewrite H. auto. auto. + intros. rewrite nextinstr_inv; auto. + exploit addimm_correct. eauto. intros [rs' [A [B C]]]. + exists (nextinstr rs'). + split. eapply exec_straight_trans. eauto. apply exec_straight_one. + simpl. unfold exec_store. rewrite B. rewrite C. + rewrite Val.add_assoc. simpl. rewrite Int.add_zero. + rewrite H. auto. + congruence. congruence. auto with ppcgen. auto. + intros. rewrite nextinstr_inv; auto. +Qed. + +Lemma storeind_correct: + forall (base: ireg) ofs ty src k (rs: regset) m m', + Mem.storev (chunk_of_type ty) m (Val.add rs#base (Vint ofs)) (rs#(preg_of src)) = Some m' -> + mreg_type src = ty -> + base <> IR14 -> + exists rs', + exec_straight (storeind src base ofs ty k) rs m k rs' m' + /\ forall r, r <> PC -> r <> IR14 -> rs'#r = rs#r. +Proof. + intros. unfold storeind. unfold preg_of in H. rewrite H0 in H. destruct ty. + apply storeind_int_correct. auto. auto. auto with ppcgen. + apply storeind_float_correct. auto. auto. +Qed. + +(** Translation of shift immediates *) + +Lemma transl_shift_correct: + forall s (r: ireg) (rs: regset), + eval_shift_op (transl_shift s r) rs = eval_shift_total s (rs#r). +Proof. + intros. destruct s; simpl; + unfold eval_shift_total, eval_shift, Val.shl, Val.shr, Val.shru, Val.ror; + rewrite (s_amount_ltu s); auto. +Qed. + +Lemma transl_shift_addr_correct: + forall s (r: ireg) (rs: regset), + eval_shift_addr (transl_shift_addr s r) rs = eval_shift_total s (rs#r). +Proof. + intros. destruct s; simpl; + unfold eval_shift_total, eval_shift, Val.shl, Val.shr, Val.shru, Val.ror; + rewrite (s_amount_ltu s); auto. +Qed. + +(** Translation of conditions *) + +Ltac TypeInv := + match goal with + | H: (List.map ?f ?x = nil) |- _ => + destruct x; [clear H | simpl in H; discriminate] + | H: (List.map ?f ?x = ?hd :: ?tl) |- _ => + destruct x; simpl in H; + [ discriminate | + injection H; clear H; let T := fresh "T" in ( + intros H T; TypeInv) ] + | _ => idtac + end. + +(** Translation of conditions. *) + +Lemma compare_int_spec: + forall rs v1 v2, + let rs1 := nextinstr (compare_int rs v1 v2) in + rs1#CReq = (Val.cmp Ceq v1 v2) + /\ rs1#CRne = (Val.cmp Cne v1 v2) + /\ rs1#CRhs = (Val.cmpu Cge v1 v2) + /\ rs1#CRlo = (Val.cmpu Clt v1 v2) + /\ rs1#CRhi = (Val.cmpu Cgt v1 v2) + /\ rs1#CRls = (Val.cmpu Cle v1 v2) + /\ rs1#CRge = (Val.cmp Cge v1 v2) + /\ rs1#CRlt = (Val.cmp Clt v1 v2) + /\ rs1#CRgt = (Val.cmp Cgt v1 v2) + /\ rs1#CRle = (Val.cmp Cle v1 v2) + /\ forall r', is_data_reg r' -> rs1#r' = rs#r'. +Proof. + intros. unfold rs1. intuition; try reflexivity. + rewrite nextinstr_inv; [unfold compare_int; repeat rewrite Pregmap.gso; auto | idtac]; + red; intro; subst r'; elim H. +Qed. + +Lemma compare_float_spec: + forall rs v1 v2, + let rs' := nextinstr (compare_float rs v1 v2) in + rs'#CReq = (Val.cmpf Ceq v1 v2) + /\ rs'#CRne = (Val.cmpf Cne v1 v2) + /\ rs'#CRmi = (Val.cmpf Clt v1 v2) + /\ rs'#CRpl = (Val.notbool (Val.cmpf Clt v1 v2)) + /\ rs'#CRhi = (Val.notbool (Val.cmpf Cle v1 v2)) + /\ rs'#CRls = (Val.cmpf Cle v1 v2) + /\ rs'#CRge = (Val.cmpf Cge v1 v2) + /\ rs'#CRlt = (Val.notbool (Val.cmpf Cge v1 v2)) + /\ rs'#CRgt = (Val.cmpf Cgt v1 v2) + /\ rs'#CRle = (Val.notbool (Val.cmpf Cgt v1 v2)) + /\ forall r', is_data_reg r' -> rs'#r' = rs#r'. +Proof. + intros. unfold rs'. intuition; try reflexivity. + rewrite nextinstr_inv; [unfold compare_float; repeat rewrite Pregmap.gso; auto | idtac]; + red; intro; subst r'; elim H. +Qed. + +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) m = Some b -> + exists rs', + exec_straight (transl_cond cond args k) rs m k rs' m + /\ rs'#(CR (crbit_for_cond cond)) = Val.of_bool b + /\ agree ms sp rs'. +Proof. + intros. + rewrite <- (eval_condition_weaken _ _ _ H1). clear H1. + destruct cond; simpl in H; TypeInv; simpl. + (* Ccomp *) + generalize (compare_int_spec rs ms#m0 ms#m1). + intros [A [B [C [D [E [F [G [H [I [J K]]]]]]]]]]. + exists (nextinstr (compare_int rs ms#m0 ms#m1)). + split. apply exec_straight_one. simpl. + repeat rewrite <- (ireg_val ms sp rs); trivial. + reflexivity. + split. + case c; simpl; auto. + apply agree_exten_1 with rs; auto. + (* Ccompu *) + generalize (compare_int_spec rs ms#m0 ms#m1). + intros [A [B [C [D [E [F [G [H [I [J K]]]]]]]]]]. + exists (nextinstr (compare_int rs ms#m0 ms#m1)). + split. apply exec_straight_one. simpl. + repeat rewrite <- (ireg_val ms sp rs); trivial. + reflexivity. + split. + case c; simpl; auto. + apply agree_exten_1 with rs; auto. + (* Ccompshift *) + generalize (compare_int_spec rs ms#m0 (eval_shift_total s ms#m1)). + intros [A [B [C [D [E [F [G [H [I [J K]]]]]]]]]]. + exists (nextinstr (compare_int rs ms#m0 (eval_shift_total s ms#m1))). + split. apply exec_straight_one. simpl. + rewrite transl_shift_correct. + repeat rewrite <- (ireg_val ms sp rs); trivial. + reflexivity. + split. + case c; simpl; auto. + apply agree_exten_1 with rs; auto. + (* Ccompushift *) + generalize (compare_int_spec rs ms#m0 (eval_shift_total s ms#m1)). + intros [A [B [C [D [E [F [G [H [I [J K]]]]]]]]]]. + exists (nextinstr (compare_int rs ms#m0 (eval_shift_total s ms#m1))). + split. apply exec_straight_one. simpl. + rewrite transl_shift_correct. + repeat rewrite <- (ireg_val ms sp rs); trivial. + reflexivity. + split. + case c; simpl; auto. + apply agree_exten_1 with rs; auto. + (* Ccompimm *) + destruct (is_immed_arith i). + generalize (compare_int_spec rs ms#m0 (Vint i)). + intros [A [B [C [D [E [F [G [H [I [J K]]]]]]]]]]. + exists (nextinstr (compare_int rs ms#m0 (Vint i))). + split. apply exec_straight_one. simpl. + rewrite <- (ireg_val ms sp rs); trivial. auto. + split. + case c; simpl; auto. + apply agree_exten_1 with rs; auto. + exploit (loadimm_correct IR14). intros [rs' [P [Q R]]]. + assert (AG: agree ms sp rs'). apply agree_exten_2 with rs; auto. + generalize (compare_int_spec rs' ms#m0 (Vint i)). + intros [A [B [C [D [E [F [G [H [I [J K]]]]]]]]]]. + exists (nextinstr (compare_int rs' ms#m0 (Vint i))). + split. eapply exec_straight_trans. eexact P. apply exec_straight_one. simpl. + rewrite Q. rewrite <- (ireg_val ms sp rs'); trivial. auto. + split. + case c; simpl; auto. + apply agree_exten_1 with rs'; auto. + (* Ccompuimm *) + destruct (is_immed_arith i). + generalize (compare_int_spec rs ms#m0 (Vint i)). + intros [A [B [C [D [E [F [G [H [I [J K]]]]]]]]]]. + exists (nextinstr (compare_int rs ms#m0 (Vint i))). + split. apply exec_straight_one. simpl. + rewrite <- (ireg_val ms sp rs); trivial. auto. + split. + case c; simpl; auto. + apply agree_exten_1 with rs; auto. + exploit (loadimm_correct IR14). intros [rs' [P [Q R]]]. + assert (AG: agree ms sp rs'). apply agree_exten_2 with rs; auto. + generalize (compare_int_spec rs' ms#m0 (Vint i)). + intros [A [B [C [D [E [F [G [H [I [J K]]]]]]]]]]. + exists (nextinstr (compare_int rs' ms#m0 (Vint i))). + split. eapply exec_straight_trans. eexact P. apply exec_straight_one. simpl. + rewrite Q. rewrite <- (ireg_val ms sp rs'); trivial. auto. + split. + case c; simpl; auto. + apply agree_exten_1 with rs'; auto. + (* Ccompf *) + generalize (compare_float_spec rs ms#m0 ms#m1). + intros [A [B [C [D [E [F [G [H [I [J K]]]]]]]]]]. + exists (nextinstr (compare_float rs ms#m0 ms#m1)). + split. apply exec_straight_one. simpl. + repeat rewrite <- (freg_val ms sp rs); trivial. auto. + split. + case c; simpl; auto. + apply agree_exten_1 with rs; auto. + (* Cnotcompf *) + generalize (compare_float_spec rs ms#m0 ms#m1). + intros [A [B [C [D [E [F [G [H [I [J K]]]]]]]]]]. + exists (nextinstr (compare_float rs ms#m0 ms#m1)). + split. apply exec_straight_one. simpl. + repeat rewrite <- (freg_val ms sp rs); trivial. auto. + split. + case c; simpl; auto. + rewrite Val.negate_cmpf_ne. auto. + rewrite Val.negate_cmpf_eq. auto. + apply agree_exten_1 with rs; auto. +Qed. + +(** Translation of arithmetic operations. *) + +Ltac TranslOpSimpl := + match goal with + | |- exists rs' : regset, + exec_straight ?c ?rs ?m ?k rs' ?m /\ + agree (Regmap.set ?res ?v ?ms) ?sp rs' => + (exists (nextinstr (rs#(ireg_of res) <- v)); + split; + [ apply exec_straight_one; + [ repeat (rewrite (ireg_val ms sp rs); auto); + simpl; try rewrite transl_shift_correct; reflexivity + | reflexivity ] + | auto with ppcgen ]) + || + (exists (nextinstr (rs#(freg_of res) <- v)); + split; + [ apply exec_straight_one; + [ repeat (rewrite (freg_val ms sp rs); auto); reflexivity + | reflexivity ] + | auto with ppcgen ]) + end. + +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) 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.*) + inversion H. + (* Omove *) + simpl. exists (nextinstr (rs#(preg_of res) <- (ms r1))). + split. caseEq (mreg_type r1); intro. + apply exec_straight_one. simpl. rewrite (ireg_val ms sp rs); auto. + simpl. unfold preg_of. rewrite <- H3. rewrite H6. reflexivity. + auto with ppcgen. + apply exec_straight_one. simpl. rewrite (freg_val ms sp rs); auto. + simpl. unfold preg_of. rewrite <- H3. rewrite H6. reflexivity. + auto with ppcgen. + auto with ppcgen. + (* Other instructions *) + clear H2 H3 H5. + destruct op; simpl in H6; injection H6; clear H6; intros; + TypeInv; simpl; try (TranslOpSimpl). + (* Omove again *) + congruence. + (* Ointconst *) + generalize (loadimm_correct (ireg_of res) i k rs m). + intros [rs' [A [B C]]]. + exists rs'. split. auto. + apply agree_set_mireg_exten with rs; auto. +(* + (* Ofloatconst *) + exists (nextinstr (rs#(freg_of res) <- (Vfloat f))). + split. apply exec_straight_one. reflexivity. reflexivity. + auto with ppcgen. + (* Oaddrsymbol *) + change (find_symbol_offset ge i i0) with (symbol_offset ge i i0). + set (v := symbol_offset ge i i0). + pose (rs1 := nextinstr (rs#GPR2 <- (high_half v))). + exists (nextinstr (rs1#(ireg_of res) <- v)). + split. apply exec_straight_two with rs1 m. + unfold exec_instr. rewrite gpr_or_zero_zero. + unfold const_high. rewrite Val.add_commut. + rewrite high_half_zero. reflexivity. + simpl. rewrite gpr_or_zero_not_zero. 2: congruence. + unfold rs1 at 1. rewrite nextinstr_inv; auto with ppcgen. + rewrite Pregmap.gss. + fold v. rewrite Val.add_commut. unfold v. rewrite low_high_half. + reflexivity. reflexivity. reflexivity. + unfold rs1. apply agree_nextinstr. apply agree_set_mireg; auto. + apply agree_set_mreg. apply agree_nextinstr. + apply agree_set_other. auto. simpl. tauto. +*) + (* Oaddrstack *) + generalize (addimm_correct (ireg_of res) IR13 i k rs m). + intros [rs' [EX [RES OTH]]]. + exists rs'. split. auto. + apply agree_set_mireg_exten with rs; auto. + rewrite (sp_val ms sp rs). auto. auto. + (* Ocast8signed *) + set (rs1 := nextinstr (rs#(ireg_of res) <- (Val.shl (ms m0) (Vint (Int.repr 24))))). + set (rs2 := nextinstr (rs1#(ireg_of res) <- (Val.shr (rs1 (ireg_of res)) (Vint (Int.repr 24))))). + exists rs2. split. + apply exec_straight_two with rs1 m; auto. + simpl. rewrite <- (ireg_val ms sp rs); auto. + unfold rs2. + replace (Val.shr (rs1 (ireg_of res)) (Vint (Int.repr 24))) with (Val.sign_ext 8 (ms m0)). + apply agree_nextinstr. unfold rs1. apply agree_nextinstr_commut. + apply agree_set_mireg_twice; auto with ppcgen. auto with ppcgen. + unfold rs1. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss. + destruct (ms m0); simpl; auto. rewrite Int.sign_ext_shr_shl. reflexivity. + vm_compute; auto. + (* Ocast8unsigned *) + exists (nextinstr (rs#(ireg_of res) <- (Val.and (ms m0) (Vint (Int.repr 255))))). + split. apply exec_straight_one. repeat (rewrite (ireg_val ms sp rs)); auto. reflexivity. + replace (Val.zero_ext 8 (ms m0)) + with (Val.and (ms m0) (Vint (Int.repr 255))). + auto with ppcgen. + destruct (ms m0); simpl; auto. rewrite Int.zero_ext_and. reflexivity. + vm_compute; auto. + (* Ocast16signed *) + set (rs1 := nextinstr (rs#(ireg_of res) <- (Val.shl (ms m0) (Vint (Int.repr 16))))). + set (rs2 := nextinstr (rs1#(ireg_of res) <- (Val.shr (rs1 (ireg_of res)) (Vint (Int.repr 16))))). + exists rs2. split. + apply exec_straight_two with rs1 m; auto. + simpl. rewrite <- (ireg_val ms sp rs); auto. + unfold rs2. + replace (Val.shr (rs1 (ireg_of res)) (Vint (Int.repr 16))) with (Val.sign_ext 16 (ms m0)). + apply agree_nextinstr. unfold rs1. apply agree_nextinstr_commut. + apply agree_set_mireg_twice; auto with ppcgen. auto with ppcgen. + unfold rs1. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss. + destruct (ms m0); simpl; auto. rewrite Int.sign_ext_shr_shl. reflexivity. + vm_compute; auto. + (* Ocast16unsigned *) + set (rs1 := nextinstr (rs#(ireg_of res) <- (Val.shl (ms m0) (Vint (Int.repr 16))))). + set (rs2 := nextinstr (rs1#(ireg_of res) <- (Val.shru (rs1 (ireg_of res)) (Vint (Int.repr 16))))). + exists rs2. split. + apply exec_straight_two with rs1 m; auto. + simpl. rewrite <- (ireg_val ms sp rs); auto. + unfold rs2. + replace (Val.shru (rs1 (ireg_of res)) (Vint (Int.repr 16))) with (Val.zero_ext 16 (ms m0)). + apply agree_nextinstr. unfold rs1. apply agree_nextinstr_commut. + apply agree_set_mireg_twice; auto with ppcgen. auto with ppcgen. + unfold rs1. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss. + destruct (ms m0); simpl; auto. rewrite Int.zero_ext_shru_shl. reflexivity. + vm_compute; auto. + (* Oaddimm *) + generalize (addimm_correct (ireg_of res) (ireg_of m0) i k rs m). + intros [rs' [A [B C]]]. + exists rs'. split. auto. + apply agree_set_mireg_exten with rs; auto. + rewrite (ireg_val ms sp rs); auto. + (* Orsbimm *) + exploit (makeimm_correct Prsb (fun v1 v2 => Val.sub v2 v1) (ireg_of res) (ireg_of m0)); + auto with ppcgen. + intros [rs' [A [B C]]]. + exists rs'. + split. eauto. + apply agree_set_mireg_exten with rs; auto. rewrite B. + rewrite <- (ireg_val ms sp rs); auto. + (* Omul *) + destruct (ireg_eq (ireg_of res) (ireg_of m0) || ireg_eq (ireg_of res) (ireg_of m1)). + set (rs1 := nextinstr (rs#IR14 <- (Val.mul (ms m0) (ms m1)))). + set (rs2 := nextinstr (rs1#(ireg_of res) <- (rs1#IR14))). + exists rs2; split. + apply exec_straight_two with rs1 m; auto. + simpl. repeat rewrite <- (ireg_val ms sp rs); auto. + unfold rs2. unfold rs1. rewrite nextinstr_inv. rewrite Pregmap.gss. + apply agree_nextinstr. apply agree_nextinstr_commut. + apply agree_set_mireg; auto. apply agree_set_mreg. apply agree_set_other. auto. + simpl; auto. auto with ppcgen. discriminate. + TranslOpSimpl. + (* Oandimm *) + generalize (andimm_correct (ireg_of res) (ireg_of m0) i k rs m + (ireg_of_not_IR14 m0)). + intros [rs' [A [B C]]]. + exists rs'. split. auto. + apply agree_set_mireg_exten with rs; auto. + rewrite (ireg_val ms sp rs); auto. + (* Oorimm *) + exploit (makeimm_correct Porr Val.or (ireg_of res) (ireg_of m0)); + auto with ppcgen. + intros [rs' [A [B C]]]. + exists rs'. + split. eauto. + apply agree_set_mireg_exten with rs; auto. rewrite B. + rewrite <- (ireg_val ms sp rs); auto. + (* Oxorimm *) + exploit (makeimm_correct Peor Val.xor (ireg_of res) (ireg_of m0)); + auto with ppcgen. + intros [rs' [A [B C]]]. + exists rs'. + split. eauto. + apply agree_set_mireg_exten with rs; auto. rewrite B. + rewrite <- (ireg_val ms sp rs); auto. + (* Oshrximm *) + assert (exists n, ms m0 = Vint n /\ Int.ltu i (Int.repr 31) = true). + simpl in H1. destruct (ms m0); try discriminate. + exists i0; split; auto. destruct (Int.ltu i (Int.repr 31)); discriminate || auto. + destruct H3 as [n [ARG1 LTU]]. + assert (LTU': Int.ltu i (Int.repr 32) = true). + exploit Int.ltu_inv. eexact LTU. intro. + unfold Int.ltu. apply zlt_true. + assert (Int.unsigned (Int.repr 31) < Int.unsigned (Int.repr 32)). vm_compute; auto. + omega. + assert (RSm0: rs (ireg_of m0) = Vint n). + rewrite <- ARG1. symmetry. eapply ireg_val; eauto. + set (islt := Int.lt n Int.zero). + set (rs1 := nextinstr (compare_int rs (Vint n) (Vint Int.zero))). + assert (OTH1: forall r', is_data_reg r' -> rs1#r' = rs#r'). + generalize (compare_int_spec rs (Vint n) (Vint Int.zero)). + fold rs1. intros [A B]. intuition. + exploit (addimm_correct IR14 (ireg_of m0) (Int.sub (Int.shl Int.one i) Int.one)). + intros [rs2 [EXEC2 [RES2 OTH2]]]. + set (rs3 := nextinstr (if islt then rs2 else rs2#IR14 <- (Vint n))). + set (rs4 := nextinstr (rs3#(ireg_of res) <- (Val.shr rs3#IR14 (Vint i)))). + exists rs4; split. + apply exec_straight_step with rs1 m. + simpl. rewrite RSm0. auto. auto. + eapply exec_straight_trans. eexact EXEC2. + apply exec_straight_two with rs3 m. + simpl. rewrite OTH2. change (rs1 CRge) with (Val.cmp Cge (Vint n) (Vint Int.zero)). + unfold Val.cmp. change (Int.cmp Cge n Int.zero) with (negb islt). + rewrite OTH2. rewrite OTH1. rewrite RSm0. + unfold rs3. case islt; reflexivity. + apply ireg_of_is_data_reg. decEq; auto with ppcgen. auto with ppcgen. congruence. congruence. + simpl. auto. + auto. unfold rs3. case islt; auto. auto. + (* agreement *) + assert (RES4: rs4#(ireg_of res) = Vint(Int.shrx n i)). + unfold rs4. rewrite nextinstr_inv; auto. rewrite Pregmap.gss. + rewrite Int.shrx_shr. fold islt. unfold rs3. + repeat rewrite nextinstr_inv; auto. + case islt. rewrite RES2. rewrite OTH1. rewrite RSm0. + simpl. rewrite LTU'. auto. + apply ireg_of_is_data_reg. + rewrite Pregmap.gss. simpl. rewrite LTU'. auto. congruence. + exact LTU. auto with ppcgen. + assert (OTH4: forall r, is_data_reg r -> r <> ireg_of res -> rs4#r = rs#r). + intros. + assert (r <> PC). red; intro; subst r; elim H3. + assert (r <> IR14). red; intro; subst r; elim H3. + unfold rs4. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. + unfold rs3. rewrite nextinstr_inv; auto. + transitivity (rs2 r). + case islt. auto. apply Pregmap.gso; auto. + rewrite OTH2; auto. + apply agree_exten_1 with (rs#(ireg_of res) <- (Val.shrx (ms m0) (Vint i))). + auto with ppcgen. + intros. unfold Pregmap.set. destruct (PregEq.eq r (ireg_of res)). + subst r. rewrite ARG1. simpl. rewrite LTU'. auto. + auto. + (* Ointoffloat *) + exists (nextinstr (rs#(ireg_of res) <- (Val.intoffloat (ms m0)))). + split. apply exec_straight_one. + repeat (rewrite (freg_val ms sp rs); auto). + reflexivity. auto with ppcgen. + (* Ointuoffloat *) + exists (nextinstr (rs#(ireg_of res) <- (Val.intuoffloat (ms m0)))). + split. apply exec_straight_one. + repeat (rewrite (freg_val ms sp rs); auto). + reflexivity. auto with ppcgen. + (* Ofloatofint *) + exists (nextinstr (rs#(freg_of res) <- (Val.floatofint (ms m0)))). + split. apply exec_straight_one. + repeat (rewrite (ireg_val ms sp rs); auto). + reflexivity. auto 10 with ppcgen. + (* Ofloatofintu *) + exists (nextinstr (rs#(freg_of res) <- (Val.floatofintu (ms m0)))). + split. apply exec_straight_one. + repeat (rewrite (ireg_val ms sp rs); auto). + reflexivity. auto 10 with ppcgen. + (* Ocmp *) + assert (exists b, eval_condition c ms##args m = Some b /\ v = Val.of_bool b). + simpl in H1. destruct (eval_condition c ms##args m). + destruct b; inv H1. exists true; auto. exists false; auto. + discriminate. + destruct H5 as [b [EVC EQ]]. + exploit transl_cond_correct; eauto. intros [rs' [A [B C]]]. + rewrite (eval_condition_weaken _ _ _ EVC). + set (rs1 := nextinstr (rs'#(ireg_of res) <- (Vint Int.zero))). + set (rs2 := nextinstr (if b then (rs1#(ireg_of res) <- Vtrue) else rs1)). + exists rs2; split. + eapply exec_straight_trans. eauto. + apply exec_straight_two with rs1 m; auto. + simpl. replace (rs1 (crbit_for_cond c)) with (Val.of_bool b). + unfold rs2. destruct b; auto. + unfold rs2. destruct b; auto. + apply agree_set_mireg_exten with rs'; auto. + unfold rs2. rewrite nextinstr_inv; auto with ppcgen. + destruct b. apply Pregmap.gss. + unfold rs1. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. + intros. unfold rs2. rewrite nextinstr_inv; auto. + transitivity (rs1 r'). destruct b; auto. rewrite Pregmap.gso; auto. + unfold rs1. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto. +Qed. + +Remark val_add_add_zero: + forall v1 v2, Val.add v1 v2 = Val.add (Val.add v1 v2) (Vint Int.zero). +Proof. + intros. destruct v1; destruct v2; simpl; auto; rewrite Int.add_zero; auto. +Qed. + +Lemma transl_load_store_correct: + forall (mk_instr_imm: ireg -> int -> instruction) + (mk_instr_gen: option (ireg -> shift_addr -> instruction)) + (is_immed: int -> bool) + addr args k ms sp rs m ms' m', + (forall (r1: ireg) (rs1: regset) n k, + eval_addressing_total sp addr (map ms args) = Val.add rs1#r1 (Vint n) -> + agree ms sp rs1 -> + exists rs', + exec_straight (mk_instr_imm r1 n :: k) rs1 m k rs' m' /\ + agree ms' sp rs') -> + match mk_instr_gen with + | None => True + | Some mk => + (forall (r1: ireg) (sa: shift_addr) (rs1: regset) k, + eval_addressing_total sp addr (map ms args) = Val.add rs1#r1 (eval_shift_addr sa rs1) -> + agree ms sp rs1 -> + exists rs', + exec_straight (mk r1 sa :: k) rs1 m k rs' m' /\ + agree ms' sp rs') + end -> + agree ms sp rs -> + map mreg_type args = type_of_addressing addr -> + exists rs', + exec_straight (transl_load_store mk_instr_imm mk_instr_gen is_immed addr args k) rs m + k rs' m' + /\ agree ms' sp rs'. +Proof. + intros. destruct addr; simpl in H2; TypeInv; simpl. + (* Aindexed *) + case (is_immed i). + (* Aindexed, small displacement *) + apply H; eauto. simpl. rewrite (ireg_val ms sp rs); auto. + (* Aindexed, large displacement *) + exploit (addimm_correct IR14 (ireg_of t)); eauto with ppcgen. + intros [rs' [A [B C]]]. + exploit (H IR14 rs' Int.zero); eauto. + simpl. rewrite (ireg_val ms sp rs); auto. rewrite B. + rewrite Val.add_assoc. simpl Val.add. rewrite Int.add_zero. reflexivity. + apply agree_exten_2 with rs; auto. + intros [rs'' [D E]]. + exists rs''; split. + eapply exec_straight_trans. eexact A. eexact D. auto. + (* Aindexed2 *) + destruct mk_instr_gen as [mk | ]. + (* binary form available *) + apply H0; auto. simpl. repeat rewrite (ireg_val ms sp rs); auto. + (* binary form not available *) + set (rs' := nextinstr (rs#IR14 <- (Val.add (ms t) (ms t0)))). + exploit (H IR14 rs' Int.zero); eauto. + simpl. repeat rewrite (ireg_val ms sp rs); auto. + unfold rs'. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss. + repeat rewrite (ireg_val ms sp rs); auto. apply val_add_add_zero. + unfold rs'; auto with ppcgen. + intros [rs'' [A B]]. + exists rs''; split. + eapply exec_straight_step with (rs2 := rs'); eauto. + simpl. repeat rewrite <- (ireg_val ms sp rs); auto. + auto. + (* Aindexed2shift *) + destruct mk_instr_gen as [mk | ]. + (* binary form available *) + apply H0; auto. simpl. repeat rewrite (ireg_val ms sp rs); auto. + rewrite transl_shift_addr_correct. auto. + (* binary form not available *) + set (rs' := nextinstr (rs#IR14 <- (Val.add (ms t) (eval_shift_total s (ms t0))))). + exploit (H IR14 rs' Int.zero); eauto. + simpl. repeat rewrite (ireg_val ms sp rs); auto. + unfold rs'. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss. + repeat rewrite (ireg_val ms sp rs); auto. apply val_add_add_zero. + unfold rs'; auto with ppcgen. + intros [rs'' [A B]]. + exists rs''; split. + eapply exec_straight_step with (rs2 := rs'); eauto. + simpl. rewrite transl_shift_correct. + repeat rewrite <- (ireg_val ms sp rs); auto. + auto. + (* Ainstack *) + destruct (is_immed i). + (* Ainstack, short displacement *) + apply H. simpl. rewrite (sp_val ms sp rs); auto. auto. + (* Ainstack, large displacement *) + exploit (addimm_correct IR14 IR13); eauto with ppcgen. + intros [rs' [A [B C]]]. + exploit (H IR14 rs' Int.zero); eauto. + simpl. rewrite (sp_val ms sp rs); auto. rewrite B. + rewrite Val.add_assoc. simpl Val.add. rewrite Int.add_zero. reflexivity. + apply agree_exten_2 with rs; auto. + intros [rs'' [D E]]. + exists rs''; split. + eapply exec_straight_trans. eexact A. eexact D. auto. +Qed. + +Lemma transl_load_int_correct: + forall (mk_instr: ireg -> ireg -> shift_addr -> instruction) + (is_immed: int -> bool) + (rd: mreg) addr args k ms sp rs m chunk a v, + (forall (c: code) (r1 r2: ireg) (sa: shift_addr) (rs1: regset), + exec_instr ge c (mk_instr r1 r2 sa) rs1 m = + exec_load chunk (Val.add rs1#r2 (eval_shift_addr sa rs1)) r1 rs1 m) -> + agree ms sp rs -> + map mreg_type args = type_of_addressing addr -> + mreg_type rd = Tint -> + eval_addressing ge sp addr (map ms args) = Some a -> + Mem.loadv chunk m a = Some v -> + exists rs', + exec_straight (transl_load_store_int mk_instr is_immed rd addr args k) rs m + k rs' m + /\ agree (Regmap.set rd v ms) sp rs'. +Proof. + intros. unfold transl_load_store_int. + exploit eval_addressing_weaken. eauto. intros. + apply transl_load_store_correct with ms; auto. + intros. exists (nextinstr (rs1#(ireg_of rd) <- v)); split. + apply exec_straight_one. rewrite H. simpl. rewrite <- H6. rewrite H5. + unfold exec_load. rewrite H4. auto. auto. + auto with ppcgen. + intros. exists (nextinstr (rs1#(ireg_of rd) <- v)); split. + apply exec_straight_one. rewrite H. simpl. rewrite <- H6. rewrite H5. + unfold exec_load. rewrite H4. auto. auto. + auto with ppcgen. +Qed. + +Lemma transl_load_float_correct: + forall (mk_instr: freg -> ireg -> int -> instruction) + (is_immed: int -> bool) + (rd: mreg) addr args k ms sp rs m chunk a v, + (forall (c: code) (r1: freg) (r2: ireg) (n: int) (rs1: regset), + exec_instr ge c (mk_instr r1 r2 n) rs1 m = + exec_load chunk (Val.add rs1#r2 (Vint n)) r1 rs1 m) -> + agree ms sp rs -> + map mreg_type args = type_of_addressing addr -> + mreg_type rd = Tfloat -> + eval_addressing ge sp addr (map ms args) = Some a -> + Mem.loadv chunk m a = Some v -> + exists rs', + exec_straight (transl_load_store_float mk_instr is_immed rd addr args k) rs m + k rs' m + /\ agree (Regmap.set rd v ms) sp rs'. +Proof. + intros. unfold transl_load_store_float. + exploit eval_addressing_weaken. eauto. intros. + apply transl_load_store_correct with ms; auto. + intros. exists (nextinstr (rs1#(freg_of rd) <- v)); split. + apply exec_straight_one. rewrite H. rewrite <- H6. rewrite H5. + unfold exec_load. rewrite H4. auto. auto. + auto with ppcgen. +Qed. + +Lemma transl_store_int_correct: + forall (mk_instr: ireg -> ireg -> shift_addr -> instruction) + (is_immed: int -> bool) + (rd: mreg) addr args k ms sp rs m chunk a m', + (forall (c: code) (r1 r2: ireg) (sa: shift_addr) (rs1: regset), + exec_instr ge c (mk_instr r1 r2 sa) rs1 m = + exec_store chunk (Val.add rs1#r2 (eval_shift_addr sa rs1)) r1 rs1 m) -> + agree ms sp rs -> + map mreg_type args = type_of_addressing addr -> + mreg_type rd = Tint -> + eval_addressing ge sp addr (map ms args) = Some a -> + Mem.storev chunk m a (ms rd) = Some m' -> + exists rs', + exec_straight (transl_load_store_int mk_instr is_immed rd addr args k) rs m + k rs' m' + /\ agree ms sp rs'. +Proof. + intros. unfold transl_load_store_int. + exploit eval_addressing_weaken. eauto. intros. + apply transl_load_store_correct with ms; auto. + intros. exists (nextinstr rs1); split. + apply exec_straight_one. rewrite H. simpl. rewrite <- H6. rewrite H5. + unfold exec_store. rewrite <- (ireg_val ms sp rs1); auto. + rewrite H4. auto. auto. + auto with ppcgen. + intros. exists (nextinstr rs1); split. + apply exec_straight_one. rewrite H. simpl. rewrite <- H6. rewrite H5. + unfold exec_store. rewrite <- (ireg_val ms sp rs1); auto. + rewrite H4. auto. auto. + auto with ppcgen. +Qed. + +Lemma transl_store_float_correct: + forall (mk_instr: freg -> ireg -> int -> instruction) + (is_immed: int -> bool) + (rd: mreg) addr args k ms sp rs m chunk a m', + (forall (c: code) (r1: freg) (r2: ireg) (n: int) (rs1: regset), + exec_instr ge c (mk_instr r1 r2 n) rs1 m = + exec_store chunk (Val.add rs1#r2 (Vint n)) r1 rs1 m) -> + agree ms sp rs -> + map mreg_type args = type_of_addressing addr -> + mreg_type rd = Tfloat -> + eval_addressing ge sp addr (map ms args) = Some a -> + Mem.storev chunk m a (ms rd) = Some m' -> + exists rs', + exec_straight (transl_load_store_float mk_instr is_immed rd addr args k) rs m + k rs' m' + /\ agree ms sp rs'. +Proof. + intros. unfold transl_load_store_float. + exploit eval_addressing_weaken. eauto. intros. + apply transl_load_store_correct with ms; auto. + intros. exists (nextinstr rs1); split. + apply exec_straight_one. rewrite H. simpl. rewrite <- H6. rewrite H5. + unfold exec_store. rewrite <- (freg_val ms sp rs1); auto. + rewrite H4. auto. auto. + auto with ppcgen. +Qed. + +(** Translation of allocations *) + +Lemma transl_alloc_correct: + forall ms sp rs sz m m' blk k, + agree ms sp rs -> + ms Conventions.loc_alloc_argument = Vint sz -> + Mem.alloc m 0 (Int.signed sz) = (m', blk) -> + let ms' := Regmap.set Conventions.loc_alloc_result (Vptr blk Int.zero) ms in + exists rs', + exec_straight (Pallocblock :: k) rs m k rs' m' + /\ agree ms' sp rs'. +Proof. + intros. + pose (rs' := nextinstr (rs#IR0 <- (Vptr blk Int.zero) #IR14 <- (Val.add rs#PC Vone))). + exists rs'; split. + apply exec_straight_one. unfold exec_instr. + generalize (preg_val _ _ _ Conventions.loc_alloc_argument H). + unfold preg_of; intro. simpl in H2. rewrite <- H2. rewrite H0. + rewrite H1. reflexivity. + reflexivity. + unfold ms', rs'. apply agree_nextinstr. apply agree_set_other. + change (IR IR0) with (preg_of Conventions.loc_alloc_result). + apply agree_set_mreg. auto. + simpl. tauto. +Qed. + +End STRAIGHTLINE. + diff --git a/arm/Asmgenretaddr.v b/arm/Asmgenretaddr.v new file mode 100644 index 0000000..72d855a --- /dev/null +++ b/arm/Asmgenretaddr.v @@ -0,0 +1,201 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** 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 Asm. +Require Import Asmgen. + +(** 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 f 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; 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 makeimm_tail: + forall f r1 r2 n k, is_tail k (makeimm f r1 r2 n k). +Proof. unfold makeimm; intros; IsTail. Qed. +Hint Resolve makeimm_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 is_immed addr args k, + is_tail k (transl_load_store mk1 mk2 is_immed addr args k). +Proof. unfold transl_load_store; intros; destruct addr; IsTail. + destruct mk2; IsTail. destruct mk2; IsTail. Qed. +Hint Resolve transl_load_store_tail: ppcretaddr. + +Lemma transl_load_store_int_tail: + forall mk is_immed rd addr args k, + is_tail k (transl_load_store_int mk is_immed rd addr args k). +Proof. unfold transl_load_store_int; intros; IsTail. Qed. +Hint Resolve transl_load_store_int_tail: ppcretaddr. + +Lemma transl_load_store_float_tail: + forall mk is_immed rd addr args k, + is_tail k (transl_load_store_float mk is_immed rd addr args k). +Proof. unfold transl_load_store_float; intros; IsTail. Qed. +Hint Resolve transl_load_store_float_tail: ppcretaddr. + +Lemma loadind_int_tail: + forall base ofs dst k, is_tail k (loadind_int base ofs dst k). +Proof. unfold loadind_int; intros; IsTail. Qed. +Hint Resolve loadind_int_tail: ppcretaddr. + +Lemma loadind_tail: + forall base ofs ty dst k, is_tail k (loadind base ofs ty dst k). +Proof. unfold loadind, loadind_float; intros; IsTail. Qed. +Hint Resolve loadind_tail: ppcretaddr. + +Lemma storeind_int_tail: + forall src base ofs k, is_tail k (storeind_int src base ofs k). +Proof. unfold storeind_int; intros; IsTail. Qed. +Hint Resolve storeind_int_tail: ppcretaddr. + +Lemma storeind_tail: + forall src base ofs ty k, is_tail k (storeind src base ofs ty k). +Proof. unfold storeind, storeind_float; intros; IsTail. Qed. +Hint Resolve storeind_tail: ppcretaddr. + +Lemma transl_instr_tail: + forall f i k, is_tail k (transl_instr f 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 f c1 c2, is_tail c1 c2 -> is_tail (transl_code f c1) (transl_code f 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 f 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/arm/Constprop.v b/arm/Constprop.v new file mode 100644 index 0000000..7369012 --- /dev/null +++ b/arm/Constprop.v @@ -0,0 +1,1254 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Constant propagation over RTL. This is the first of the two + optimizations performed at RTL level. It proceeds by a standard + dataflow analysis and the corresponding code transformation. *) + +Require Import Coqlib. +Require Import Maps. +Require Import AST. +Require Import Integers. +Require Import Floats. +Require Import Values. +Require Import Globalenvs. +Require Import Op. +Require Import Registers. +Require Import RTL. +Require Import Lattice. +Require Import Kildall. + +(** * Static analysis *) + +(** To each pseudo-register at each program point, the static analysis + associates a compile-time approximation taken from the following set. *) + +Inductive approx : Set := + | Novalue: approx (** No value possible, code is unreachable. *) + | Unknown: approx (** All values are possible, + no compile-time information is available. *) + | I: int -> approx (** A known integer value. *) + | F: float -> approx (** A known floating-point value. *) + | S: ident -> int -> approx. + (** The value is the address of the given global + symbol plus the given integer offset. *) + +(** We equip this set of approximations with a semi-lattice structure. + The ordering is inclusion between the sets of values denoted by + the approximations. *) + +Module Approx <: SEMILATTICE_WITH_TOP. + Definition t := approx. + Definition eq (x y: t) := (x = y). + Definition eq_refl: forall x, eq x x := (@refl_equal t). + Definition eq_sym: forall x y, eq x y -> eq y x := (@sym_equal t). + Definition eq_trans: forall x y z, eq x y -> eq y z -> eq x z := (@trans_equal t). + Lemma eq_dec: forall (x y: t), {x=y} + {x<>y}. + Proof. + decide equality. + apply Int.eq_dec. + apply Float.eq_dec. + apply Int.eq_dec. + apply ident_eq. + Qed. + Definition beq (x y: t) := if eq_dec x y then true else false. + Lemma beq_correct: forall x y, beq x y = true -> x = y. + Proof. + unfold beq; intros. destruct (eq_dec x y). auto. congruence. + Qed. + Definition ge (x y: t) : Prop := + x = Unknown \/ y = Novalue \/ x = y. + Lemma ge_refl: forall x y, eq x y -> ge x y. + Proof. + unfold eq, ge; tauto. + Qed. + Lemma ge_trans: forall x y z, ge x y -> ge y z -> ge x z. + Proof. + unfold ge; intuition congruence. + Qed. + Lemma ge_compat: forall x x' y y', eq x x' -> eq y y' -> ge x y -> ge x' y'. + Proof. + unfold eq, ge; intros; congruence. + Qed. + Definition bot := Novalue. + Definition top := Unknown. + Lemma ge_bot: forall x, ge x bot. + Proof. + unfold ge, bot; tauto. + Qed. + Lemma ge_top: forall x, ge top x. + Proof. + unfold ge, bot; tauto. + Qed. + Definition lub (x y: t) : t := + if eq_dec x y then x else + match x, y with + | Novalue, _ => y + | _, Novalue => x + | _, _ => Unknown + end. + Lemma lub_commut: forall x y, eq (lub x y) (lub y x). + Proof. + unfold lub, eq; intros. + case (eq_dec x y); case (eq_dec y x); intros; try congruence. + destruct x; destruct y; auto. + Qed. + Lemma ge_lub_left: forall x y, ge (lub x y) x. + Proof. + unfold lub; intros. + case (eq_dec x y); intro. + apply ge_refl. apply eq_refl. + destruct x; destruct y; unfold ge; tauto. + Qed. +End Approx. + +Module D := LPMap Approx. + +(** We now define the abstract interpretations of conditions and operators + over this set of approximations. For instance, the abstract interpretation + of the operator [Oaddf] applied to two expressions [a] and [b] is + [F(Float.add f g)] if [a] and [b] have static approximations [F f] + and [F g] respectively, and [Unknown] otherwise. + + The static approximations are defined by large pattern-matchings over + the approximations of the results. We write these matchings in the + indirect style described in file [Selection] to avoid excessive + duplication of cases in proofs. *) + +(* +Definition eval_static_condition (cond: condition) (vl: list approx) := + match cond, vl with + | Ccomp c, I n1 :: I n2 :: nil => Some(Int.cmp c n1 n2) + | Ccompu c, I n1 :: I n2 :: nil => Some(Int.cmpu c n1 n2) + | Ccompshift c s, I n1 :: I n2 :: nil => Some(Int.cmp c n1 (eval_shift s n2)) + | Ccompushift c s, I n1 :: I n2 :: nil => Some(Int.cmpu c n1 (eval_shift s n2)) + | Ccompimm c n, I n1 :: nil => Some(Int.cmp c n1 n) + | Ccompuimm c n, I n1 :: nil => Some(Int.cmpu c n1 n) + | Ccompf c, F n1 :: F n2 :: nil => Some(Float.cmp c n1 n2) + | Cnotcompf c, F n1 :: F n2 :: nil => Some(negb(Float.cmp c n1 n2)) + | _, _ => None + end. +*) + +Inductive eval_static_condition_cases: forall (cond: condition) (vl: list approx), Set := + | eval_static_condition_case1: + forall c n1 n2, + eval_static_condition_cases (Ccomp c) (I n1 :: I n2 :: nil) + | eval_static_condition_case2: + forall c n1 n2, + eval_static_condition_cases (Ccompu c) (I n1 :: I n2 :: nil) + | eval_static_condition_case3: + forall c s n1 n2, + eval_static_condition_cases (Ccompshift c s) (I n1 :: I n2 :: nil) + | eval_static_condition_case4: + forall c s n1 n2, + eval_static_condition_cases (Ccompushift c s) (I n1 :: I n2 :: nil) + | eval_static_condition_case5: + forall c n n1, + eval_static_condition_cases (Ccompimm c n) (I n1 :: nil) + | eval_static_condition_case6: + forall c n n1, + eval_static_condition_cases (Ccompuimm c n) (I n1 :: nil) + | eval_static_condition_case7: + forall c n1 n2, + eval_static_condition_cases (Ccompf c) (F n1 :: F n2 :: nil) + | eval_static_condition_case8: + forall c n1 n2, + eval_static_condition_cases (Cnotcompf c) (F n1 :: F n2 :: nil) + | eval_static_condition_default: + forall (cond: condition) (vl: list approx), + eval_static_condition_cases cond vl. + +Definition eval_static_condition_match (cond: condition) (vl: list approx) := + match cond as z1, vl as z2 return eval_static_condition_cases z1 z2 with + | Ccomp c, I n1 :: I n2 :: nil => + eval_static_condition_case1 c n1 n2 + | Ccompu c, I n1 :: I n2 :: nil => + eval_static_condition_case2 c n1 n2 + | Ccompshift c s, I n1 :: I n2 :: nil => + eval_static_condition_case3 c s n1 n2 + | Ccompushift c s, I n1 :: I n2 :: nil => + eval_static_condition_case4 c s n1 n2 + | Ccompimm c n, I n1 :: nil => + eval_static_condition_case5 c n n1 + | Ccompuimm c n, I n1 :: nil => + eval_static_condition_case6 c n n1 + | Ccompf c, F n1 :: F n2 :: nil => + eval_static_condition_case7 c n1 n2 + | Cnotcompf c, F n1 :: F n2 :: nil => + eval_static_condition_case8 c n1 n2 + | cond, vl => + eval_static_condition_default cond vl + end. + +Definition eval_static_condition (cond: condition) (vl: list approx) := + match eval_static_condition_match cond vl with + | eval_static_condition_case1 c n1 n2 => + Some(Int.cmp c n1 n2) + | eval_static_condition_case2 c n1 n2 => + Some(Int.cmpu c n1 n2) + | eval_static_condition_case3 c s n1 n2 => + Some(Int.cmp c n1 (eval_shift s n2)) + | eval_static_condition_case4 c s n1 n2 => + Some(Int.cmpu c n1 (eval_shift s n2)) + | eval_static_condition_case5 c n n1 => + Some(Int.cmp c n1 n) + | eval_static_condition_case6 c n n1 => + Some(Int.cmpu c n1 n) + | eval_static_condition_case7 c n1 n2 => + Some(Float.cmp c n1 n2) + | eval_static_condition_case8 c n1 n2 => + Some(negb(Float.cmp c n1 n2)) + | eval_static_condition_default cond vl => + None + end. + +(* +Definition eval_static_operation (op: operation) (vl: list approx) := + match op, vl with + | Omove, v1::nil => v1 + | Ointconst n, nil => I n + | Ofloatconst n, nil => F n + | Oaddrsymbol s n, nil => S s n + | Ocast8signed, I n1 :: nil => I(Int.sign_ext 8 n) + | Ocast8unsigned, I n1 :: nil => I(Int.zero_ext 8 n) + | Ocast16signed, I n1 :: nil => I(Int.sign_ext 16 n) + | Ocast16unsigned, I n1 :: nil => I(Int.zero_ext 16 n) + | Oadd, I n1 :: I n2 :: nil => I(Int.add n1 n2) + | Oaddshift s, I n1 :: I n2 :: nil => I(Int.add n1 (eval_shift s n2)) + | Oadd, S s1 n1 :: I n2 :: nil => S s1 (Int.add n1 n2) + | Oaddshift s, S s1 n1 :: I n2 :: nil => S s1 (Int.add n1 (eval_shift s n2)) + | Oaddimm n, I n1 :: nil => I (Int.add n1 n) + | Oaddimm n, S s1 n1 :: nil => S s1 (Int.add n1 n) + | Osub, I n1 :: I n2 :: nil => I(Int.sub n1 n2) + | Osubshift s, I n1 :: I n2 :: nil => I(Int.sub n1 (eval_shift s n2)) + | Osub, S s1 n1 :: I n2 :: nil => S s1 (Int.sub n1 n2) + | Osubshift s, S s1 n1 :: I n2 :: nil => S s1 (Int.sub n1 (eval_shift s n2)) + | Orsubshift s, I n1 :: I n2 :: nil => I(Int.sub (eval_shift s n2) n1) + | Orsubimm n, I n1 :: nil => I (Int.sub n n1) + | Omul, I n1 :: I n2 :: nil => I(Int.mul n1 n2) + | Odiv, I n1 :: I n2 :: nil => if Int.eq n2 Int.zero then Unknown else I(Int.divs n1 n2) + | Odivu, I n1 :: I n2 :: nil => if Int.eq n2 Int.zero then Unknown else I(Int.divu n1 n2) + | Oand, I n1 :: I n2 :: nil => I(Int.and n1 n2) + | Oandshift s, I n1 :: I n2 :: nil => I(Int.and n1 (eval_shift s n2)) + | Oandimm n, I n1 :: nil => I(Int.and n1 n) + | Oor, I n1 :: I n2 :: nil => I(Int.or n1 n2) + | Oorshift s, I n1 :: I n2 :: nil => I(Int.or n1 (eval_shift s n2)) + | Oorimm n, I n1 :: nil => I(Int.or n1 n) + | Oxor, I n1 :: I n2 :: nil => I(Int.xor n1 n2) + | Oxorshift s, I n1 :: I n2 :: nil => I(Int.xor n1 (eval_shift s n2)) + | Oxorimm n, I n1 :: nil => I(Int.xor n1 n) + | Obic, I n1 :: I n2 :: nil => I(Int.and n1 (Int.not n2)) + | Obicshift s, I n1 :: I n2 :: nil => I(Int.and n1 (Int.not (eval_shift s n2))) + | Onot, I n1 :: nil => I(Int.not n1) + | Onotshift s, I n1 :: nil => I(Int.not (eval_shift s n1)) + | Oshl, I n1 :: I n2 :: nil => if Int.ltu n2 (Int.repr 32) then I(Int.shl n1 n2) else Unknown + | Oshr, I n1 :: I n2 :: nil => if Int.ltu n2 (Int.repr 32) then I(Int.shr n1 n2) else Unknown + | Oshru, I n1 :: I n2 :: nil => if Int.ltu n2 (Int.repr 32) then I(Int.shru n1 n2) else Unknown + | Oshift s, I n1 :: nil => I(eval_shift s n1) + | Onegf, F n1 :: nil => F(Float.neg n1) + | Oabsf, F n1 :: nil => F(Float.abs n1) + | Oaddf, F n1 :: F n2 :: nil => F(Float.add n1 n2) + | Osubf, F n1 :: F n2 :: nil => F(Float.sub n1 n2) + | Omulf, F n1 :: F n2 :: nil => F(Float.mul n1 n2) + | Odivf, F n1 :: F n2 :: nil => F(Float.div n1 n2) + | Osingleoffloat, F n1 :: nil => F(Float.singleoffloat n1) + | Ointoffloat, F n1 :: nil => I(Float.intoffloat n1) + | Ofloatofint, I n1 :: nil => F(Float.floatofint n1) + | Ofloatofintu, I n1 :: nil => F(Float.floatofintu n1) + | Ocmp c, vl => + match eval_static_condition c vl with + | None => Unknown + | Some b => I(if b then Int.one else Int.zero) + end + | _, _ => Unknown + end. +*) + +Inductive eval_static_operation_cases: forall (op: operation) (vl: list approx), Set := + | eval_static_operation_case1: + forall v1, + eval_static_operation_cases (Omove) (v1::nil) + | eval_static_operation_case2: + forall n, + eval_static_operation_cases (Ointconst n) (nil) + | eval_static_operation_case3: + forall n, + eval_static_operation_cases (Ofloatconst n) (nil) + | eval_static_operation_case4: + forall s n, + eval_static_operation_cases (Oaddrsymbol s n) (nil) + | eval_static_operation_case5: + forall n1, + eval_static_operation_cases (Ocast8signed) (I n1 :: nil) + | eval_static_operation_case6: + forall n1, + eval_static_operation_cases (Ocast8unsigned) (I n1 :: nil) + | eval_static_operation_case7: + forall n1, + eval_static_operation_cases (Ocast16signed) (I n1 :: nil) + | eval_static_operation_case8: + forall n1, + eval_static_operation_cases (Ocast16unsigned) (I n1 :: nil) + | eval_static_operation_case9: + forall n1 n2, + eval_static_operation_cases (Oadd) (I n1 :: I n2 :: nil) + | eval_static_operation_case10: + forall s n1 n2, + eval_static_operation_cases (Oaddshift s) (I n1 :: I n2 :: nil) + | eval_static_operation_case11: + forall s1 n1 n2, + eval_static_operation_cases (Oadd) (S s1 n1 :: I n2 :: nil) + | eval_static_operation_case12: + forall s s1 n1 n2, + eval_static_operation_cases (Oaddshift s) (S s1 n1 :: I n2 :: nil) + | eval_static_operation_case13: + forall n n1, + eval_static_operation_cases (Oaddimm n) (I n1 :: nil) + | eval_static_operation_case14: + forall n s1 n1, + eval_static_operation_cases (Oaddimm n) (S s1 n1 :: nil) + | eval_static_operation_case15: + forall n1 n2, + eval_static_operation_cases (Osub) (I n1 :: I n2 :: nil) + | eval_static_operation_case16: + forall s n1 n2, + eval_static_operation_cases (Osubshift s) (I n1 :: I n2 :: nil) + | eval_static_operation_case17: + forall s1 n1 n2, + eval_static_operation_cases (Osub) (S s1 n1 :: I n2 :: nil) + | eval_static_operation_case18: + forall s s1 n1 n2, + eval_static_operation_cases (Osubshift s) (S s1 n1 :: I n2 :: nil) + | eval_static_operation_case19: + forall s n1 n2, + eval_static_operation_cases (Orsubshift s) (I n1 :: I n2 :: nil) + | eval_static_operation_case20: + forall n n1, + eval_static_operation_cases (Orsubimm n) (I n1 :: nil) + | eval_static_operation_case21: + forall n1 n2, + eval_static_operation_cases (Omul) (I n1 :: I n2 :: nil) + | eval_static_operation_case22: + forall n1 n2, + eval_static_operation_cases (Odiv) (I n1 :: I n2 :: nil) + | eval_static_operation_case23: + forall n1 n2, + eval_static_operation_cases (Odivu) (I n1 :: I n2 :: nil) + | eval_static_operation_case24: + forall n1 n2, + eval_static_operation_cases (Oand) (I n1 :: I n2 :: nil) + | eval_static_operation_case25: + forall s n1 n2, + eval_static_operation_cases (Oandshift s) (I n1 :: I n2 :: nil) + | eval_static_operation_case26: + forall n n1, + eval_static_operation_cases (Oandimm n) (I n1 :: nil) + | eval_static_operation_case27: + forall n1 n2, + eval_static_operation_cases (Oor) (I n1 :: I n2 :: nil) + | eval_static_operation_case28: + forall s n1 n2, + eval_static_operation_cases (Oorshift s) (I n1 :: I n2 :: nil) + | eval_static_operation_case29: + forall n n1, + eval_static_operation_cases (Oorimm n) (I n1 :: nil) + | eval_static_operation_case30: + forall n1 n2, + eval_static_operation_cases (Oxor) (I n1 :: I n2 :: nil) + | eval_static_operation_case31: + forall s n1 n2, + eval_static_operation_cases (Oxorshift s) (I n1 :: I n2 :: nil) + | eval_static_operation_case32: + forall n n1, + eval_static_operation_cases (Oxorimm n) (I n1 :: nil) + | eval_static_operation_case33: + forall n1 n2, + eval_static_operation_cases (Obic) (I n1 :: I n2 :: nil) + | eval_static_operation_case34: + forall s n1 n2, + eval_static_operation_cases (Obicshift s) (I n1 :: I n2 :: nil) + | eval_static_operation_case35: + forall n1, + eval_static_operation_cases (Onot) (I n1 :: nil) + | eval_static_operation_case36: + forall s n1, + eval_static_operation_cases (Onotshift s) (I n1 :: nil) + | eval_static_operation_case37: + forall n1 n2, + eval_static_operation_cases (Oshl) (I n1 :: I n2 :: nil) + | eval_static_operation_case38: + forall n1 n2, + eval_static_operation_cases (Oshr) (I n1 :: I n2 :: nil) + | eval_static_operation_case39: + forall n1 n2, + eval_static_operation_cases (Oshru) (I n1 :: I n2 :: nil) + | eval_static_operation_case40: + forall s n1, + eval_static_operation_cases (Oshift s) (I n1 :: nil) + | eval_static_operation_case41: + forall n1, + eval_static_operation_cases (Onegf) (F n1 :: nil) + | eval_static_operation_case42: + forall n1, + eval_static_operation_cases (Oabsf) (F n1 :: nil) + | eval_static_operation_case43: + forall n1 n2, + eval_static_operation_cases (Oaddf) (F n1 :: F n2 :: nil) + | eval_static_operation_case44: + forall n1 n2, + eval_static_operation_cases (Osubf) (F n1 :: F n2 :: nil) + | eval_static_operation_case45: + forall n1 n2, + eval_static_operation_cases (Omulf) (F n1 :: F n2 :: nil) + | eval_static_operation_case46: + forall n1 n2, + eval_static_operation_cases (Odivf) (F n1 :: F n2 :: nil) + | eval_static_operation_case47: + forall n1, + eval_static_operation_cases (Osingleoffloat) (F n1 :: nil) + | eval_static_operation_case48: + forall n1, + eval_static_operation_cases (Ointoffloat) (F n1 :: nil) + | eval_static_operation_case49: + forall n1, + eval_static_operation_cases (Ofloatofint) (I n1 :: nil) + | eval_static_operation_case50: + forall n1, + eval_static_operation_cases (Ofloatofintu) (I n1 :: nil) + | eval_static_operation_case51: + forall c vl, + eval_static_operation_cases (Ocmp c) (vl) + | eval_static_operation_case52: + forall n n1, + eval_static_operation_cases (Oshrximm n) (I n1 :: nil) + | eval_static_operation_default: + forall (op: operation) (vl: list approx), + eval_static_operation_cases op vl. + +Definition eval_static_operation_match (op: operation) (vl: list approx) := + match op as z1, vl as z2 return eval_static_operation_cases z1 z2 with + | Omove, v1::nil => + eval_static_operation_case1 v1 + | Ointconst n, nil => + eval_static_operation_case2 n + | Ofloatconst n, nil => + eval_static_operation_case3 n + | Oaddrsymbol s n, nil => + eval_static_operation_case4 s n + | Ocast8signed, I n1 :: nil => + eval_static_operation_case5 n1 + | Ocast8unsigned, I n1 :: nil => + eval_static_operation_case6 n1 + | Ocast16signed, I n1 :: nil => + eval_static_operation_case7 n1 + | Ocast16unsigned, I n1 :: nil => + eval_static_operation_case8 n1 + | Oadd, I n1 :: I n2 :: nil => + eval_static_operation_case9 n1 n2 + | Oaddshift s, I n1 :: I n2 :: nil => + eval_static_operation_case10 s n1 n2 + | Oadd, S s1 n1 :: I n2 :: nil => + eval_static_operation_case11 s1 n1 n2 + | Oaddshift s, S s1 n1 :: I n2 :: nil => + eval_static_operation_case12 s s1 n1 n2 + | Oaddimm n, I n1 :: nil => + eval_static_operation_case13 n n1 + | Oaddimm n, S s1 n1 :: nil => + eval_static_operation_case14 n s1 n1 + | Osub, I n1 :: I n2 :: nil => + eval_static_operation_case15 n1 n2 + | Osubshift s, I n1 :: I n2 :: nil => + eval_static_operation_case16 s n1 n2 + | Osub, S s1 n1 :: I n2 :: nil => + eval_static_operation_case17 s1 n1 n2 + | Osubshift s, S s1 n1 :: I n2 :: nil => + eval_static_operation_case18 s s1 n1 n2 + | Orsubshift s, I n1 :: I n2 :: nil => + eval_static_operation_case19 s n1 n2 + | Orsubimm n, I n1 :: nil => + eval_static_operation_case20 n n1 + | Omul, I n1 :: I n2 :: nil => + eval_static_operation_case21 n1 n2 + | Odiv, I n1 :: I n2 :: nil => + eval_static_operation_case22 n1 n2 + | Odivu, I n1 :: I n2 :: nil => + eval_static_operation_case23 n1 n2 + | Oand, I n1 :: I n2 :: nil => + eval_static_operation_case24 n1 n2 + | Oandshift s, I n1 :: I n2 :: nil => + eval_static_operation_case25 s n1 n2 + | Oandimm n, I n1 :: nil => + eval_static_operation_case26 n n1 + | Oor, I n1 :: I n2 :: nil => + eval_static_operation_case27 n1 n2 + | Oorshift s, I n1 :: I n2 :: nil => + eval_static_operation_case28 s n1 n2 + | Oorimm n, I n1 :: nil => + eval_static_operation_case29 n n1 + | Oxor, I n1 :: I n2 :: nil => + eval_static_operation_case30 n1 n2 + | Oxorshift s, I n1 :: I n2 :: nil => + eval_static_operation_case31 s n1 n2 + | Oxorimm n, I n1 :: nil => + eval_static_operation_case32 n n1 + | Obic, I n1 :: I n2 :: nil => + eval_static_operation_case33 n1 n2 + | Obicshift s, I n1 :: I n2 :: nil => + eval_static_operation_case34 s n1 n2 + | Onot, I n1 :: nil => + eval_static_operation_case35 n1 + | Onotshift s, I n1 :: nil => + eval_static_operation_case36 s n1 + | Oshl, I n1 :: I n2 :: nil => + eval_static_operation_case37 n1 n2 + | Oshr, I n1 :: I n2 :: nil => + eval_static_operation_case38 n1 n2 + | Oshru, I n1 :: I n2 :: nil => + eval_static_operation_case39 n1 n2 + | Oshift s, I n1 :: nil => + eval_static_operation_case40 s n1 + | Onegf, F n1 :: nil => + eval_static_operation_case41 n1 + | Oabsf, F n1 :: nil => + eval_static_operation_case42 n1 + | Oaddf, F n1 :: F n2 :: nil => + eval_static_operation_case43 n1 n2 + | Osubf, F n1 :: F n2 :: nil => + eval_static_operation_case44 n1 n2 + | Omulf, F n1 :: F n2 :: nil => + eval_static_operation_case45 n1 n2 + | Odivf, F n1 :: F n2 :: nil => + eval_static_operation_case46 n1 n2 + | Osingleoffloat, F n1 :: nil => + eval_static_operation_case47 n1 + | Ointoffloat, F n1 :: nil => + eval_static_operation_case48 n1 + | Ofloatofint, I n1 :: nil => + eval_static_operation_case49 n1 + | Ofloatofintu, I n1 :: nil => + eval_static_operation_case50 n1 + | Ocmp c, vl => + eval_static_operation_case51 c vl + | Oshrximm n, I n1 :: nil => + eval_static_operation_case52 n n1 + | op, vl => + eval_static_operation_default op vl + end. + +Definition eval_static_operation (op: operation) (vl: list approx) := + match eval_static_operation_match op vl with + | eval_static_operation_case1 v1 => + v1 + | eval_static_operation_case2 n => + I n + | eval_static_operation_case3 n => + F n + | eval_static_operation_case4 s n => + S s n + | eval_static_operation_case5 n => + I(Int.sign_ext 8 n) + | eval_static_operation_case6 n => + I(Int.zero_ext 8 n) + | eval_static_operation_case7 n => + I(Int.sign_ext 16 n) + | eval_static_operation_case8 n => + I(Int.zero_ext 16 n) + | eval_static_operation_case9 n1 n2 => + I(Int.add n1 n2) + | eval_static_operation_case10 s n1 n2 => + I(Int.add n1 (eval_shift s n2)) + | eval_static_operation_case11 s1 n1 n2 => + S s1 (Int.add n1 n2) + | eval_static_operation_case12 s s1 n1 n2 => + S s1 (Int.add n1 (eval_shift s n2)) + | eval_static_operation_case13 n n1 => + I (Int.add n1 n) + | eval_static_operation_case14 n s1 n1 => + S s1 (Int.add n1 n) + | eval_static_operation_case15 n1 n2 => + I(Int.sub n1 n2) + | eval_static_operation_case16 s n1 n2 => + I(Int.sub n1 (eval_shift s n2)) + | eval_static_operation_case17 s1 n1 n2 => + S s1 (Int.sub n1 n2) + | eval_static_operation_case18 s s1 n1 n2 => + S s1 (Int.sub n1 (eval_shift s n2)) + | eval_static_operation_case19 s n1 n2 => + I(Int.sub (eval_shift s n2) n1) + | eval_static_operation_case20 n n1 => + I (Int.sub n n1) + | eval_static_operation_case21 n1 n2 => + I(Int.mul n1 n2) + | eval_static_operation_case22 n1 n2 => + if Int.eq n2 Int.zero then Unknown else I(Int.divs n1 n2) + | eval_static_operation_case23 n1 n2 => + if Int.eq n2 Int.zero then Unknown else I(Int.divu n1 n2) + | eval_static_operation_case24 n1 n2 => + I(Int.and n1 n2) + | eval_static_operation_case25 s n1 n2 => + I(Int.and n1 (eval_shift s n2)) + | eval_static_operation_case26 n n1 => + I(Int.and n1 n) + | eval_static_operation_case27 n1 n2 => + I(Int.or n1 n2) + | eval_static_operation_case28 s n1 n2 => + I(Int.or n1 (eval_shift s n2)) + | eval_static_operation_case29 n n1 => + I(Int.or n1 n) + | eval_static_operation_case30 n1 n2 => + I(Int.xor n1 n2) + | eval_static_operation_case31 s n1 n2 => + I(Int.xor n1 (eval_shift s n2)) + | eval_static_operation_case32 n n1 => + I(Int.xor n1 n) + | eval_static_operation_case33 n1 n2 => + I(Int.and n1 (Int.not n2)) + | eval_static_operation_case34 s n1 n2 => + I(Int.and n1 (Int.not (eval_shift s n2))) + | eval_static_operation_case35 n1 => + I(Int.not n1) + | eval_static_operation_case36 s n1 => + I(Int.not (eval_shift s n1)) + | eval_static_operation_case37 n1 n2 => + if Int.ltu n2 (Int.repr 32) then I(Int.shl n1 n2) else Unknown + | eval_static_operation_case38 n1 n2 => + if Int.ltu n2 (Int.repr 32) then I(Int.shr n1 n2) else Unknown + | eval_static_operation_case39 n1 n2 => + if Int.ltu n2 (Int.repr 32) then I(Int.shru n1 n2) else Unknown + | eval_static_operation_case40 s n1 => + I(eval_shift s n1) + | eval_static_operation_case41 n1 => + F(Float.neg n1) + | eval_static_operation_case42 n1 => + F(Float.abs n1) + | eval_static_operation_case43 n1 n2 => + F(Float.add n1 n2) + | eval_static_operation_case44 n1 n2 => + F(Float.sub n1 n2) + | eval_static_operation_case45 n1 n2 => + F(Float.mul n1 n2) + | eval_static_operation_case46 n1 n2 => + F(Float.div n1 n2) + | eval_static_operation_case47 n1 => + F(Float.singleoffloat n1) + | eval_static_operation_case48 n1 => + I(Float.intoffloat n1) + | eval_static_operation_case49 n1 => + F(Float.floatofint n1) + | eval_static_operation_case50 n1 => + F(Float.floatofintu n1) + | eval_static_operation_case51 c vl => + match eval_static_condition c vl with + | None => Unknown + | Some b => I(if b then Int.one else Int.zero) + end + | eval_static_operation_case52 n n1 => + if Int.ltu n (Int.repr 31) then I(Int.shrx n1 n) else Unknown + | eval_static_operation_default op vl => + Unknown + end. + + +(** The transfer function for the dataflow analysis is straightforward: + for [Iop] instructions, we set the approximation of the destination + register to the result of executing abstractly the operation; + for [Iload] and [Icall], we set the approximation of the destination + to [Unknown]. *) + +Definition approx_regs (rl: list reg) (approx: D.t) := + List.map (fun r => D.get r approx) rl. + +Definition transfer (f: function) (pc: node) (before: D.t) := + match f.(fn_code)!pc with + | None => before + | Some i => + match i with + | Inop s => + before + | Iop op args res s => + let a := eval_static_operation op (approx_regs args before) in + D.set res a before + | Iload chunk addr args dst s => + D.set dst Unknown before + | Istore chunk addr args src s => + 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 => + before + | Ireturn optarg => + before + end + end. + +(** The static analysis itself is then an instantiation of Kildall's + generic solver for forward dataflow inequations. [analyze f] + returns a mapping from program points to mappings of pseudo-registers + to approximations. It can fail to reach a fixpoint in a reasonable + number of iterations, in which case [None] is returned. *) + +Module DS := Dataflow_Solver(D)(NodeSetForward). + +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 *) + +(** ** Operator strength reduction *) + +(** We now define auxiliary functions for strength reduction of + operators and addressing modes: replacing an operator with a cheaper + one if some of its arguments are statically known. These are again + large pattern-matchings expressed in indirect style. *) + +Section STRENGTH_REDUCTION. + +Variable approx: D.t. + +Definition intval (r: reg) : option int := + match D.get r approx with I n => Some n | _ => None end. + +(* +Definition cond_strength_reduction (cond: condition) (args: list reg) := + match cond, args with + | Ccomp c, r1 :: r2 :: nil => + | Ccompu c, r1 :: r2 :: nil => + | Ccompshift c s, r1 :: r2 :: nil => + | Ccompushift c s, r1 :: r2 :: nil => + | _ => + end. +*) + +Inductive cond_strength_reduction_cases: forall (cond: condition) (args: list reg), Set := + | cond_strength_reduction_case1: + forall c r1 r2, + cond_strength_reduction_cases (Ccomp c) (r1 :: r2 :: nil) + | cond_strength_reduction_case2: + forall c r1 r2, + cond_strength_reduction_cases (Ccompu c) (r1 :: r2 :: nil) + | cond_strength_reduction_case3: + forall c s r1 r2, + cond_strength_reduction_cases (Ccompshift c s) (r1 :: r2 :: nil) + | cond_strength_reduction_case4: + forall c s r1 r2, + cond_strength_reduction_cases (Ccompushift c s) (r1 :: r2 :: nil) + | cond_strength_reduction_default: + forall (cond: condition) (args: list reg), + cond_strength_reduction_cases cond args. + +Definition cond_strength_reduction_match (cond: condition) (args: list reg) := + match cond as z1, args as z2 return cond_strength_reduction_cases z1 z2 with + | Ccomp c, r1 :: r2 :: nil => + cond_strength_reduction_case1 c r1 r2 + | Ccompu c, r1 :: r2 :: nil => + cond_strength_reduction_case2 c r1 r2 + | Ccompshift c s, r1 :: r2 :: nil => + cond_strength_reduction_case3 c s r1 r2 + | Ccompushift c s, r1 :: r2 :: nil => + cond_strength_reduction_case4 c s r1 r2 + | cond, args => + cond_strength_reduction_default cond args + end. + +Definition cond_strength_reduction (cond: condition) (args: list reg) := + match cond_strength_reduction_match cond args with + | cond_strength_reduction_case1 c r1 r2 => + match intval r1, intval r2 with + | Some n, _ => + (Ccompimm (swap_comparison c) n, r2 :: nil) + | _, Some n => + (Ccompimm c n, r1 :: nil) + | _, _ => + (cond, args) + end + | cond_strength_reduction_case2 c r1 r2 => + match intval r1, intval r2 with + | Some n, _ => + (Ccompuimm (swap_comparison c) n, r2 :: nil) + | _, Some n => + (Ccompuimm c n, r1 :: nil) + | _, _ => + (cond, args) + end + | cond_strength_reduction_case3 c s r1 r2 => + match intval r2 with + | Some n => + (Ccompimm c (eval_shift s n), r1 :: nil) + | None => + (cond, args) + end + | cond_strength_reduction_case4 c s r1 r2 => + match intval r2 with + | Some n => + (Ccompuimm c (eval_shift s n), r1 :: nil) + | None => + (cond, args) + end + | cond_strength_reduction_default cond args => + (cond, args) + end. + +Definition make_addimm (n: int) (r: reg) := + if Int.eq n Int.zero + then (Omove, r :: nil) + else (Oaddimm n, r :: nil). + +Definition make_shlimm (n: int) (r: reg) := + if Int.eq n Int.zero then + (Omove, r :: nil) + else match is_shift_amount n with + | Some n' => (Oshift (Slsl n'), r :: nil) + | None => (Ointconst Int.zero, nil) (* never happens *) + end. + +Definition make_shrimm (n: int) (r: reg) := + if Int.eq n Int.zero then + (Omove, r :: nil) + else match is_shift_amount n with + | Some n' => (Oshift (Sasr n'), r :: nil) + | None => (Ointconst Int.zero, nil) (* never happens *) + end. + +Definition make_shruimm (n: int) (r: reg) := + if Int.eq n Int.zero then + (Omove, r :: nil) + else match is_shift_amount n with + | Some n' => (Oshift (Slsr n'), r :: nil) + | None => (Ointconst Int.zero, nil) (* never happens *) + end. + +Definition make_mulimm (n: int) (r: reg) (r': reg) := + if Int.eq n Int.zero then + (Ointconst Int.zero, nil) + else if Int.eq n Int.one then + (Omove, r :: nil) + else + match Int.is_power2 n with + | Some l => make_shlimm l r + | None => (Omul, r :: r' :: nil) + end. + +Definition make_andimm (n: int) (r: reg) := + if Int.eq n Int.zero + then (Ointconst Int.zero, nil) + else if Int.eq n Int.mone then (Omove, r :: nil) + else (Oandimm n, r :: nil). + +Definition make_orimm (n: int) (r: reg) := + if Int.eq n Int.zero then (Omove, r :: nil) + else if Int.eq n Int.mone then (Ointconst Int.mone, nil) + else (Oorimm n, r :: nil). + +Definition make_xorimm (n: int) (r: reg) := + if Int.eq n Int.zero then (Omove, r :: nil) + else if Int.eq n Int.mone then (Onot, r :: nil) + else (Oxorimm n, r :: nil). + +(* +Definition op_strength_reduction (op: operation) (args: list reg) := + match op, args with + | Oadd, r1 :: r2 :: nil => + | Oaddshift s, r1 :: r2 :: nil => + | Osub, r1 :: r2 :: nil => + | Osubshift s, r1 :: r2 :: nil => + | Orsubshift s, r1 :: r2 :: nil => + | Omul, r1 :: r2 :: nil => + | Odivu, r1 :: r2 :: nil => + | Oand, r1 :: r2 :: nil => + | Oandshift s, r1 :: r2 :: nil => + | Oor, r1 :: r2 :: nil => + | Oorshift s, r1 :: r2 :: nil => + | Oxor, r1 :: r2 :: nil => + | Oxorshift s, r1 :: r2 :: nil => + | Obic, r1 :: r2 :: nil => + | Obicshift s, r1 :: r2 :: nil => + | Oshl, r1 :: r2 :: nil => + | Oshr, r1 :: r2 :: nil => + | Oshru, r1 :: r2 :: nil => + | Ocmp c, rl => + | _, _ => + end. +*) + +Inductive op_strength_reduction_cases: forall (op: operation) (args: list reg), Set := + | op_strength_reduction_case1: + forall r1 r2, + op_strength_reduction_cases (Oadd) (r1 :: r2 :: nil) + | op_strength_reduction_case2: + forall s r1 r2, + op_strength_reduction_cases (Oaddshift s) (r1 :: r2 :: nil) + | op_strength_reduction_case3: + forall r1 r2, + op_strength_reduction_cases (Osub) (r1 :: r2 :: nil) + | op_strength_reduction_case4: + forall s r1 r2, + op_strength_reduction_cases (Osubshift s) (r1 :: r2 :: nil) + | op_strength_reduction_case5: + forall s r1 r2, + op_strength_reduction_cases (Orsubshift s) (r1 :: r2 :: nil) + | op_strength_reduction_case6: + forall r1 r2, + op_strength_reduction_cases (Omul) (r1 :: r2 :: nil) + | op_strength_reduction_case7: + forall r1 r2, + op_strength_reduction_cases (Odivu) (r1 :: r2 :: nil) + | op_strength_reduction_case8: + forall r1 r2, + op_strength_reduction_cases (Oand) (r1 :: r2 :: nil) + | op_strength_reduction_case9: + forall s r1 r2, + op_strength_reduction_cases (Oandshift s) (r1 :: r2 :: nil) + | op_strength_reduction_case10: + forall r1 r2, + op_strength_reduction_cases (Oor) (r1 :: r2 :: nil) + | op_strength_reduction_case11: + forall s r1 r2, + op_strength_reduction_cases (Oorshift s) (r1 :: r2 :: nil) + | op_strength_reduction_case12: + forall r1 r2, + op_strength_reduction_cases (Oxor) (r1 :: r2 :: nil) + | op_strength_reduction_case13: + forall s r1 r2, + op_strength_reduction_cases (Oxorshift s) (r1 :: r2 :: nil) + | op_strength_reduction_case14: + forall r1 r2, + op_strength_reduction_cases (Obic) (r1 :: r2 :: nil) + | op_strength_reduction_case15: + forall s r1 r2, + op_strength_reduction_cases (Obicshift s) (r1 :: r2 :: nil) + | op_strength_reduction_case16: + forall r1 r2, + op_strength_reduction_cases (Oshl) (r1 :: r2 :: nil) + | op_strength_reduction_case17: + forall r1 r2, + op_strength_reduction_cases (Oshr) (r1 :: r2 :: nil) + | op_strength_reduction_case18: + forall r1 r2, + op_strength_reduction_cases (Oshru) (r1 :: r2 :: nil) + | op_strength_reduction_case19: + forall c rl, + op_strength_reduction_cases (Ocmp c) rl + | op_strength_reduction_default: + forall (op: operation) (args: list reg), + op_strength_reduction_cases op args. + +Definition op_strength_reduction_match (op: operation) (args: list reg) := + match op as z1, args as z2 return op_strength_reduction_cases z1 z2 with + | Oadd, r1 :: r2 :: nil => + op_strength_reduction_case1 r1 r2 + | Oaddshift s, r1 :: r2 :: nil => + op_strength_reduction_case2 s r1 r2 + | Osub, r1 :: r2 :: nil => + op_strength_reduction_case3 r1 r2 + | Osubshift s, r1 :: r2 :: nil => + op_strength_reduction_case4 s r1 r2 + | Orsubshift s, r1 :: r2 :: nil => + op_strength_reduction_case5 s r1 r2 + | Omul, r1 :: r2 :: nil => + op_strength_reduction_case6 r1 r2 + | Odivu, r1 :: r2 :: nil => + op_strength_reduction_case7 r1 r2 + | Oand, r1 :: r2 :: nil => + op_strength_reduction_case8 r1 r2 + | Oandshift s, r1 :: r2 :: nil => + op_strength_reduction_case9 s r1 r2 + | Oor, r1 :: r2 :: nil => + op_strength_reduction_case10 r1 r2 + | Oorshift s, r1 :: r2 :: nil => + op_strength_reduction_case11 s r1 r2 + | Oxor, r1 :: r2 :: nil => + op_strength_reduction_case12 r1 r2 + | Oxorshift s, r1 :: r2 :: nil => + op_strength_reduction_case13 s r1 r2 + | Obic, r1 :: r2 :: nil => + op_strength_reduction_case14 r1 r2 + | Obicshift s, r1 :: r2 :: nil => + op_strength_reduction_case15 s r1 r2 + | Oshl, r1 :: r2 :: nil => + op_strength_reduction_case16 r1 r2 + | Oshr, r1 :: r2 :: nil => + op_strength_reduction_case17 r1 r2 + | Oshru, r1 :: r2 :: nil => + op_strength_reduction_case18 r1 r2 + | Ocmp c, rl => + op_strength_reduction_case19 c rl + | op, args => + op_strength_reduction_default op args + end. + +Definition op_strength_reduction (op: operation) (args: list reg) := + match op_strength_reduction_match op args with + | op_strength_reduction_case1 r1 r2 => (* Oadd *) + match intval r1, intval r2 with + | Some n, _ => make_addimm n r2 + | _, Some n => make_addimm n r1 + | _, _ => (op, args) + end + | op_strength_reduction_case2 s r1 r2 => (* Oaddshift *) + match intval r2 with + | Some n => make_addimm (eval_shift s n) r1 + | _ => (op, args) + end + | op_strength_reduction_case3 r1 r2 => (* Osub *) + match intval r1, intval r2 with + | Some n, _ => (Orsubimm n, r2 :: nil) + | _, Some n => make_addimm (Int.neg n) r1 + | _, _ => (op, args) + end + | op_strength_reduction_case4 s r1 r2 => (* Osubshift *) + match intval r2 with + | Some n => make_addimm (Int.neg (eval_shift s n)) r1 + | _ => (op, args) + end + | op_strength_reduction_case5 s r1 r2 => (* Orsubshift *) + match intval r2 with + | Some n => (Orsubimm (eval_shift s n), r1 :: nil) + | _ => (op, args) + end + | op_strength_reduction_case6 r1 r2 => (* Omul *) + match intval r1, intval r2 with + | Some n, _ => make_mulimm n r2 r1 + | _, Some n => make_mulimm n r1 r2 + | _, _ => (op, args) + end + | op_strength_reduction_case7 r1 r2 => (* Odivu *) + match intval r2 with + | Some n => + match Int.is_power2 n with + | Some l => make_shruimm l r1 + | None => (op, args) + end + | None => + (op, args) + end + | op_strength_reduction_case8 r1 r2 => (* Oand *) + match intval r1, intval r2 with + | Some n, _ => make_andimm n r2 + | _, Some n => make_andimm n r1 + | _, _ => (op, args) + end + | op_strength_reduction_case9 s r1 r2 => (* Oandshift *) + match intval r2 with + | Some n => make_andimm (eval_shift s n) r1 + | _ => (op, args) + end + | op_strength_reduction_case10 r1 r2 => (* Oor *) + match intval r1, intval r2 with + | Some n, _ => make_orimm n r2 + | _, Some n => make_orimm n r1 + | _, _ => (op, args) + end + | op_strength_reduction_case11 s r1 r2 => (* Oorshift *) + match intval r2 with + | Some n => make_orimm (eval_shift s n) r1 + | _ => (op, args) + end + | op_strength_reduction_case12 r1 r2 => (* Oxor *) + match intval r1, intval r2 with + | Some n, _ => make_xorimm n r2 + | _, Some n => make_xorimm n r1 + | _, _ => (op, args) + end + | op_strength_reduction_case13 s r1 r2 => (* Oxorshift *) + match intval r2 with + | Some n => make_xorimm (eval_shift s n) r1 + | _ => (op, args) + end + | op_strength_reduction_case14 r1 r2 => (* Obic *) + match intval r2 with + | Some n => make_andimm (Int.not n) r1 + | _ => (op, args) + end + | op_strength_reduction_case15 s r1 r2 => (* Obicshift *) + match intval r2 with + | Some n => make_andimm (Int.not (eval_shift s n)) r1 + | _ => (op, args) + end + | op_strength_reduction_case16 r1 r2 => (* Oshl *) + match intval r2 with + | Some n => + if Int.ltu n (Int.repr 32) + then make_shlimm n r1 + else (op, args) + | _ => (op, args) + end + | op_strength_reduction_case17 r1 r2 => (* Oshr *) + match intval r2 with + | Some n => + if Int.ltu n (Int.repr 32) + then make_shrimm n r1 + else (op, args) + | _ => (op, args) + end + | op_strength_reduction_case18 r1 r2 => (* Oshru *) + match intval r2 with + | Some n => + if Int.ltu n (Int.repr 32) + then make_shruimm n r1 + else (op, args) + | _ => (op, args) + end + | op_strength_reduction_case19 c rl => (* Ocmp *) + let (c', args') := cond_strength_reduction c args in + (Ocmp c', args') + | op_strength_reduction_default op args => (* default *) + (op, args) + end. + +(* +Definition addr_strength_reduction (addr: addressing) (args: list reg) := + match addr, args with + | Aindexed2, r1 :: r2 :: nil => + | Aindexed2shift s, r1 :: r2 :: nil => + | _, _ => + end. +*) + +Inductive addr_strength_reduction_cases: forall (addr: addressing) (args: list reg), Set := + | addr_strength_reduction_case1: + forall r1 r2, + addr_strength_reduction_cases (Aindexed2) (r1 :: r2 :: nil) + | addr_strength_reduction_case2: + forall s r1 r2, + addr_strength_reduction_cases (Aindexed2shift s) (r1 :: r2 :: nil) + | addr_strength_reduction_default: + forall (addr: addressing) (args: list reg), + addr_strength_reduction_cases addr args. + +Definition addr_strength_reduction_match (addr: addressing) (args: list reg) := + match addr as z1, args as z2 return addr_strength_reduction_cases z1 z2 with + | Aindexed2, r1 :: r2 :: nil => + addr_strength_reduction_case1 r1 r2 + | Aindexed2shift s, r1 :: r2 :: nil => + addr_strength_reduction_case2 s r1 r2 + | addr, args => + addr_strength_reduction_default addr args + end. + +Definition addr_strength_reduction (addr: addressing) (args: list reg) := + match addr_strength_reduction_match addr args with + | addr_strength_reduction_case1 r1 r2 => (* Aindexed2 *) + match intval r1, intval r2 with + | Some n1, _ => (Aindexed n1, r2 :: nil) + | _, Some n2 => (Aindexed n2, r1 :: nil) + | _, _ => (addr, args) + end + | addr_strength_reduction_case2 s r1 r2 => (* Aindexed2shift *) + match intval r2 with + | Some n2 => (Aindexed (eval_shift s n2), r1 :: nil) + | _ => (addr, args) + end + | addr_strength_reduction_default addr args => + (addr, args) + end. + +End STRENGTH_REDUCTION. + +(** ** Code transformation *) + +(** The code transformation proceeds instruction by instruction. + Operators whose arguments are all statically known are turned + into ``load integer constant'', ``load float constant'' or + ``load symbol address'' operations. Operators for which some + but not all arguments are known are subject to 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 => + match eval_static_operation op (approx_regs args approx) with + | I n => + Iop (Ointconst n) nil res s + | F n => + Iop (Ofloatconst n) nil res s + | S symb ofs => + Iop (Oaddrsymbol symb ofs) nil res s + | _ => + let (op', args') := op_strength_reduction approx op args in + Iop op' args' res s + end + | Iload chunk addr args dst s => + let (addr', args') := addr_strength_reduction approx addr args in + Iload chunk addr' args' dst s + | Istore chunk addr args src s => + let (addr', args') := addr_strength_reduction approx addr args in + Istore chunk addr' args' src s + | 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 => + match eval_static_condition cond (approx_regs args approx) with + | Some b => + if b then Inop s1 else Inop s2 + | None => + let (cond', args') := cond_strength_reduction approx cond args in + Icond cond' args' s1 s2 + end + | _ => + instr + end. + +Definition transf_code (approxs: PMap.t D.t) (instrs: code) : code := + PTree.map (fun pc instr => transf_instr approxs!!pc instr) instrs. + +Lemma transf_code_wf: + forall f approxs, + (forall pc, Plt pc f.(fn_nextpc) \/ f.(fn_code)!pc = None) -> + (forall pc, Plt pc f.(fn_nextpc) + \/ (transf_code approxs f.(fn_code))!pc = None). +Proof. + intros. + elim (H pc); intro. + left; auto. + right. unfold transf_code. rewrite PTree.gmap. + unfold option_map; rewrite H0. reflexivity. +Qed. + +Definition transf_function (f: function) : function := + 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 (fd: fundef) : fundef := + AST.transf_fundef transf_function fd. + +Definition transf_program (p: program) : program := + transform_program transf_fundef p. diff --git a/arm/Constpropproof.v b/arm/Constpropproof.v new file mode 100644 index 0000000..e85cadf --- /dev/null +++ b/arm/Constpropproof.v @@ -0,0 +1,970 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Correctness proof for constant propagation. *) + +Require Import Coqlib. +Require Import Maps. +Require Import AST. +Require Import Integers. +Require Import Floats. +Require Import Values. +Require Import Events. +Require Import Mem. +Require Import Globalenvs. +Require Import Smallstep. +Require Import Op. +Require Import Registers. +Require Import RTL. +Require Import Lattice. +Require Import Kildall. +Require Import Constprop. + +(** * Correctness of the static analysis *) + +Section ANALYSIS. + +Variable ge: genv. + +(** We first show that the dataflow analysis is correct with respect + to the dynamic semantics: the approximations (sets of values) + of a register at a program point predicted by the static analysis + are a superset of the values actually encountered during concrete + executions. We formalize this correspondence between run-time values and + compile-time approximations by the following predicate. *) + +Definition val_match_approx (a: approx) (v: val) : Prop := + match a with + | Unknown => True + | I p => v = Vint p + | F p => v = Vfloat p + | S symb ofs => exists b, Genv.find_symbol ge symb = Some b /\ v = Vptr b ofs + | _ => False + end. + +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. +Proof. + intros until v. + intros [A|[B|C]]. + subst a1. simpl. auto. + subst a2. simpl. tauto. + subst a2. auto. +Qed. + +Lemma regs_match_approx_increasing: + forall a1 a2 rs, + D.ge a1 a2 -> regs_match_approx a2 rs -> regs_match_approx a1 rs. +Proof. + unfold D.ge, regs_match_approx. intros. + apply val_match_approx_increasing with (D.get r a2); auto. +Qed. + +Lemma regs_match_approx_update: + forall ra rs a v r, + val_match_approx a v -> + regs_match_approx ra rs -> + regs_match_approx (D.set r a ra) (rs#r <- v). +Proof. + intros; red; intros. rewrite Regmap.gsspec. + case (peq r0 r); intro. + subst r0. rewrite D.gss. auto. + rewrite D.gso; auto. +Qed. + +Inductive val_list_match_approx: list approx -> list val -> Prop := + | vlma_nil: + val_list_match_approx nil nil + | vlma_cons: + forall a al v vl, + val_match_approx a v -> + val_list_match_approx al vl -> + val_list_match_approx (a :: al) (v :: vl). + +Lemma approx_regs_val_list: + forall ra rs rl, + regs_match_approx ra rs -> + val_list_match_approx (approx_regs rl ra) rs##rl. +Proof. + induction rl; simpl; intros. + constructor. + constructor. apply H. auto. +Qed. + +Ltac SimplVMA := + match goal with + | H: (val_match_approx (I _) ?v) |- _ => + simpl in H; (try subst v); SimplVMA + | H: (val_match_approx (F _) ?v) |- _ => + simpl in H; (try subst v); SimplVMA + | H: (val_match_approx (S _ _) ?v) |- _ => + simpl in H; + (try (elim H; + let b := fresh "b" in let A := fresh in let B := fresh in + (intros b [A B]; subst v; clear H))); + SimplVMA + | _ => + idtac + end. + +Ltac InvVLMA := + match goal with + | H: (val_list_match_approx nil ?vl) |- _ => + inversion H + | H: (val_list_match_approx (?a :: ?al) ?vl) |- _ => + inversion H; SimplVMA; InvVLMA + | _ => + idtac + end. + +(** We then show that [eval_static_operation] is a correct abstract + interpretations of [eval_operation]: if the concrete arguments match + the given approximations, the concrete results match the + approximations returned by [eval_static_operation]. *) + +Lemma eval_static_condition_correct: + forall cond al vl m b, + val_list_match_approx al vl -> + eval_static_condition cond al = Some b -> + eval_condition cond vl m = Some b. +Proof. + intros until b. + unfold eval_static_condition. + case (eval_static_condition_match cond al); intros; + InvVLMA; simpl; congruence. +Qed. + +Lemma eval_static_operation_correct: + forall op sp al vl m v, + val_list_match_approx al vl -> + eval_operation ge sp op vl m = Some v -> + val_match_approx (eval_static_operation op al) v. +Proof. + intros until v. + unfold eval_static_operation. + case (eval_static_operation_match op al); intros; + InvVLMA; simpl in *; FuncInv; try congruence. + + destruct (Genv.find_symbol ge s). exists b. intuition congruence. + congruence. + + rewrite <- H3. replace v0 with (Vint n1). reflexivity. congruence. + rewrite <- H3. replace v0 with (Vint n1). reflexivity. congruence. + rewrite <- H3. replace v0 with (Vint n1). reflexivity. congruence. + rewrite <- H3. replace v0 with (Vint n1). reflexivity. congruence. + + exists b. split. auto. congruence. + exists b. split. auto. congruence. + exists b. split. auto. congruence. + exists b. split. auto. congruence. + exists b. split. auto. congruence. + + replace n2 with i0. destruct (Int.eq i0 Int.zero). + discriminate. injection H0; intro; subst v. simpl. congruence. congruence. + + replace n2 with i0. destruct (Int.eq i0 Int.zero). + discriminate. injection H0; intro; subst v. simpl. congruence. congruence. + + replace n2 with i0. destruct (Int.ltu i0 (Int.repr 32)). + injection H0; intro; subst v. simpl. congruence. discriminate. congruence. + + replace n2 with i0. destruct (Int.ltu i0 (Int.repr 32)). + injection H0; intro; subst v. simpl. congruence. discriminate. congruence. + + replace n2 with i0. destruct (Int.ltu i0 (Int.repr 32)). + injection H0; intro; subst v. simpl. congruence. discriminate. congruence. + + rewrite <- H3. replace v0 with (Vfloat n1). reflexivity. congruence. + + caseEq (eval_static_condition c vl0). + 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. + + replace n1 with i. destruct (Int.ltu n (Int.repr 31)). + injection H0; intro; subst v. simpl. auto. congruence. congruence. + + 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 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 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; eauto. + elim (fn_code_wf f pc); intro. auto. + unfold successors in H0; rewrite H2 in H0; simpl; contradiction. + auto. + intros. rewrite PMap.gi. apply regs_match_approx_top. +Qed. + +Lemma analyze_correct_3: + forall f rs, + regs_match_approx (analyze f)!!(f.(fn_entrypoint)) rs. +Proof. + 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; eauto. auto with coqlib. + apply regs_match_approx_top. + intros. rewrite PMap.gi. apply regs_match_approx_top. +Qed. + +(** * Correctness of strength reduction *) + +(** We now show that strength reduction over operators and addressing + modes preserve semantics: the strength-reduced operations and + addressings evaluate to the same values as the original ones if the + actual arguments match the static approximations used for strength + reduction. *) + +Section STRENGTH_REDUCTION. + +Variable approx: D.t. +Variable sp: val. +Variable rs: regset. +Hypothesis MATCH: regs_match_approx approx rs. + +Lemma intval_correct: + forall r n, + intval approx r = Some n -> rs#r = Vint n. +Proof. + intros until n. + unfold intval. caseEq (D.get r approx); intros; try discriminate. + generalize (MATCH r). unfold val_match_approx. rewrite H. + congruence. +Qed. + +Lemma cond_strength_reduction_correct: + forall cond args m, + let (cond', args') := cond_strength_reduction approx cond args in + 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. + + caseEq (intval approx r1); intros. + simpl. rewrite (intval_correct _ _ H). + destruct (rs#r2); auto. rewrite Int.swap_cmp. auto. + destruct c; reflexivity. + caseEq (intval approx r2); intros. + simpl. rewrite (intval_correct _ _ H0). auto. + auto. + + caseEq (intval approx r1); intros. + simpl. rewrite (intval_correct _ _ H). + destruct (rs#r2); auto. rewrite Int.swap_cmpu. auto. + caseEq (intval approx r2); intros. + simpl. rewrite (intval_correct _ _ H0). auto. + auto. + + caseEq (intval approx r2); intros. + simpl. rewrite (intval_correct _ _ H). auto. + auto. + + caseEq (intval approx r2); intros. + simpl. rewrite (intval_correct _ _ H). auto. + auto. + + auto. +Qed. + +Lemma make_addimm_correct: + forall n r m v, + let (op, args) := make_addimm n r in + 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. + subst n. simpl in *. FuncInv. rewrite Int.add_zero in H. congruence. + rewrite Int.add_zero in H. congruence. + exact H0. +Qed. + +Lemma make_shlimm_correct: + forall n r m v, + let (op, args) := make_shlimm n r in + 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. + subst n. simpl in *. FuncInv. rewrite Int.shl_zero in H. congruence. + unfold is_shift_amount. destruct (is_shift_amount_aux n); intros. + simpl in *. FuncInv. rewrite e in H0. auto. + simpl in *. FuncInv. rewrite e in H0. discriminate. +Qed. + +Lemma make_shrimm_correct: + forall n r m v, + let (op, args) := make_shrimm n r in + 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. + subst n. simpl in *. FuncInv. rewrite Int.shr_zero in H. congruence. + unfold is_shift_amount. destruct (is_shift_amount_aux n); intros. + simpl in *. FuncInv. rewrite e in H0. auto. + simpl in *. FuncInv. rewrite e in H0. discriminate. +Qed. + +Lemma make_shruimm_correct: + forall n r m v, + let (op, args) := make_shruimm n r in + 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. + subst n. simpl in *. FuncInv. rewrite Int.shru_zero in H. congruence. + unfold is_shift_amount. destruct (is_shift_amount_aux n); intros. + simpl in *. FuncInv. rewrite e in H0. auto. + simpl in *. FuncInv. rewrite e in H0. discriminate. +Qed. + +Lemma make_mulimm_correct: + forall n r r' m v, + rs#r' = Vint n -> + let (op, args) := make_mulimm n r r' in + 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. + subst n. simpl in H1. FuncInv. rewrite Int.mul_zero in H0. simpl. congruence. + generalize (Int.eq_spec n Int.one); case (Int.eq n Int.one); intros. + subst n. simpl in H2. simpl. FuncInv. rewrite Int.mul_one in H1. congruence. + caseEq (Int.is_power2 n); intros. + 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 _ _ H2). + change (Z_of_nat wordsize) with 32. intro. rewrite H3. + destruct rs#r; auto. rewrite (Int.mul_pow2 i0 _ _ H2). auto. + simpl List.map. rewrite H. auto. +Qed. + +Lemma make_andimm_correct: + forall n r m v, + let (op, args) := make_andimm n r in + 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. + subst n. simpl in *. FuncInv. rewrite Int.and_zero in H. congruence. + generalize (Int.eq_spec n Int.mone); case (Int.eq n Int.mone); intros. + subst n. simpl in *. FuncInv. rewrite Int.and_mone in H0. congruence. + exact H1. +Qed. + +Lemma make_orimm_correct: + forall n r m v, + let (op, args) := make_orimm n r in + 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. + subst n. simpl in *. FuncInv. rewrite Int.or_zero in H. congruence. + generalize (Int.eq_spec n Int.mone); case (Int.eq n Int.mone); intros. + subst n. simpl in *. FuncInv. rewrite Int.or_mone in H0. congruence. + exact H1. +Qed. + +Lemma make_xorimm_correct: + forall n r m v, + let (op, args) := make_xorimm n r in + 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. + subst n. simpl in *. FuncInv. rewrite Int.xor_zero in H. congruence. + generalize (Int.eq_spec n Int.mone); case (Int.eq n Int.mone); intros. + subst n. simpl in *. FuncInv. decEq. auto. + exact H1. +Qed. + +Lemma op_strength_reduction_correct: + forall op args m v, + let (op', args') := op_strength_reduction approx op args in + 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) 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. + rewrite (intval_correct _ _ H0). apply make_addimm_correct. + assumption. + (* Oaddshift *) + caseEq (intval approx r2); intros. + rewrite (intval_correct _ _ H). + replace (eval_operation ge sp (Oaddshift s) (rs # r1 :: Vint i :: nil) m) + with (eval_operation ge sp Oadd (rs # r1 :: Vint (eval_shift s i) :: nil) m). + apply make_addimm_correct. + simpl. destruct rs#r1; auto. + assumption. + (* Osub *) + caseEq (intval approx r1); intros. + rewrite (intval_correct _ _ H) in H0. + simpl in *. destruct rs#r2; auto. + caseEq (intval approx r2); intros. + rewrite (intval_correct _ _ H0). + 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. + (* Osubshift *) + caseEq (intval approx r2); intros. + rewrite (intval_correct _ _ H). + replace (eval_operation ge sp (Osubshift s) (rs # r1 :: Vint i :: nil) m) + with (eval_operation ge sp Oadd (rs # r1 :: Vint (Int.neg (eval_shift s i)) :: nil) m). + apply make_addimm_correct. + simpl. destruct rs#r1; auto; rewrite Int.sub_add_opp; auto. + assumption. + (* Orsubshift *) + caseEq (intval approx r2). intros n H. + rewrite (intval_correct _ _ H). + simpl. destruct rs#r1; auto. + auto. + (* Omul *) + caseEq (intval approx r1); intros. + rewrite (intval_correct _ _ H). + 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. apply intval_correct; auto. + simpl. destruct rs#r2; auto. rewrite Int.mul_commut; auto. + caseEq (intval approx r2); intros. + rewrite (intval_correct _ _ H0). apply make_mulimm_correct. + apply intval_correct; auto. + assumption. + (* Odivu *) + 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) 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). + rewrite (Int.is_power2_range _ _ H0). + generalize (Int.eq_spec i Int.zero); case (Int.eq i Int.zero); intros. + subst i. discriminate. + rewrite (Int.divu_pow2 i1 _ _ H0). auto. + assumption. + assumption. + (* Oand *) + caseEq (intval approx r1); intros. + rewrite (intval_correct _ _ H). + 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. + rewrite (intval_correct _ _ H0). apply make_andimm_correct. + assumption. + (* Oandshift *) + caseEq (intval approx r2); intros. + rewrite (intval_correct _ _ H). + replace (eval_operation ge sp (Oandshift s) (rs # r1 :: Vint i :: nil) m) + with (eval_operation ge sp Oand (rs # r1 :: Vint (eval_shift s i) :: nil) m). + apply make_andimm_correct. reflexivity. + assumption. + (* Oor *) + caseEq (intval approx r1); intros. + rewrite (intval_correct _ _ H). + 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. + rewrite (intval_correct _ _ H0). apply make_orimm_correct. + assumption. + (* Oorshift *) + caseEq (intval approx r2); intros. + rewrite (intval_correct _ _ H). + replace (eval_operation ge sp (Oorshift s) (rs # r1 :: Vint i :: nil) m) + with (eval_operation ge sp Oor (rs # r1 :: Vint (eval_shift s i) :: nil) m). + apply make_orimm_correct. reflexivity. + assumption. + (* Oxor *) + caseEq (intval approx r1); intros. + rewrite (intval_correct _ _ H). + 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. + rewrite (intval_correct _ _ H0). apply make_xorimm_correct. + assumption. + (* Oxorshift *) + caseEq (intval approx r2); intros. + rewrite (intval_correct _ _ H). + replace (eval_operation ge sp (Oxorshift s) (rs # r1 :: Vint i :: nil) m) + with (eval_operation ge sp Oxor (rs # r1 :: Vint (eval_shift s i) :: nil) m). + apply make_xorimm_correct. reflexivity. + assumption. + (* Obic *) + caseEq (intval approx r2); intros. + rewrite (intval_correct _ _ H). + replace (eval_operation ge sp Obic (rs # r1 :: Vint i :: nil) m) + with (eval_operation ge sp Oand (rs # r1 :: Vint (Int.not i) :: nil) m). + apply make_andimm_correct. reflexivity. + assumption. + (* Obicshift *) + caseEq (intval approx r2); intros. + rewrite (intval_correct _ _ H). + replace (eval_operation ge sp (Obicshift s) (rs # r1 :: Vint i :: nil) m) + with (eval_operation ge sp Oand (rs # r1 :: Vint (Int.not (eval_shift s i)) :: nil) m). + apply make_andimm_correct. reflexivity. + assumption. + (* Oshl *) + caseEq (intval approx r2); intros. + caseEq (Int.ltu i (Int.repr 32)); intros. + rewrite (intval_correct _ _ H). apply make_shlimm_correct. + assumption. + assumption. + (* Oshr *) + caseEq (intval approx r2); intros. + caseEq (Int.ltu i (Int.repr 32)); intros. + rewrite (intval_correct _ _ H). apply make_shrimm_correct. + assumption. + assumption. + (* Oshru *) + caseEq (intval approx r2); intros. + caseEq (Int.ltu i (Int.repr 32)); intros. + rewrite (intval_correct _ _ H). apply make_shruimm_correct. + assumption. + assumption. + (* Ocmp *) + generalize (cond_strength_reduction_correct c rl). + destruct (cond_strength_reduction approx c rl). + simpl. intro. rewrite H. auto. + (* default *) + assumption. +Qed. + +Ltac KnownApprox := + match goal with + | MATCH: (regs_match_approx ?approx ?rs), + H: (D.get ?r ?approx = ?a) |- _ => + generalize (MATCH r); rewrite H; intro; clear H; KnownApprox + | _ => idtac + end. + +Lemma addr_strength_reduction_correct: + forall addr args, + let (addr', args') := addr_strength_reduction approx addr args in + eval_addressing ge sp addr' rs##args' = eval_addressing ge sp addr rs##args. +Proof. + intros. + + unfold addr_strength_reduction; + case (addr_strength_reduction_match addr args); intros. + + (* Aindexed2 *) + caseEq (intval approx r1); intros. + simpl; rewrite (intval_correct _ _ H). + destruct rs#r2; auto. rewrite Int.add_commut; auto. + caseEq (intval approx r2); intros. + simpl; rewrite (intval_correct _ _ H0). auto. + auto. + + (* Aindexed2shift *) + caseEq (intval approx r2); intros. + simpl; rewrite (intval_correct _ _ H). auto. + auto. + + (* default *) + reflexivity. +Qed. + +End STRENGTH_REDUCTION. + +End ANALYSIS. + +(** * Correctness of the code transformation *) + +(** We now show that the transformed code after constant propagation + has the same semantics as the original code. *) + +Section PRESERVATION. + +Variable prog: program. +Let tprog := transf_program prog. +Let ge := Genv.globalenv prog. +Let tge := Genv.globalenv tprog. + +Lemma symbols_preserved: + forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. +Proof. + intros; unfold ge, tge, tprog, transf_program. + apply Genv.find_symbol_transf. +Qed. + +Lemma functions_translated: + forall (v: val) (f: fundef), + Genv.find_funct ge v = Some f -> + Genv.find_funct tge v = Some (transf_fundef f). +Proof. + intros. + exact (Genv.find_funct_transf transf_fundef H). +Qed. + +Lemma function_ptr_translated: + forall (b: block) (f: fundef), + Genv.find_funct_ptr ge b = Some f -> + Genv.find_funct_ptr tge b = Some (transf_fundef f). +Proof. + intros. + exact (Genv.find_funct_ptr_transf transf_fundef H). +Qed. + +Lemma sig_function_translated: + forall f, + funsig (transf_fundef f) = funsig f. +Proof. + 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: +<< + st1 --------------- st2 + | | + t| |t + | | + v v + st1'--------------- st2' +>> + The left vertical arrow represents a transition in the + 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 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), 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 proof of simulation proceeds by case analysis on the transition + taken in the source code. *) + +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. + induction 1; intros; inv MS. + + (* Inop *) + 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 *) + 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' m = Some v). + rewrite (eval_operation_preserved symbols_preserved). + 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 (analyze f)!!pc) rs##args m v + (approx_regs_val_list _ _ _ args MATCH) H0). + case (eval_static_operation op (approx_regs args (analyze f)!!pc)); intros; + simpl in H2; + eapply exec_Iop; eauto; simpl. + 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 *) + 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 (analyze f)!!pc sp rs + MATCH addr args). + rewrite ASR; simpl. congruence. + TransfInstr. rewrite ASR. intro. + exists (State s' (transf_code (analyze f) (fn_code f)) sp pc' (rs#dst <- v) m); split. + 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 *) + 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 (analyze f)!!pc sp rs + MATCH addr args). + rewrite ASR; simpl. congruence. + TransfInstr. rewrite ASR. intro. + exists (State s' (transf_code (analyze f) (fn_code f)) sp pc' rs m'); split. + 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 *) + 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 *) + 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 *) + 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' m = Some true). + generalize (cond_strength_reduction_correct + ge (analyze f)!!pc rs MATCH cond args m). + rewrite CSR. intro. congruence. + TransfInstr. rewrite CSR. + caseEq (eval_static_condition cond (approx_regs args (analyze f)!!pc)). + intros b ESC. + 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. + econstructor; eauto. + apply analyze_correct_1 with pc; auto. + unfold successors; rewrite H; auto with coqlib. + unfold transfer; rewrite H; auto. + + (* Icond, false *) + 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' m = Some false). + generalize (cond_strength_reduction_correct + ge (analyze f)!!pc rs MATCH cond args m). + rewrite CSR. intro. congruence. + TransfInstr. rewrite CSR. + caseEq (eval_static_condition cond (approx_regs args (analyze f)!!pc)). + intros b ESC. + 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. + 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 *) + simpl. unfold transf_function. + econstructor; split. + eapply exec_function_internal; simpl; eauto. + simpl. econstructor; eauto. + apply analyze_correct_3; auto. + + (* external function *) + 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, using the generic preservation theorem + [Smallstep.simulation_step_preservation]. *) + +Theorem transf_program_correct: + 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/arm/Machregs.v b/arm/Machregs.v new file mode 100644 index 0000000..3466c0b --- /dev/null +++ b/arm/Machregs.v @@ -0,0 +1,80 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +Require Import Coqlib. +Require Import Maps. +Require Import AST. + +(** ** Machine registers *) + +(** The following type defines the machine registers that can be referenced + as locations. These include: +- Integer registers that can be allocated to RTL pseudo-registers ([Rxx]). +- Floating-point registers that can be allocated to RTL pseudo-registers + ([Fxx]). +- Two integer registers, not allocatable, reserved as temporaries for + spilling and reloading ([ITx]). +- Two float registers, not allocatable, reserved as temporaries for + spilling and reloading ([FTx]). + + The type [mreg] does not include special-purpose machine registers + such as the stack pointer and the condition codes. *) + +Inductive mreg: Set := + (** Allocatable integer regs *) + | R0: mreg | R1: mreg | R2: mreg | R3: mreg + | R4: mreg | R5: mreg | R6: mreg | R7: mreg + | R8: mreg | R9: mreg | R11: mreg + (** Allocatable float regs *) + | F0: mreg | F1: mreg | F4: mreg | F5: mreg + | F6: mreg | F7: mreg + (** Integer temporaries *) + | IT1: mreg (* R10 *) | IT2: mreg (* R12 *) + (** Float temporaries *) + | FT1: mreg (* F2 *) | FT2: mreg (* F3 *). + +Lemma mreg_eq: forall (r1 r2: mreg), {r1 = r2} + {r1 <> r2}. +Proof. decide equality. Qed. + +Definition mreg_type (r: mreg): typ := + match r with + | R0 => Tint | R1 => Tint | R2 => Tint | R3 => Tint + | R4 => Tint | R5 => Tint | R6 => Tint | R7 => Tint + | R8 => Tint | R9 => Tint | R11 => Tint + | F0 => Tfloat | F1 => Tfloat | F4 => Tfloat | F5 => Tfloat + | F6 => Tfloat | F7 => Tfloat + | IT1 => Tint | IT2 => Tint + | FT1 => Tfloat | FT2 => Tfloat + end. + +Open Scope positive_scope. + +Module IndexedMreg <: INDEXED_TYPE. + Definition t := mreg. + Definition eq := mreg_eq. + Definition index (r: mreg): positive := + match r with + | R0 => 1 | R1 => 2 | R2 => 3 | R3 => 4 + | R4 => 5 | R5 => 6 | R6 => 7 | R7 => 8 + | R8 => 9 | R9 => 10 | R11 => 11 + | F0 => 12 | F1 => 13 | F4 => 14 | F5 => 15 + | F6 => 16 | F7 => 17 + | IT1 => 18 | IT2 => 19 + | FT1 => 20 | FT2 => 21 + end. + Lemma index_inj: + forall r1 r2, index r1 = index r2 -> r1 = r2. + Proof. + destruct r1; destruct r2; simpl; intro; discriminate || reflexivity. + Qed. +End IndexedMreg. + diff --git a/arm/Op.v b/arm/Op.v new file mode 100644 index 0000000..6a6df7e --- /dev/null +++ b/arm/Op.v @@ -0,0 +1,1007 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Operators and addressing modes. The abstract syntax and dynamic + 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; +- [addressing]: addressing modes for load and store operations. + + These types are processor-specific and correspond roughly to what the + 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 Cminor language. +*) + +Require Import Coqlib. +Require Import AST. +Require Import Integers. +Require Import Floats. +Require Import Values. +Require Import Mem. +Require Import Globalenvs. + +Set Implicit Arguments. + +Record shift_amount : Set := + mk_shift_amount { + s_amount: int; + s_amount_ltu: Int.ltu s_amount (Int.repr 32) = true + }. + +Inductive shift : Set := + | Slsl: shift_amount -> shift + | Slsr: shift_amount -> shift + | Sasr: shift_amount -> shift + | Sror: shift_amount -> shift. + +(** Conditions (boolean-valued operators). *) + +Inductive condition : Set := + | Ccomp: comparison -> condition (**r signed integer comparison *) + | Ccompu: comparison -> condition (**r unsigned integer comparison *) + | Ccompshift: comparison -> shift -> condition (**r signed integer comparison *) + | Ccompushift: comparison -> shift -> condition (**r unsigned integer comparison *) + | Ccompimm: comparison -> int -> condition (**r signed integer comparison with a constant *) + | Ccompuimm: comparison -> int -> condition (**r unsigned integer comparison with a constant *) + | Ccompf: comparison -> condition (**r floating-point comparison *) + | Cnotcompf: comparison -> condition. (**r negation of a floating-point comparison *) + +(** Arithmetic and logical operations. In the descriptions, [rd] is the + result of the operation and [r1], [r2], etc, are the arguments. *) + +Inductive operation : Set := + | Omove: operation (**r [rd = r1] *) + | Ointconst: int -> operation (**r [rd] is set to the given integer constant *) + | 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 *) +(*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] *) + | Ocast16signed: operation (**r [rd] is 16-bit sign extension of [r1] *) + | Ocast16unsigned: operation (**r [rd] is 16-bit zero extension of [r1] *) + | Oadd: operation (**r [rd = r1 + r2] *) + | Oaddshift: shift -> operation (**r [rd = r1 + shifted r2] *) + | Oaddimm: int -> operation (**r [rd = r1 + n] *) + | Osub: operation (**r [rd = r1 - r2] *) + | Osubshift: shift -> operation (**r [rd = r1 - shifted r2] *) + | Orsubshift: shift -> operation (**r [rd = shifted r2 - r1] *) + | Orsubimm: int -> operation (**r [rd = r1 - n] *) + | Omul: operation (**r [rd = r1 * r2] *) + | Odiv: operation (**r [rd = r1 / r2] (signed) *) + | Odivu: operation (**r [rd = r1 / r2] (unsigned) *) + | Oand: operation (**r [rd = r1 & r2] *) + | Oandshift: shift -> operation (**r [rd = r1 & shifted r2] *) + | Oandimm: int -> operation (**r [rd = r1 & n] *) + | Oor: operation (**r [rd = r1 | r2] *) + | Oorshift: shift -> operation (**r [rd = r1 | shifted r2] *) + | Oorimm: int -> operation (**r [rd = r1 | n] *) + | Oxor: operation (**r [rd = r1 ^ r2] *) + | Oxorshift: shift -> operation (**r [rd = r1 ^ shifted r2] *) + | Oxorimm: int -> operation (**r [rd = r1 ^ n] *) + | Obic: operation (**r [rd = r1 & ~r2] *) + | Obicshift: shift -> operation (**r [rd = r1 & ~(shifted r2)] *) + | Onot: operation (**r [rd = ~r1] *) + | Onotshift: shift -> operation (**r [rd = ~(shifted r1)] *) + | Oshl: operation (**r [rd = r1 << r2] *) + | Oshr: operation (**r [rd = r1 >> r2] (signed) *) + | Oshru: operation (**r [rd = r1 >> r2] (unsigned) *) + | Oshift: shift -> operation (**r [rd = shifted r1] *) + | Oshrximm: int -> operation (**r [rd = r1 / 2^n] (signed) *) +(*c Floating-point arithmetic: *) + | Onegf: operation (**r [rd = - r1] *) + | Oabsf: operation (**r [rd = abs(r1)] *) + | Oaddf: operation (**r [rd = r1 + r2] *) + | Osubf: operation (**r [rd = r1 - r2] *) + | Omulf: operation (**r [rd = r1 * r2] *) + | Odivf: operation (**r [rd = r1 / r2] *) + | Osingleoffloat: operation (**r [rd] is [r1] truncated to single-precision float *) +(*c Conversions between int and float: *) + | Ointoffloat: operation (**r [rd = int_of_float(r1)] *) + | Ointuoffloat: operation (**r [rd = unsigned_int_of_float(r1)] *) + | Ofloatofint: operation (**r [rd = float_of_signed_int(r1)] *) + | Ofloatofintu: operation (**r [rd = float_of_unsigned_int(r1)] *) +(*c Boolean tests: *) + | Ocmp: condition -> operation. (**r [rd = 1] if condition holds, [rd = 0] otherwise. *) + +(** Addressing modes. [r1], [r2], etc, are the arguments to the + addressing. *) + +Inductive addressing: Set := + | Aindexed: int -> addressing (**r Address is [r1 + offset] *) + | Aindexed2: addressing (**r Address is [r1 + r2] *) + | Aindexed2shift: shift -> addressing (**r Address is [r1 + shifted r2] *) + | Ainstack: int -> addressing. (**r Address is [stack_pointer + offset] *) + +(** Comparison functions (used in module [CSE]). *) + +Definition eq_shift (x y: shift): {x=y} + {x<>y}. +Proof. + generalize Int.eq_dec; intro. + assert (forall (x y: shift_amount), {x=y}+{x<>y}). + destruct x as [x Px]. destruct y as [y Py]. destruct (H x y). + subst x. rewrite (proof_irrelevance _ Px Py). left; auto. + right. red; intro. elim n. inversion H0. auto. + decide equality. +Qed. + +Definition eq_operation (x y: operation): {x=y} + {x<>y}. +Proof. + generalize Int.eq_dec; intro. + generalize Float.eq_dec; intro. + assert (forall (x y: ident), {x=y}+{x<>y}). exact peq. + generalize eq_shift; intro. + assert (forall (x y: comparison), {x=y}+{x<>y}). decide equality. + assert (forall (x y: condition), {x=y}+{x<>y}). decide equality. + decide equality. +Qed. + +Definition eq_addressing (x y: addressing) : {x=y} + {x<>y}. +Proof. + generalize Int.eq_dec; intro. + generalize eq_shift; intro. + decide equality. +Qed. + +(** Evaluation of conditions, operators and addressing modes applied + to lists of values. Return [None] when the computation is undefined: + wrong number of arguments, arguments of the wrong types, undefined + operations such as division by zero. [eval_condition] returns a boolean, + [eval_operation] and [eval_addressing] return a value. *) + +Definition eval_compare_mismatch (c: comparison) : option bool := + match c with Ceq => Some false | Cne => Some true | _ => None end. + +Definition eval_compare_null (c: comparison) (n: int) : option bool := + if Int.eq n Int.zero + then match c with Ceq => Some false | Cne => Some true | _ => None end + else None. + +Definition eval_shift (s: shift) (n: int) : int := + match s with + | Slsl x => Int.shl n (s_amount x) + | Slsr x => Int.shru n (s_amount x) + | Sasr x => Int.shr n (s_amount x) + | Sror x => Int.ror n (s_amount x) + end. + +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 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 eval_compare_mismatch c + 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) + | Ccompshift c s, Vint n1 :: Vint n2 :: nil => + Some (Int.cmp c n1 (eval_shift s n2)) + | Ccompshift c s, Vptr b1 n1 :: Vint n2 :: nil => + eval_compare_null c (eval_shift s n2) + | Ccompushift c s, Vint n1 :: Vint n2 :: nil => + Some (Int.cmpu c n1 (eval_shift s n2)) + | 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) + | Ccompf c, Vfloat f1 :: Vfloat f2 :: nil => + Some (Float.cmp c f1 f2) + | Cnotcompf c, Vfloat f1 :: Vfloat f2 :: nil => + Some (negb (Float.cmp c f1 f2)) + | _, _ => + None + end. + +Definition offset_sp (sp: val) (delta: int) : option val := + match sp with + | Vptr b n => Some (Vptr b (Int.add n delta)) + | _ => None + end. + +Definition eval_operation + (F: Set) (genv: Genv.t F) (sp: 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) + | Ofloatconst n, nil => Some (Vfloat n) + | Oaddrsymbol s ofs, nil => + match Genv.find_symbol genv s with + | None => None + | Some b => Some (Vptr b ofs) + end + | Oaddrstack ofs, nil => offset_sp sp ofs + | Ocast8signed, v1 :: nil => Some (Val.sign_ext 8 v1) + | Ocast8unsigned, v1 :: nil => Some (Val.zero_ext 8 v1) + | Ocast16signed, v1 :: nil => Some (Val.sign_ext 16 v1) + | Ocast16unsigned, v1 :: nil => Some (Val.zero_ext 16 v1) + | 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)) + | Oaddshift s, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.add n1 (eval_shift s n2))) + | Oaddshift s, Vptr b1 n1 :: Vint n2 :: nil => Some (Vptr b1 (Int.add n1 (eval_shift s n2))) + | Oaddimm n, Vint n1 :: nil => Some (Vint (Int.add n1 n)) + | Oaddimm n, Vptr b1 n1 :: nil => Some (Vptr b1 (Int.add n1 n)) + | 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 + | Osubshift s, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.sub n1 (eval_shift s n2))) + | Osubshift s, Vptr b1 n1 :: Vint n2 :: nil => Some (Vptr b1 (Int.sub n1 (eval_shift s n2))) + | Orsubshift s, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.sub (eval_shift s n2) n1)) + | Orsubimm n, Vint n1 :: nil => Some (Vint (Int.sub n n1)) + | 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)) + | Oand, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.and n1 n2)) + | Oandshift s, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.and n1 (eval_shift s n2))) + | Oandimm n, Vint n1 :: nil => Some (Vint (Int.and n1 n)) + | Oor, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.or n1 n2)) + | Oorshift s, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.or n1 (eval_shift s n2))) + | Oorimm n, Vint n1 :: nil => Some (Vint (Int.or n1 n)) + | Oxor, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.xor n1 n2)) + | Oxorshift s, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.xor n1 (eval_shift s n2))) + | Oxorimm n, Vint n1 :: nil => Some (Vint (Int.xor n1 n)) + | Obic, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.and n1 (Int.not n2))) + | Obicshift s, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.and n1 (Int.not (eval_shift s n2)))) + | Onot, Vint n1 :: nil => Some (Vint (Int.not n1)) + | Onotshift s, Vint n1 :: nil => Some (Vint (Int.not (eval_shift s n1))) + | 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 + | Oshift s, Vint n :: nil => Some (Vint (eval_shift s n)) + | Oshrximm n, Vint n1 :: nil => + if Int.ltu n (Int.repr 31) then Some (Vint (Int.shrx n1 n)) 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, v1 :: nil => + Some (Val.singleoffloat v1) + | Ointoffloat, Vfloat f1 :: nil => + Some (Vint (Float.intoffloat f1)) + | Ointuoffloat, Vfloat f1 :: nil => + Some (Vint (Float.intuoffloat f1)) + | Ofloatofint, Vint n1 :: nil => + Some (Vfloat (Float.floatofint n1)) + | Ofloatofintu, Vint n1 :: nil => + Some (Vfloat (Float.floatofintu n1)) + | Ocmp c, _ => + match eval_condition c vl m with + | None => None + | Some false => Some Vfalse + | Some true => Some Vtrue + end + | _, _ => None + end. + +Definition eval_addressing + (F: Set) (genv: Genv.t F) (sp: val) + (addr: addressing) (vl: list val) : option val := + match addr, vl with + | Aindexed n, Vptr b1 n1 :: nil => + Some (Vptr b1 (Int.add n1 n)) + | Aindexed2, Vptr b1 n1 :: Vint n2 :: nil => + Some (Vptr b1 (Int.add n1 n2)) + | Aindexed2, Vint n1 :: Vptr b2 n2 :: nil => + Some (Vptr b2 (Int.add n1 n2)) + | Aindexed2shift s, Vptr b1 n1 :: Vint n2 :: nil => + Some (Vptr b1 (Int.add n1 (eval_shift s n2))) + | Ainstack ofs, nil => + offset_sp sp ofs + | _, _ => None + end. + +Definition negate_condition (cond: condition): condition := + match cond with + | Ccomp c => Ccomp(negate_comparison c) + | Ccompu c => Ccompu(negate_comparison c) + | Ccompshift c s => Ccompshift (negate_comparison c) s + | Ccompushift c s => Ccompushift (negate_comparison c) s + | Ccompimm c n => Ccompimm (negate_comparison c) n + | Ccompuimm c n => Ccompuimm (negate_comparison c) n + | Ccompf c => Cnotcompf c + | Cnotcompf c => Ccompf c + end. + +Ltac FuncInv := + match goal with + | H: (match ?x with nil => _ | _ :: _ => _ end = Some _) |- _ => + destruct x; simpl in H; try discriminate; FuncInv + | H: (match ?v with Vundef => _ | Vint _ => _ | Vfloat _ => _ | Vptr _ _ => _ end = Some _) |- _ => + destruct v; simpl in H; try discriminate; FuncInv + | H: (Some _ = Some _) |- _ => + injection H; intros; clear H; FuncInv + | _ => + idtac + end. + +Remark eval_negate_compare_null: + forall c n b, + eval_compare_null c n = Some b -> + eval_compare_null (negate_comparison c) n = Some (negb b). +Proof. + intros until b. unfold eval_compare_null. + case (Int.eq n Int.zero). + destruct c; intro EQ; simplify_eq EQ; intros; subst b; reflexivity. + intro; discriminate. +Qed. + +Lemma eval_negate_condition: + 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. + destruct c; simpl in H; inv H; auto. + discriminate. + rewrite Int.negate_cmpu. auto. + rewrite Int.negate_cmp. auto. + apply eval_negate_compare_null; auto. + rewrite Int.negate_cmpu. auto. + rewrite Int.negate_cmp. auto. + apply eval_negate_compare_null; auto. + rewrite Int.negate_cmpu. auto. + auto. + rewrite negb_elim. auto. +Qed. + +(** [eval_operation] and [eval_addressing] depend on a global environment + for resolving references to global symbols. We show that they give + the same results if a global environment is replaced by another that + assigns the same addresses to the same symbols. *) + +Section GENV_TRANSF. + +Variable F1 F2: Set. +Variable ge1: Genv.t F1. +Variable ge2: Genv.t F2. +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 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; + reflexivity. +Qed. + +Lemma eval_addressing_preserved: + forall sp addr vl, + eval_addressing ge2 sp addr vl = eval_addressing ge1 sp addr vl. +Proof. + intros. + assert (UNUSED: forall (s: ident), Genv.find_symbol ge2 s = Genv.find_symbol ge1 s). + exact agree_on_symbols. + unfold eval_addressing; destruct addr; try rewrite agree_on_symbols; + reflexivity. +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 + (A: Set) (op: operation) (args: list A) : option A := + match op, args with + | Omove, arg :: nil => Some arg + | _, _ => None + end. + +Lemma is_move_operation_correct: + forall (A: Set) (op: operation) (args: list A) (a: A), + is_move_operation op args = Some a -> + op = Omove /\ args = a :: nil. +Proof. + intros until a. unfold is_move_operation; destruct op; + try (intros; discriminate). + destruct args. intros; discriminate. + destruct args. intros. intuition congruence. + intros; discriminate. +Qed. + +(** Static typing of conditions, operators and addressing modes. *) + +Definition type_of_condition (c: condition) : list typ := + match c with + | Ccomp _ => Tint :: Tint :: nil + | Ccompu _ => Tint :: Tint :: nil + | Ccompshift _ _ => Tint :: Tint :: nil + | Ccompushift _ _ => Tint :: Tint :: nil + | Ccompimm _ _ => Tint :: nil + | Ccompuimm _ _ => Tint :: nil + | Ccompf _ => Tfloat :: Tfloat :: nil + | Cnotcompf _ => Tfloat :: Tfloat :: nil + end. + +Definition type_of_operation (op: operation) : list typ * typ := + match op with + | Omove => (nil, Tint) (* treated specially *) + | Ointconst _ => (nil, Tint) + | Ofloatconst _ => (nil, Tfloat) + | Oaddrsymbol _ _ => (nil, Tint) + | Oaddrstack _ => (nil, Tint) + | Ocast8signed => (Tint :: nil, Tint) + | Ocast8unsigned => (Tint :: nil, Tint) + | Ocast16signed => (Tint :: nil, Tint) + | Ocast16unsigned => (Tint :: nil, Tint) + | Oadd => (Tint :: Tint :: nil, Tint) + | Oaddshift _ => (Tint :: Tint :: nil, Tint) + | Oaddimm _ => (Tint :: nil, Tint) + | Osub => (Tint :: Tint :: nil, Tint) + | Osubshift _ => (Tint :: Tint :: nil, Tint) + | Orsubshift _ => (Tint :: Tint :: nil, Tint) + | Orsubimm _ => (Tint :: nil, Tint) + | Omul => (Tint :: Tint :: nil, Tint) + | Odiv => (Tint :: Tint :: nil, Tint) + | Odivu => (Tint :: Tint :: nil, Tint) + | Oand => (Tint :: Tint :: nil, Tint) + | Oandshift _ => (Tint :: Tint :: nil, Tint) + | Oandimm _ => (Tint :: nil, Tint) + | Oor => (Tint :: Tint :: nil, Tint) + | Oorshift _ => (Tint :: Tint :: nil, Tint) + | Oorimm _ => (Tint :: nil, Tint) + | Oxor => (Tint :: Tint :: nil, Tint) + | Oxorshift _ => (Tint :: Tint :: nil, Tint) + | Oxorimm _ => (Tint :: nil, Tint) + | Obic => (Tint :: Tint :: nil, Tint) + | Obicshift _ => (Tint :: Tint :: nil, Tint) + | Onot => (Tint :: nil, Tint) + | Onotshift _ => (Tint :: nil, Tint) + | Oshl => (Tint :: Tint :: nil, Tint) + | Oshr => (Tint :: Tint :: nil, Tint) + | Oshru => (Tint :: Tint :: nil, Tint) + | Oshift _ => (Tint :: nil, Tint) + | Oshrximm _ => (Tint :: nil, Tint) + | Onegf => (Tfloat :: nil, Tfloat) + | Oabsf => (Tfloat :: nil, Tfloat) + | Oaddf => (Tfloat :: Tfloat :: nil, Tfloat) + | Osubf => (Tfloat :: Tfloat :: nil, Tfloat) + | Omulf => (Tfloat :: Tfloat :: nil, Tfloat) + | Odivf => (Tfloat :: Tfloat :: nil, Tfloat) + | Osingleoffloat => (Tfloat :: nil, Tfloat) + | Ointoffloat => (Tfloat :: nil, Tint) + | Ointuoffloat => (Tfloat :: nil, Tint) + | Ofloatofint => (Tint :: nil, Tfloat) + | Ofloatofintu => (Tint :: nil, Tfloat) + | Ocmp c => (type_of_condition c, Tint) + end. + +Definition type_of_addressing (addr: addressing) : list typ := + match addr with + | Aindexed _ => Tint :: nil + | Aindexed2 => Tint :: Tint :: nil + | Aindexed2shift _ => Tint :: Tint :: nil + | Ainstack _ => nil + end. + +Definition type_of_chunk (c: memory_chunk) : typ := + match c with + | Mint8signed => Tint + | Mint8unsigned => Tint + | Mint16signed => Tint + | Mint16unsigned => Tint + | Mint32 => Tint + | Mfloat32 => Tfloat + | Mfloat64 => Tfloat + end. + +(** Weak type soundness results for [eval_operation]: + the result values, when defined, are always of the type predicted + by [type_of_operation]. *) + +Section SOUNDNESS. + +Variable A: Set. +Variable genv: Genv.t A. + +Lemma type_of_operation_sound: + 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 H0; FuncInv; try subst v; try exact I. + congruence. + 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 H0; intro; subst v; exact I. + discriminate. + destruct (Int.eq i0 Int.zero). discriminate. + injection H0; intro; subst v; exact I. + destruct (Int.eq i0 Int.zero). discriminate. + injection H0; intro; subst v; exact I. + destruct (Int.ltu i0 (Int.repr 32)). + injection H0; intro; subst v; exact I. discriminate. + destruct (Int.ltu i0 (Int.repr 32)). + injection H0; intro; subst v; exact I. discriminate. + destruct (Int.ltu i0 (Int.repr 32)). + injection H0; intro; subst v; exact I. discriminate. + destruct (Int.ltu i (Int.repr 31)). + injection H0; intro; subst v; exact I. discriminate. + destruct v0; exact I. + destruct (eval_condition c vl). + destruct b; injection H0; intro; subst v; exact I. + discriminate. +Qed. + +Lemma type_of_chunk_correct: + forall chunk m addr v, + Mem.loadv chunk m addr = Some v -> + Val.has_type v (type_of_chunk chunk). +Proof. + intro chunk. + assert (forall v, Val.has_type (Val.load_result chunk v) (type_of_chunk chunk)). + destruct v; destruct chunk; exact I. + intros until v. unfold Mem.loadv. + destruct addr; intros; try discriminate. + generalize (Mem.load_inv _ _ _ _ _ H0). + intros [X Y]. subst v. apply H. +Qed. + +End SOUNDNESS. + +(** Alternate definition of [eval_condition], [eval_op], [eval_addressing] + as total functions that return [Vundef] when not applicable + (instead of [None]). Used in the proof of [PPCgen]. *) + +Section EVAL_OP_TOTAL. + +Variable F: Set. +Variable genv: Genv.t F. + +Definition find_symbol_offset (id: ident) (ofs: int) : val := + match Genv.find_symbol genv id with + | Some b => Vptr b ofs + | None => Vundef + end. + +Definition eval_shift_total (s: shift) (v: val) : val := + match v with + | Vint n => Vint(eval_shift s n) + | _ => Vundef + end. + +Definition eval_condition_total (cond: condition) (vl: list val) : val := + match cond, vl with + | Ccomp c, v1::v2::nil => Val.cmp c v1 v2 + | Ccompu c, v1::v2::nil => Val.cmpu c v1 v2 + | Ccompshift c s, v1::v2::nil => Val.cmp c v1 (eval_shift_total s v2) + | Ccompushift c s, v1::v2::nil => Val.cmpu c v1 (eval_shift_total s v2) + | Ccompimm c n, v1::nil => Val.cmp c v1 (Vint n) + | Ccompuimm c n, v1::nil => Val.cmpu c v1 (Vint n) + | Ccompf c, v1::v2::nil => Val.cmpf c v1 v2 + | Cnotcompf c, v1::v2::nil => Val.notbool(Val.cmpf c v1 v2) + | _, _ => Vundef + end. + +Definition eval_operation_total (sp: val) (op: operation) (vl: list val) : val := + match op, vl with + | Omove, v1::nil => v1 + | Ointconst n, nil => Vint n + | Ofloatconst n, nil => Vfloat n + | Oaddrsymbol s ofs, nil => find_symbol_offset s ofs + | Oaddrstack ofs, nil => Val.add sp (Vint ofs) + | Ocast8signed, v1::nil => Val.sign_ext 8 v1 + | Ocast8unsigned, v1::nil => Val.zero_ext 8 v1 + | Ocast16signed, v1::nil => Val.sign_ext 16 v1 + | Ocast16unsigned, v1::nil => Val.zero_ext 16 v1 + | Oadd, v1::v2::nil => Val.add v1 v2 + | Oaddshift s, v1::v2::nil => Val.add v1 (eval_shift_total s v2) + | Oaddimm n, v1::nil => Val.add v1 (Vint n) + | Osub, v1::v2::nil => Val.sub v1 v2 + | Osubshift s, v1::v2::nil => Val.sub v1 (eval_shift_total s v2) + | Orsubshift s, v1::v2::nil => Val.sub (eval_shift_total s v2) v1 + | Orsubimm n, v1::nil => Val.sub (Vint n) v1 + | Omul, v1::v2::nil => Val.mul v1 v2 + | Odiv, v1::v2::nil => Val.divs v1 v2 + | Odivu, v1::v2::nil => Val.divu v1 v2 + | Oand, v1::v2::nil => Val.and v1 v2 + | Oandshift s, v1::v2::nil => Val.and v1 (eval_shift_total s v2) + | Oandimm n, v1::nil => Val.and v1 (Vint n) + | Oor, v1::v2::nil => Val.or v1 v2 + | Oorshift s, v1::v2::nil => Val.or v1 (eval_shift_total s v2) + | Oorimm n, v1::nil => Val.or v1 (Vint n) + | Oxor, v1::v2::nil => Val.xor v1 v2 + | Oxorshift s, v1::v2::nil => Val.xor v1 (eval_shift_total s v2) + | Oxorimm n, v1::nil => Val.xor v1 (Vint n) + | Obic, v1::v2::nil => Val.and v1 (Val.notint v2) + | Obicshift s, v1::v2::nil => Val.and v1 (Val.notint (eval_shift_total s v2)) + | Onot, v1::nil => Val.notint v1 + | Onotshift s, v1::nil => Val.notint (eval_shift_total s v1) + | Oshl, v1::v2::nil => Val.shl v1 v2 + | Oshr, v1::v2::nil => Val.shr v1 v2 + | Oshru, v1::v2::nil => Val.shru v1 v2 + | Oshrximm n, v1::nil => Val.shrx v1 (Vint n) + | Oshift s, v1::nil => eval_shift_total s v1 + | Onegf, v1::nil => Val.negf v1 + | Oabsf, v1::nil => Val.absf v1 + | Oaddf, v1::v2::nil => Val.addf v1 v2 + | Osubf, v1::v2::nil => Val.subf v1 v2 + | Omulf, v1::v2::nil => Val.mulf v1 v2 + | Odivf, v1::v2::nil => Val.divf v1 v2 + | Osingleoffloat, v1::nil => Val.singleoffloat v1 + | Ointoffloat, v1::nil => Val.intoffloat v1 + | Ointuoffloat, v1::nil => Val.intuoffloat v1 + | Ofloatofint, v1::nil => Val.floatofint v1 + | Ofloatofintu, v1::nil => Val.floatofintu v1 + | Ocmp c, _ => eval_condition_total c vl + | _, _ => Vundef + end. + +Definition eval_addressing_total + (sp: val) (addr: addressing) (vl: list val) : val := + match addr, vl with + | Aindexed n, v1::nil => Val.add v1 (Vint n) + | Aindexed2, v1::v2::nil => Val.add v1 v2 + | Aindexed2shift s, v1::v2::nil => Val.add v1 (eval_shift_total s v2) + | Ainstack ofs, nil => Val.add sp (Vint ofs) + | _, _ => Vundef + end. + +Lemma eval_compare_mismatch_weaken: + forall c b, + eval_compare_mismatch c = Some b -> + Val.cmp_mismatch c = Val.of_bool b. +Proof. + unfold eval_compare_mismatch. intros. destruct c; inv H; auto. +Qed. + +Lemma eval_compare_null_weaken: + forall c i b, + eval_compare_null c i = Some b -> + (if Int.eq i Int.zero then Val.cmp_mismatch c else Vundef) = Val.of_bool b. +Proof. + unfold eval_compare_null. intros. + destruct (Int.eq i Int.zero); try discriminate. + apply eval_compare_mismatch_weaken; auto. +Qed. + +Lemma eval_condition_weaken: + 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); try congruence. + apply eval_compare_mismatch_weaken; auto. + discriminate. + symmetry. apply Val.notbool_negb_1. +Qed. + +Lemma eval_operation_weaken: + forall sp op vl m v, + eval_operation genv sp op vl m = Some v -> + eval_operation_total sp op vl = v. +Proof. + intros. + unfold eval_operation in H; destruct op; FuncInv; + try subst v; try reflexivity; simpl. + unfold find_symbol_offset. + destruct (Genv.find_symbol genv i); try discriminate. + congruence. + unfold offset_sp in H. + destruct sp; try discriminate. simpl. congruence. + unfold eq_block in H. destruct (zeq b b0); congruence. + destruct (Int.eq i0 Int.zero); congruence. + destruct (Int.eq i0 Int.zero); congruence. + destruct (Int.ltu i0 (Int.repr 32)); congruence. + destruct (Int.ltu i0 (Int.repr 32)); congruence. + destruct (Int.ltu i0 (Int.repr 32)); congruence. + unfold Int.ltu in H. destruct (zlt (Int.unsigned i) (Int.unsigned (Int.repr 31))). + unfold Int.ltu. rewrite zlt_true. congruence. + assert (Int.unsigned (Int.repr 31) < Int.unsigned (Int.repr 32)). vm_compute; auto. + omega. discriminate. + caseEq (eval_condition c vl m); intros; rewrite H0 in H. + replace v with (Val.of_bool b). + eapply eval_condition_weaken; eauto. + destruct b; simpl; congruence. + discriminate. +Qed. + +Lemma eval_addressing_weaken: + forall sp addr vl v, + eval_addressing genv sp addr vl = Some v -> + eval_addressing_total sp addr vl = v. +Proof. + intros. + unfold eval_addressing in H; destruct addr; FuncInv; + try subst v; simpl; try reflexivity. + decEq. apply Int.add_commut. + unfold offset_sp in H. destruct sp; simpl; congruence. +Qed. + +Lemma eval_condition_total_is_bool: + forall cond vl, Val.is_bool (eval_condition_total cond vl). +Proof. + intros; destruct cond; + destruct vl; try apply Val.undef_is_bool; + destruct vl; try apply Val.undef_is_bool; + try (destruct vl; try apply Val.undef_is_bool); simpl. + apply Val.cmp_is_bool. + apply Val.cmpu_is_bool. + apply Val.cmp_is_bool. + apply Val.cmpu_is_bool. + apply Val.cmp_is_bool. + apply Val.cmpu_is_bool. + apply Val.cmpf_is_bool. + apply Val.notbool_is_bool. +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. + rewrite (Mem.valid_pointer_lessdef _ _ _ _ MEM H1). + rewrite (Mem.valid_pointer_lessdef _ _ _ _ MEM H). simpl. 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.sign_ext 8 v2); split. auto. apply Val.sign_ext_lessdef; auto. + exists (Val.zero_ext 8 v2); split. auto. apply Val.zero_ext_lessdef; auto. + exists (Val.sign_ext 16 v2); split. auto. apply Val.sign_ext_lessdef; auto. + exists (Val.zero_ext 16 v2); split. auto. apply Val.zero_ext_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 i0 (Int.repr 32)); inv H1; TrivialExists. + destruct (Int.ltu i0 (Int.repr 32)); inv H1; TrivialExists. + destruct (Int.ltu i (Int.repr 31)); 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. + exists v1; auto. +Qed. + +End EVAL_LESSDEF. + +(** Recognition of integers that are valid shift amounts. *) + +Definition is_shift_amount_aux (n: int) : + { Int.ltu n (Int.repr 32) = true } + + { Int.ltu n (Int.repr 32) = false }. +Proof. + intro. case (Int.ltu n (Int.repr 32)). left; auto. right; auto. +Defined. + +Definition is_shift_amount (n: int) : option shift_amount := + match is_shift_amount_aux n with + | left H => Some(mk_shift_amount n H) + | right _ => None + end. + +Lemma is_shift_amount_Some: + forall n s, is_shift_amount n = Some s -> s_amount s = n. +Proof. + intros until s. unfold is_shift_amount. + destruct (is_shift_amount_aux n). + simpl. intros. inv H. reflexivity. + congruence. +Qed. + +Lemma is_shift_amount_None: + forall n, is_shift_amount n = None -> Int.ltu n (Int.repr 32) = true -> False. +Proof. + intro n. unfold is_shift_amount. + destruct (is_shift_amount_aux n). + congruence. + congruence. +Qed. + +(** Transformation of addressing modes with two operands or more + into an equivalent arithmetic operation. This is used in the [Reload] + pass when a store instruction cannot be reloaded directly because + it runs out of temporary registers. *) + +(** For the ARM, there are only two binary addressing mode: [Aindexed2] + and [Aindexed2shift]. The corresponding operations are [Oadd] + and [Oaddshift]. *) + +Definition op_for_binary_addressing (addr: addressing) : operation := + match addr with + | Aindexed2 => Oadd + | Aindexed2shift s => Oaddshift s + | _ => Ointconst Int.zero (* never happens *) + end. + +Lemma eval_op_for_binary_addressing: + forall (F: Set) (ge: Genv.t F) sp addr args m v, + (length args >= 2)%nat -> + eval_addressing ge sp addr args = Some v -> + eval_operation ge sp (op_for_binary_addressing addr) args m = Some v. +Proof. + intros. + unfold eval_addressing in H0; destruct addr; FuncInv; simpl in H; try omegaContradiction; simpl. + rewrite Int.add_commut. congruence. + congruence. + congruence. +Qed. + +Lemma type_op_for_binary_addressing: + forall addr, + (length (type_of_addressing addr) >= 2)%nat -> + type_of_operation (op_for_binary_addressing addr) = (type_of_addressing addr, Tint). +Proof. + intros. destruct addr; simpl in H; reflexivity || omegaContradiction. +Qed. diff --git a/arm/Selection.v b/arm/Selection.v new file mode 100644 index 0000000..d5eb6b8 --- /dev/null +++ b/arm/Selection.v @@ -0,0 +1,1394 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** 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) + | 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 + 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 (Oshift s) (t1:::Enil) => Eop (Onotshift s) (t1:::Enil) + | Eop Onot (t1:::Enil) => t1 + | Eop (Onotshift s) (t1:::Enil) => Eop (Oshift s) (t1:::Enil) + | _ => Eop Onot (e:::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 s t1, + notint_cases (Eop (Oshift s) (t1:::Enil)) + | notint_case2: + forall t1, + notint_cases (Eop Onot (t1:::Enil)) + | notint_case3: + forall s t1, + notint_cases (Eop (Onotshift s) (t1:::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 (Oshift s) (t1:::Enil) => + notint_case1 s t1 + | Eop Onot (t1:::Enil) => + notint_case2 t1 + | Eop (Onotshift s) (t1:::Enil) => + notint_case3 s t1 + | 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 s t1 => + Eop (Onotshift s) (t1:::Enil) + | notint_case2 t1 => + t1 + | notint_case3 s t1 => + Eop (Oshift s) (t1:::Enil) + | notint_default e => + Eop Onot (e:::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 *) + +(** Addition of an integer constant. *) + +(* +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. +*) + +Inductive addimm_cases: forall (e: expr), Set := + | addimm_case1: + forall m, + addimm_cases (Eop (Ointconst m) Enil) + | addimm_case2: + forall s m, + addimm_cases (Eop (Oaddrsymbol s m) Enil) + | addimm_case3: + forall m, + addimm_cases (Eop (Oaddrstack m) Enil) + | addimm_case4: + forall m t, + 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 (Oshift s) (t1:::Enil), t2 => Eop (Oaddshift s) (t2:::t1:::Enil) + | t1, Eop (Oshift s) (t2:::Enil) => Eop (Oaddshift s) (t1:::t2:::Enil) + | _, _ => Eop Oadd (e1:::e2:::Enil) + end. +*) + +Inductive add_cases: forall (e1: expr) (e2: expr), Set := + | add_case1: + forall n1 t2, + add_cases (Eop (Ointconst n1) Enil) (t2) + | add_case2: + forall n1 t1 n2 t2, + add_cases (Eop (Oaddimm n1) (t1:::Enil)) (Eop (Oaddimm n2) (t2:::Enil)) + | add_case3: + forall n1 t1 t2, + add_cases (Eop (Oaddimm n1) (t1:::Enil)) (t2) + | add_case4: + forall t1 n2, + add_cases (t1) (Eop (Ointconst n2) Enil) + | add_case5: + forall t1 n2 t2, + add_cases (t1) (Eop (Oaddimm n2) (t2:::Enil)) + | add_case6: + forall s t1 t2, + add_cases (Eop (Oshift s) (t1:::Enil)) (t2) + | add_case7: + forall t1 s t2, + add_cases (t1) (Eop (Oshift s) (t2:::Enil)) + | add_default: + forall (e1: expr) (e2: expr), + add_cases e1 e2. + +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 + | t1, Eop (Ointconst n2) Enil => + add_case4 t1 n2 + | t1, Eop (Oaddimm n2) (t2:::Enil) => + add_case5 t1 n2 t2 + | Eop (Oshift s) (t1:::Enil), t2 => + add_case6 s t1 t2 + | t1, Eop (Oshift s) (t2:::Enil) => + add_case7 t1 s t2 + | e1, e2 => + add_default 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_case6 s t1 t2 => + Eop (Oaddshift s) (t2:::t1:::Enil) + | add_case7 t1 s t2 => + Eop (Oaddshift s) (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:::Rnil)) + | t1, Eop (Oaddimm n2) (t2:::Enil) => addimm (Int.neg n2) (Eop Osub (t1::::t2:::Enil)) + | Eop (Ointconst n1) Enil, t2 => Eop (Orsubimm n1) (t2:::Enil) + | Eop (Oshift s) (t1:::Enil), t2 => Eop (Orsubshift s) (t2:::t1:::Enil) + | t1, Eop (Oshift s) (t2:::Enil) => Eop (Osubshift s) (t1:::t2:::Enil) + | _, _ => Eop Osub (e1:::e2:::Enil) + end. +*) + +Inductive sub_cases: forall (e1: expr) (e2: expr), Set := + | sub_case1: + forall t1 n2, + sub_cases (t1) (Eop (Ointconst n2) Enil) + | sub_case2: + forall n1 t1 n2 t2, + sub_cases (Eop (Oaddimm n1) (t1:::Enil)) (Eop (Oaddimm n2) (t2:::Enil)) + | sub_case3: + forall n1 t1 t2, + sub_cases (Eop (Oaddimm n1) (t1:::Enil)) (t2) + | sub_case4: + forall t1 n2 t2, + sub_cases (t1) (Eop (Oaddimm n2) (t2:::Enil)) + | sub_case5: + forall n1 t2, + sub_cases (Eop (Ointconst n1) Enil) (t2) + | sub_case6: + forall s t1 t2, + sub_cases (Eop (Oshift s) (t1:::Enil)) (t2) + | sub_case7: + forall t1 s t2, + sub_cases (t1) (Eop (Oshift s) (t2:::Enil)) + | sub_default: + forall (e1: expr) (e2: expr), + sub_cases e1 e2. + +Definition sub_match (e1: expr) (e2: expr) := + match e1 as z1, e2 as z2 return sub_cases z1 z2 with + | t1, Eop (Ointconst n2) Enil => + sub_case1 t1 n2 + | Eop (Oaddimm n1) (t1:::Enil), Eop (Oaddimm n2) (t2:::Enil) => + sub_case2 n1 t1 n2 t2 + | Eop (Oaddimm n1) (t1:::Enil), t2 => + sub_case3 n1 t1 t2 + | t1, Eop (Oaddimm n2) (t2:::Enil) => + sub_case4 t1 n2 t2 + | Eop (Ointconst n1) Enil, t2 => + sub_case5 n1 t2 + | Eop (Oshift s) (t1:::Enil), t2 => + sub_case6 s t1 t2 + | t1, Eop (Oshift s) (t2:::Enil) => + sub_case7 t1 s t2 + | e1, e2 => + sub_default 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_case5 n1 t2 => + Eop (Orsubimm n1) (t2:::Enil) + | sub_case6 s t1 t2 => + Eop (Orsubshift s) (t2:::t1:::Enil) + | sub_case7 t1 s t2 => + Eop (Osubshift s) (t1:::t2:::Enil) + | sub_default e1 e2 => + Eop Osub (e1:::e2:::Enil) + end. + +(** ** Immediate shifts *) + +(* +Definition shlimm (e1: expr) := + if Int.eq n Int.zero then e1 else + match e1 with + | Eop (Ointconst n1) Enil => Eop (Ointconst(Int.shl n1 n)) + | Eop (Oshift (Olsl n1)) (t1:::Enil) => if Int.ltu (Int.add n n1) (Int.repr 32) then Eop (Oshift (Olsl (Int.add n n1))) (t1:::Enil) else Eop (Oshift (Olsl n)) (e1:::Enil) + | _ => Eop (Oshift (Olsl n)) (e1:::Enil) + end. +*) + +Inductive shlimm_cases: forall (e1: expr), Set := + | shlimm_case1: + forall n1, + shlimm_cases (Eop (Ointconst n1) Enil) + | shlimm_case2: + forall n1 t1, + shlimm_cases (Eop (Oshift (Slsl n1)) (t1:::Enil)) + | shlimm_default: + forall (e1: expr), + shlimm_cases e1. + +Definition shlimm_match (e1: expr) := + match e1 as z1 return shlimm_cases z1 with + | Eop (Ointconst n1) Enil => + shlimm_case1 n1 + | Eop (Oshift (Slsl n1)) (t1:::Enil) => + shlimm_case2 n1 t1 + | e1 => + shlimm_default e1 + end. + +Definition shlimm (e1: expr) (n: int) := + if Int.eq n Int.zero then e1 else + match is_shift_amount n with + | None => Eop Oshl (e1 ::: Eop (Ointconst n) Enil ::: Enil) + | Some n' => + match shlimm_match e1 with + | shlimm_case1 n1 => + Eop (Ointconst(Int.shl n1 n)) Enil + | shlimm_case2 n1 t1 => + match is_shift_amount (Int.add n (s_amount n1)) with + | None => + Eop (Oshift (Slsl n')) (e1:::Enil) + | Some n'' => + Eop (Oshift (Slsl n'')) (t1:::Enil) + end + | shlimm_default e1 => + Eop (Oshift (Slsl n')) (e1:::Enil) + end + end. + +(* +Definition shruimm (e1: expr) := + if Int.eq n Int.zero then e1 else + match e1 with + | Eop (Ointconst n1) Enil => Eop (Ointconst(Int.shru n1 n)) + | Eop (Oshift (Olsr n1)) (t1:::Enil) => if Int.ltu (Int.add n n1) (Int.repr 32) then Eop (Oshift (Olsr (Int.add n n1))) (t1:::Enil) else Eop (Oshift (Olsr n)) (e1:::Enil) + | _ => Eop (Oshift (Olsr n)) (e1:::Enil) + end. +*) + +Inductive shruimm_cases: forall (e1: expr), Set := + | shruimm_case1: + forall n1, + shruimm_cases (Eop (Ointconst n1) Enil) + | shruimm_case2: + forall n1 t1, + shruimm_cases (Eop (Oshift (Slsr n1)) (t1:::Enil)) + | shruimm_default: + forall (e1: expr), + shruimm_cases e1. + +Definition shruimm_match (e1: expr) := + match e1 as z1 return shruimm_cases z1 with + | Eop (Ointconst n1) Enil => + shruimm_case1 n1 + | Eop (Oshift (Slsr n1)) (t1:::Enil) => + shruimm_case2 n1 t1 + | e1 => + shruimm_default e1 + end. + +Definition shruimm (e1: expr) (n: int) := + if Int.eq n Int.zero then e1 else + match is_shift_amount n with + | None => Eop Oshru (e1 ::: Eop (Ointconst n) Enil ::: Enil) + | Some n' => + match shruimm_match e1 with + | shruimm_case1 n1 => + Eop (Ointconst(Int.shru n1 n)) Enil + | shruimm_case2 n1 t1 => + match is_shift_amount (Int.add n (s_amount n1)) with + | None => + Eop (Oshift (Slsr n')) (e1:::Enil) + | Some n'' => + Eop (Oshift (Slsr n'')) (t1:::Enil) + end + | shruimm_default e1 => + Eop (Oshift (Slsr n')) (e1:::Enil) + end + end. + +(* +Definition shrimm (e1: expr) := + match e1 with + | Eop (Ointconst n1) Enil => Eop (Ointconst(Int.shr n1 n)) + | Eop (Oshift (Oasr n1)) (t1:::Enil) => if Int.ltu (Int.add n n1) (Int.repr 32) then Eop (Oshift (Oasr (Int.add n n1))) (t1:::Enil) else Eop (Oshift (Oasr n)) (e1:::Enil) + | _ => Eop (Oshift (Oasr n)) (e1:::Enil) + end. +*) + +Inductive shrimm_cases: forall (e1: expr), Set := + | shrimm_case1: + forall n1, + shrimm_cases (Eop (Ointconst n1) Enil) + | shrimm_case2: + forall n1 t1, + shrimm_cases (Eop (Oshift (Sasr n1)) (t1:::Enil)) + | shrimm_default: + forall (e1: expr), + shrimm_cases e1. + +Definition shrimm_match (e1: expr) := + match e1 as z1 return shrimm_cases z1 with + | Eop (Ointconst n1) Enil => + shrimm_case1 n1 + | Eop (Oshift (Sasr n1)) (t1:::Enil) => + shrimm_case2 n1 t1 + | e1 => + shrimm_default e1 + end. + +Definition shrimm (e1: expr) (n: int) := + if Int.eq n Int.zero then e1 else + match is_shift_amount n with + | None => Eop Oshr (e1 ::: Eop (Ointconst n) Enil ::: Enil) + | Some n' => + match shrimm_match e1 with + | shrimm_case1 n1 => + Eop (Ointconst(Int.shr n1 n)) Enil + | shrimm_case2 n1 t1 => + match is_shift_amount (Int.add n (s_amount n1)) with + | None => + Eop (Oshift (Sasr n')) (e1:::Enil) + | Some n'' => + Eop (Oshift (Sasr n'')) (t1:::Enil) + end + | shrimm_default e1 => + Eop (Oshift (Sasr n')) (e1:::Enil) + end + end. + +(** ** 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 + (add (shlimm (Eletvar 0) i) (shlimm (Eletvar 0) j)) + | _ => + Eop Omul (Eop (Ointconst n1) Enil ::: e2 ::: Enil) + end. + +(* +Definition mulimm (n1: int) (e2: expr) := + if Int.eq n1 Int.zero then + 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 + 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 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))). + +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 => Eop (Oandimm (Int.sub n2 Int.one)) (e1:::Enil) + | None => mod_aux Odivu e1 e2 + end + | divu_default e2 => + mod_aux Odivu e1 e2 + end. + +Definition divs (e1: expr) (e2: expr) := + match divu_match e2 with + | divu_case1 n2 => + match Int.is_power2 n2 with + | Some l2 => if Int.ltu l2 (Int.repr 31) + then Eop (Oshrximm l2) (e1:::Enil) + else Eop Odiv (e1:::e2:::Enil) + | None => Eop Odiv (e1:::e2:::Enil) + end + | divu_default e2 => + Eop Odiv (e1:::e2:::Enil) + end. + +Definition mods := mod_aux Odiv. (* could be improved *) + + +(** ** Bitwise and, or, xor *) + +(* +Definition and (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Oshift s) (t1:::Enil), t2 => Eop (Oandshift s) (t2:::t1:::Enil) + | t1, Eop (Oshift s) (t2:::Enil) => Eop (Oandshift s) (t1:::t2:::Enil) + | Eop (Onotshift s) (t1:::Enil), t2 => Eop (Obicshift s) (t2:::t1:::Enil) + | t1, Eop (Onotshift s) (t2:::Enil) => Eop (Obicshift s) (t1:::t2:::Enil) + | Eop Onot (t1:::Enil), t2 => Eop Obic (t2:::t1:::Enil) + | t1, Eop Onot (t2:::Enil) => Eop Obic (t1:::t2:::Enil) + | _, _ => Eop Oand (e1:::e2:::Enil) + end. +*) + +Inductive and_cases: forall (e1: expr) (e2: expr), Set := + | and_case1: + forall s t1 t2, + and_cases (Eop (Oshift s) (t1:::Enil)) (t2) + | and_case2: + forall t1 s t2, + and_cases (t1) (Eop (Oshift s) (t2:::Enil)) + | and_case3: + forall s t1 t2, + and_cases (Eop (Onotshift s) (t1:::Enil)) (t2) + | and_case4: + forall t1 s t2, + and_cases (t1) (Eop (Onotshift s) (t2:::Enil)) + | and_case5: + forall t1 t2, + and_cases (Eop Onot (t1:::Enil)) (t2) + | and_case6: + forall t1 t2, + and_cases (t1) (Eop Onot (t2:::Enil)) + | and_default: + forall (e1: expr) (e2: expr), + and_cases e1 e2. + +Definition and_match (e1: expr) (e2: expr) := + match e1 as z1, e2 as z2 return and_cases z1 z2 with + | Eop (Oshift s) (t1:::Enil), t2 => + and_case1 s t1 t2 + | t1, Eop (Oshift s) (t2:::Enil) => + and_case2 t1 s t2 + | Eop (Onotshift s) (t1:::Enil), t2 => + and_case3 s t1 t2 + | t1, Eop (Onotshift s) (t2:::Enil) => + and_case4 t1 s t2 + | Eop Onot (t1:::Enil), t2 => + and_case5 t1 t2 + | t1, Eop Onot (t2:::Enil) => + and_case6 t1 t2 + | e1, e2 => + and_default e1 e2 + end. + +Definition and (e1: expr) (e2: expr) := + match and_match e1 e2 with + | and_case1 s t1 t2 => + Eop (Oandshift s) (t2:::t1:::Enil) + | and_case2 t1 s t2 => + Eop (Oandshift s) (t1:::t2:::Enil) + | and_case3 s t1 t2 => + Eop (Obicshift s) (t2:::t1:::Enil) + | and_case4 t1 s t2 => + Eop (Obicshift s) (t1:::t2:::Enil) + | and_case5 t1 t2 => + Eop Obic (t2:::t1:::Enil) + | and_case6 t1 t2 => + Eop Obic (t1:::t2:::Enil) + | and_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. + +(* +Definition or (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Oshift (Olsl n1) (t1:::Enil), Eop (Oshift (Olsr n2) (t2:::Enil)) => ... + | Eop (Oshift s) (t1:::Enil), t2 => Eop (Oorshift s) (t2:::t1:::Enil) + | t1, Eop (Oshift s) (t2:::Enil) => Eop (Oorshift s) (t1:::t2:::Enil) + | _, _ => Eop Oor (e1:::e2:::Enil) + end. +*) + +(* TODO: symmetric of first case *) + +Inductive or_cases: forall (e1: expr) (e2: expr), Set := + | or_case1: + forall n1 t1 n2 t2, + or_cases (Eop (Oshift (Slsl n1)) (t1:::Enil)) (Eop (Oshift (Slsr n2)) (t2:::Enil)) + | or_case2: + forall s t1 t2, + or_cases (Eop (Oshift s) (t1:::Enil)) (t2) + | or_case3: + forall t1 s t2, + or_cases (t1) (Eop (Oshift s) (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 (Oshift (Slsl n1)) (t1:::Enil), Eop (Oshift (Slsr n2)) (t2:::Enil) => + or_case1 n1 t1 n2 t2 + | Eop (Oshift s) (t1:::Enil), t2 => + or_case2 s t1 t2 + | t1, Eop (Oshift s) (t2:::Enil) => + or_case3 t1 s t2 + | e1, e2 => + or_default e1 e2 + end. + +Definition or (e1: expr) (e2: expr) := + match or_match e1 e2 with + | or_case1 n1 t1 n2 t2 => + if Int.eq (Int.add (s_amount n1) (s_amount n2)) (Int.repr 32) + && same_expr_pure t1 t2 + then Eop (Oshift (Sror n2)) (t1:::Enil) + else Eop (Oorshift (Slsr n2)) (e1:::t2:::Enil) + | or_case2 s t1 t2 => + Eop (Oorshift s) (t2:::t1:::Enil) + | or_case3 t1 s t2 => + Eop (Oorshift s) (t1:::t2:::Enil) + | or_default e1 e2 => + Eop Oor (e1:::e2:::Enil) + end. + +(* +Definition xor (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Oshift s) (t1:::Enil), t2 => Eop (Oxorshift s) (t2:::t1:::Enil) + | t1, Eop (Oshift s) (t2:::Enil) => Eop (Oxorshift s) (t1:::t2:::Enil) + | _, _ => Eop Oxor (e1:::e2:::Enil) + end. +*) + +Inductive xor_cases: forall (e1: expr) (e2: expr), Set := + | xor_case1: + forall s t1 t2, + xor_cases (Eop (Oshift s) (t1:::Enil)) (t2) + | xor_case2: + forall t1 s t2, + xor_cases (t1) (Eop (Oshift s) (t2:::Enil)) + | xor_default: + forall (e1: expr) (e2: expr), + xor_cases e1 e2. + +Definition xor_match (e1: expr) (e2: expr) := + match e1 as z1, e2 as z2 return xor_cases z1 z2 with + | Eop (Oshift s) (t1:::Enil), t2 => + xor_case1 s t1 t2 + | t1, Eop (Oshift s) (t2:::Enil) => + xor_case2 t1 s t2 + | e1, e2 => + xor_default e1 e2 + end. + +Definition xor (e1: expr) (e2: expr) := + match xor_match e1 e2 with + | xor_case1 s t1 t2 => + Eop (Oxorshift s) (t2:::t1:::Enil) + | xor_case2 t1 s t2 => + Eop (Oxorshift s) (t1:::t2:::Enil) + | xor_default e1 e2 => + Eop Oxor (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. + +Definition shr (e1: expr) (e2: expr) := + match shift_match e2 with + | shift_case1 n2 => + shrimm e1 n2 + | shift_default e2 => + Eop Oshr (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. + +(** ** Comparisons *) + +(* +Definition comp (e1: expr) (e2: expr) := + match e1, e2 with + | Eop (Ointconst n1) Enil, t2 => Eop (Ocmp (Ccompimm (swap_comparison c) n1)) (t2:::Enil) + | t1, Eop (Ointconst n2) Enil => Eop (Ocmp (Ccompimm c n1)) (t1:::Enil) + | Eop (Oshift s) (t1:::Enil), t2 => Eop (Ocmp (Ccompshift (swap_comparison c) s)) (t2:::t1:::Enil) + | t1, Eop (Oshift s) (t2:::Enil) => Eop (Ocmp (Ccompshift c s)) (t1:::t2:::Enil) + | _, _ => Eop (Ocmp (Ccomp c)) (e1:::e2:::Enil) + end. +*) + +Inductive comp_cases: forall (e1: expr) (e2: expr), Set := + | comp_case1: + forall n1 t2, + comp_cases (Eop (Ointconst n1) Enil) (t2) + | comp_case2: + forall t1 n2, + comp_cases (t1) (Eop (Ointconst n2) Enil) + | comp_case3: + forall s t1 t2, + comp_cases (Eop (Oshift s) (t1:::Enil)) (t2) + | comp_case4: + forall t1 s t2, + comp_cases (t1) (Eop (Oshift s) (t2:::Enil)) + | comp_default: + forall (e1: expr) (e2: expr), + comp_cases e1 e2. + +Definition comp_match (e1: expr) (e2: expr) := + match e1 as z1, e2 as z2 return comp_cases z1 z2 with + | Eop (Ointconst n1) Enil, t2 => + comp_case1 n1 t2 + | t1, Eop (Ointconst n2) Enil => + comp_case2 t1 n2 + | Eop (Oshift s) (t1:::Enil), t2 => + comp_case3 s t1 t2 + | t1, Eop (Oshift s) (t2:::Enil) => + comp_case4 t1 s t2 + | e1, e2 => + comp_default e1 e2 + end. + +Definition comp (c: comparison) (e1: expr) (e2: expr) := + match comp_match e1 e2 with + | comp_case1 n1 t2 => + Eop (Ocmp (Ccompimm (swap_comparison c) n1)) (t2:::Enil) + | comp_case2 t1 n2 => + Eop (Ocmp (Ccompimm c n2)) (t1:::Enil) + | comp_case3 s t1 t2 => + Eop (Ocmp (Ccompshift (swap_comparison c) s)) (t2:::t1:::Enil) + | comp_case4 t1 s t2 => + Eop (Ocmp (Ccompshift c s)) (t1:::t2:::Enil) + | comp_default e1 e2 => + Eop (Ocmp (Ccomp c)) (e1:::e2:::Enil) + end. + +Definition compu (c: comparison) (e1: expr) (e2: expr) := + match comp_match e1 e2 with + | comp_case1 n1 t2 => + Eop (Ocmp (Ccompuimm (swap_comparison c) n1)) (t2:::Enil) + | comp_case2 t1 n2 => + Eop (Ocmp (Ccompuimm c n2)) (t1:::Enil) + | comp_case3 s t1 t2 => + Eop (Ocmp (Ccompushift (swap_comparison c) s)) (t2:::t1:::Enil) + | comp_case4 t1 s t2 => + Eop (Ocmp (Ccompushift c s)) (t1:::t2:::Enil) + | comp_default e1 e2 => + Eop (Ocmp (Ccompu c)) (e1:::e2:::Enil) + end. + +Definition compf (c: comparison) (e1: expr) (e2: expr) := + Eop (Ocmp (Ccompf c)) (e1 ::: e2 ::: Enil). + +(** ** Conditional expressions *) + +Fixpoint negate_condexpr (e: condexpr): condexpr := + match e with + | CEtrue => CEfalse + | CEfalse => CEtrue + | CEcond c el => CEcond (negate_condition c) el + | CEcondition e1 e2 e3 => + CEcondition e1 (negate_condexpr e2) (negate_condexpr e3) + end. + + +Definition is_compare_neq_zero (c: condition) : bool := + match c with + | Ccompimm Cne n => Int.eq n Int.zero + | Ccompuimm Cne n => Int.eq n Int.zero + | _ => false + end. + +Definition is_compare_eq_zero (c: condition) : bool := + match c with + | Ccompimm Ceq n => Int.eq n Int.zero + | Ccompuimm Ceq n => Int.eq n Int.zero + | _ => false + end. + +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) (e1 ::: Enil) => + if is_compare_neq_zero c then + condexpr_of_expr e1 + else if is_compare_eq_zero c then + negate_condexpr (condexpr_of_expr e1) + else + CEcond c (e1 ::: Enil) + | Eop (Ocmp c) el => + CEcond c el + | Econdition ce e1 e2 => + CEcondition ce (condexpr_of_expr e1) (condexpr_of_expr e2) + | _ => + 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 (Oaddrstack n) Enil => (Ainstack n, Enil) + | Eop (Oaddimm n) (e1:::Enil) => (Aindexed n, e1:::Enil) + | Eop (Oaddshift s) (e1:::e2:::Enil) => (Aindexed2shift s, e1:::e2:::Enil) + | Eop Oadd (e1:::e2:::Enil) => (Aindexed2, e1:::e2:::Enil) + | _ => (Aindexed Int.zero, e:::Enil) + end. +*) + +Inductive addressing_cases: forall (e: expr), Set := + | addressing_case2: + forall n, + addressing_cases (Eop (Oaddrstack n) Enil) + | addressing_case3: + forall n e1, + addressing_cases (Eop (Oaddimm n) (e1:::Enil)) + | addressing_case4: + forall s e1 e2, + addressing_cases (Eop (Oaddshift s) (e1:::e2:::Enil)) + | addressing_case5: + forall e1 e2, + 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 (Oaddrstack n) Enil => + addressing_case2 n + | Eop (Oaddimm n) (e1:::Enil) => + addressing_case3 n e1 + | Eop (Oaddshift s) (e1:::e2:::Enil) => + addressing_case4 s e1 e2 + | Eop Oadd (e1:::e2:::Enil) => + addressing_case5 e1 e2 + | e => + addressing_default e + end. + +(** We do not recognize the [Aindexed2] and [Aindexed2shift] modes + for floating-point accesses, since these are not supported + by the hardware and emulated inefficiently in [ARMgen]. *) + +Definition is_float_addressing (chunk: memory_chunk): bool := + match chunk with + | Mfloat32 => true + | Mfloat64 => true + | _ => false + end. + +Definition addressing (chunk: memory_chunk) (e: expr) := + match addressing_match e with + | addressing_case2 n => + (Ainstack n, Enil) + | addressing_case3 n e1 => + (Aindexed n, e1:::Enil) + | addressing_case4 s e1 e2 => + if is_float_addressing chunk + then (Aindexed Int.zero, Eop (Oaddshift s) (e1:::e2:::Enil) ::: Enil) + else (Aindexed2shift s, e1:::e2:::Enil) + | addressing_case5 e1 e2 => + if is_float_addressing chunk + then (Aindexed Int.zero, Eop Oadd (e1:::e2:::Enil) ::: Enil) + else (Aindexed2, e1:::e2:::Enil) + | addressing_default e => + (Aindexed Int.zero, e:::Enil) + end. + +Definition load (chunk: memory_chunk) (e1: expr) := + match addressing chunk e1 with + | (mode, args) => Eload chunk mode args + end. + +Definition store (chunk: memory_chunk) (e1 e2: expr) := + match addressing chunk e1 with + | (mode, args) => Sstore 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 (Orsubimm 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.Ointuoffloat => Eop Ointuoffloat (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 => xor arg1 arg2 + | Cminor.Oshl => shl arg1 arg2 + | Cminor.Oshr => shr arg1 arg2 + | Cminor.Oshru => shru arg1 arg2 + | Cminor.Oaddf => Eop Oaddf (arg1 ::: arg2 ::: Enil) + | Cminor.Osubf => Eop Osubf (arg1 ::: arg2 ::: Enil) + | Cminor.Omulf => Eop Omulf (arg1 ::: arg2 ::: Enil) + | Cminor.Odivf => Eop Odivf (arg1 ::: arg2 ::: Enil) + | Cminor.Ocmp c => comp c arg1 arg2 + | Cminor.Ocmpu c => compu c arg1 arg2 + | Cminor.Ocmpf c => compf c arg1 arg2 + 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.Econdition cond ifso ifnot => + Econdition (condexpr_of_expr (sel_expr cond)) + (sel_expr ifso) (sel_expr ifnot) + end. + +Fixpoint sel_exprlist (al: list Cminor.expr) : exprlist := + match al with + | nil => Enil + | 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.Sassign id e => Sassign id (sel_expr e) + | Cminor.Sstore chunk addr rhs => store chunk (sel_expr addr) (sel_expr rhs) + | Cminor.Scall optid sg fn args => + Scall optid sg (sel_expr fn) (sel_exprlist args) + | Cminor.Stailcall sg fn args => + Stailcall sg (sel_expr fn) (sel_exprlist args) + | Cminor.Salloc id b => Salloc id (sel_expr b) + | 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.Slabel lbl body => Slabel lbl (sel_stmt body) + | Cminor.Sgoto lbl => Sgoto lbl + 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/arm/Selectionproof.v b/arm/Selectionproof.v new file mode 100644 index 0000000..e487d15 --- /dev/null +++ b/arm/Selectionproof.v @@ -0,0 +1,1475 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** 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 Smallstep. +Require Import Cminor. +Require Import Op. +Require Import CminorSel. +Require Import Selection. + +Open Local Scope selection_scope. + +Section CMCONSTR. + +Variable ge: genv. +Variable sp: val. +Variable e: env. +Variable m: mem. + +(** * 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. + +Hint Resolve eval_Evar eval_Eop eval_Eload eval_Econdition + eval_Elet eval_Eletvar + eval_CEtrue eval_CEfalse eval_CEcond + eval_CEcondition eval_Enil eval_Econs: evalexpr. + +Lemma eval_lift_expr: + forall w le a v, + eval_expr ge sp e m le a v -> + forall p le', insert_lenv le p w le' -> + eval_expr ge sp e m le' (lift_expr p a) v. +Proof. + intro w. + apply (eval_expr_ind3 ge sp e m + (fun le a v => + forall p le', insert_lenv le p w le' -> + eval_expr ge sp e m le' (lift_expr p a) v) + (fun le a v => + forall p le', insert_lenv le p w le' -> + eval_condexpr ge sp e m le' (lift_condexpr p a) v) + (fun le al vl => + forall p le', insert_lenv le p w le' -> + eval_exprlist ge sp e m le' (lift_exprlist p al) 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. + + 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 le a v w, + eval_expr ge sp e m le a v -> + eval_expr ge sp e m (w::le) (lift a) 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. + +Ltac InvEval1 := + match goal with + | [ H: (eval_expr _ _ _ _ _ (Eop _ Enil) _) |- _ ] => + inv H; InvEval1 + | [ H: (eval_expr _ _ _ _ _ (Eop _ (_ ::: Enil)) _) |- _ ] => + inv H; InvEval1 + | [ H: (eval_expr _ _ _ _ _ (Eop _ (_ ::: _ ::: Enil)) _) |- _ ] => + inv H; InvEval1 + | [ H: (eval_exprlist _ _ _ _ _ Enil _) |- _ ] => + inv H; InvEval1 + | [ H: (eval_exprlist _ _ _ _ _ (_ ::: _) _) |- _ ] => + inv H; InvEval1 + | _ => + idtac + end. + +Ltac InvEval2 := + match goal with + | [ H: (eval_operation _ _ _ nil _ = Some _) |- _ ] => + simpl in H; inv H + | [ H: (eval_operation _ _ _ (_ :: nil) _ = Some _) |- _ ] => + simpl in H; FuncInv + | [ H: (eval_operation _ _ _ (_ :: _ :: nil) _ = Some _) |- _ ] => + simpl in H; FuncInv + | [ H: (eval_operation _ _ _ (_ :: _ :: _ :: nil) _ = Some _) |- _ ] => + simpl in H; FuncInv + | _ => + idtac + end. + +Ltac InvEval := InvEval1; InvEval2; InvEval2. + +(** * 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. +*) + +Theorem eval_notint: + forall le a x, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le (notint a) (Vint (Int.not x)). +Proof. + unfold notint; intros until x; case (notint_match a); intros; InvEval. + EvalOp. simpl. congruence. + subst x. rewrite Int.not_involutive. auto. + EvalOp. simpl. subst x. rewrite Int.not_involutive. auto. + EvalOp. +Qed. + +Lemma eval_notbool_base: + forall le a v b, + eval_expr ge sp e m le a v -> + Val.bool_of_val v b -> + eval_expr ge sp e m le (notbool_base a) (Val.of_bool (negb b)). +Proof. + TrivialOp notbool_base. simpl. + inv 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 le a v b, + eval_expr ge sp e m le a v -> + Val.bool_of_val v b -> + eval_expr ge sp e m le (notbool a) (Val.of_bool (negb b)). +Proof. + induction a; simpl; intros; try (eapply eval_notbool_base; eauto). + destruct o; try (eapply eval_notbool_base; eauto). + + destruct e0. InvEval. + inv H0. rewrite Int.eq_false; auto. + simpl; eauto with evalexpr. + rewrite Int.eq_true; simpl; eauto with evalexpr. + eapply eval_notbool_base; eauto. + + inv H. eapply eval_Eop; eauto. + simpl. assert (eval_condition c vl m = Some b). + generalize H6. simpl. + case (eval_condition c vl m); intros. + destruct b0; inv H1; inversion H0; auto; congruence. + congruence. + rewrite (Op.eval_negate_condition _ _ _ H). + destruct b; reflexivity. + + inv H. eapply eval_Econdition; eauto. + destruct v1; eauto. +Qed. + +Theorem eval_addimm: + forall le n a x, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le (addimm n a) (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; EvalOp; simpl. + rewrite Int.add_commut. auto. + destruct (Genv.find_symbol ge s); discriminate. + destruct sp; simpl in H1; discriminate. + subst x. rewrite Int.add_assoc. decEq; decEq; decEq. apply Int.add_commut. +Qed. + +Theorem eval_addimm_ptr: + forall le n a b ofs, + eval_expr ge sp e m le a (Vptr b ofs) -> + eval_expr ge sp e m le (addimm n a) (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; EvalOp; simpl. + destruct (Genv.find_symbol ge s). + rewrite Int.add_commut. congruence. + discriminate. + destruct sp; simpl in H1; try discriminate. + inv H1. simpl. decEq. decEq. + rewrite Int.add_assoc. decEq. apply Int.add_commut. + subst. rewrite (Int.add_commut n m0). rewrite Int.add_assoc. auto. +Qed. + +Theorem eval_add: + forall le a b x y, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le b (Vint y) -> + eval_expr ge sp e m le (add a b) (Vint (Int.add x y)). +Proof. + intros until y. + unfold add; case (add_match a b); intros; InvEval. + rewrite Int.add_commut. apply eval_addimm. auto. + replace (Int.add x y) with (Int.add (Int.add i0 i) (Int.add n1 n2)). + apply eval_addimm. EvalOp. + subst x; subst y. + repeat rewrite Int.add_assoc. decEq. apply Int.add_permut. + 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. + apply eval_addimm. auto. + 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. simpl. subst x. rewrite Int.add_commut. auto. + EvalOp. simpl. congruence. + EvalOp. +Qed. + +Theorem eval_add_ptr: + forall le a b p x y, + eval_expr ge sp e m le a (Vptr p x) -> + eval_expr ge sp e m le b (Vint y) -> + eval_expr ge sp e m le (add a b) (Vptr p (Int.add x y)). +Proof. + intros until y. unfold add; case (add_match a b); intros; InvEval. + replace (Int.add x y) 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. apply Int.add_permut. + 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. + apply eval_addimm_ptr. auto. + 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. simpl. congruence. + EvalOp. +Qed. + +Theorem eval_add_ptr_2: + forall le a b x p y, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le b (Vptr p y) -> + eval_expr ge sp e m le (add a b) (Vptr p (Int.add y x)). +Proof. + intros until y. unfold add; case (add_match a b); intros; InvEval. + apply eval_addimm_ptr. auto. + replace (Int.add y x) 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. + rewrite (Int.add_commut n1 n2). apply Int.add_permut. + 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. + 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. simpl. congruence. + EvalOp. +Qed. + +Theorem eval_sub: + forall le a b x y, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le b (Vint y) -> + eval_expr ge sp e m le (sub a b) (Vint (Int.sub x y)). +Proof. + intros until y. + unfold sub; case (sub_match a b); intros; InvEval. + rewrite Int.sub_add_opp. + apply eval_addimm. assumption. + replace (Int.sub x y) with (Int.add (Int.sub i0 i) (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. + 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. + 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. + EvalOp. simpl. congruence. + EvalOp. simpl. congruence. + EvalOp. +Qed. + +Theorem eval_sub_ptr_int: + forall le a b p x y, + eval_expr ge sp e m le a (Vptr p x) -> + eval_expr ge sp e m le b (Vint y) -> + eval_expr ge sp e m le (sub a b) (Vptr p (Int.sub x y)). +Proof. + intros until y. + unfold sub; case (sub_match a b); intros; InvEval. + rewrite Int.sub_add_opp. + apply eval_addimm_ptr. assumption. + subst b0. replace (Int.sub x y) with (Int.add (Int.sub i0 i) (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. + 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. + 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. simpl. congruence. + EvalOp. +Qed. + +Theorem eval_sub_ptr_ptr: + forall le a b p x y, + eval_expr ge sp e m le a (Vptr p x) -> + eval_expr ge sp e m le b (Vptr p y) -> + eval_expr ge sp e m le (sub a b) (Vint (Int.sub x y)). +Proof. + intros until y. + unfold sub; case (sub_match a b); intros; InvEval. + replace (Int.sub x y) with (Int.add (Int.sub i0 i) (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. + 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. + 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. + +Theorem eval_shlimm: + forall le a n x, + eval_expr ge sp e m le a (Vint x) -> + Int.ltu n (Int.repr 32) = true -> + eval_expr ge sp e m le (shlimm a n) (Vint (Int.shl x n)). +Proof. + intros until x. unfold shlimm, is_shift_amount. + generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intro. + intros. subst n. rewrite Int.shl_zero. auto. + destruct (is_shift_amount_aux n). simpl. + case (shlimm_match a); intros; InvEval. + EvalOp. + destruct (is_shift_amount_aux (Int.add n (s_amount n1))). + EvalOp. simpl. subst x. + decEq. decEq. symmetry. rewrite Int.add_commut. apply Int.shl_shl. + apply s_amount_ltu. auto. + rewrite Int.add_commut. auto. + EvalOp. econstructor. EvalOp. simpl. reflexivity. constructor. + simpl. congruence. + EvalOp. + congruence. +Qed. + +Theorem eval_shruimm: + forall le a n x, + eval_expr ge sp e m le a (Vint x) -> + Int.ltu n (Int.repr 32) = true -> + eval_expr ge sp e m le (shruimm a n) (Vint (Int.shru x n)). +Proof. + intros until x. unfold shruimm, is_shift_amount. + generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intro. + intros. subst n. rewrite Int.shru_zero. auto. + destruct (is_shift_amount_aux n). simpl. + case (shruimm_match a); intros; InvEval. + EvalOp. + destruct (is_shift_amount_aux (Int.add n (s_amount n1))). + EvalOp. simpl. subst x. + decEq. decEq. symmetry. rewrite Int.add_commut. apply Int.shru_shru. + apply s_amount_ltu. auto. + rewrite Int.add_commut. auto. + EvalOp. econstructor. EvalOp. simpl. reflexivity. constructor. + simpl. congruence. + EvalOp. + congruence. +Qed. + +Theorem eval_shrimm: + forall le a n x, + eval_expr ge sp e m le a (Vint x) -> + Int.ltu n (Int.repr 32) = true -> + eval_expr ge sp e m le (shrimm a n) (Vint (Int.shr x n)). +Proof. + intros until x. unfold shrimm, is_shift_amount. + generalize (Int.eq_spec n Int.zero); case (Int.eq n Int.zero); intro. + intros. subst n. rewrite Int.shr_zero. auto. + destruct (is_shift_amount_aux n). simpl. + case (shrimm_match a); intros; InvEval. + EvalOp. + destruct (is_shift_amount_aux (Int.add n (s_amount n1))). + EvalOp. simpl. subst x. + decEq. decEq. symmetry. rewrite Int.add_commut. apply Int.shr_shr. + apply s_amount_ltu. auto. + rewrite Int.add_commut. auto. + EvalOp. econstructor. EvalOp. simpl. reflexivity. constructor. + simpl. congruence. + EvalOp. + congruence. +Qed. + +Lemma eval_mulimm_base: + forall le a n x, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le (mulimm_base n a) (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. constructor. EvalOp. simpl; reflexivity. + constructor. eauto. constructor. simpl. rewrite Int.mul_commut. auto. + 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 (Vint x). auto. + rewrite H1. simpl. rewrite Int.add_zero. + rewrite Int.mul_add_distr_r. + rewrite <- Int.shl_mul. + rewrite <- Int.shl_mul. + apply eval_add. + apply eval_shlimm. apply eval_Eletvar. simpl. reflexivity. + auto with coqlib. + apply eval_shlimm. apply eval_Eletvar. simpl. reflexivity. + auto with coqlib. + intros. EvalOp. constructor. EvalOp. simpl; reflexivity. + constructor. eauto. constructor. simpl. rewrite Int.mul_commut. auto. +Qed. + +Theorem eval_mulimm: + forall le a n x, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le (mulimm n a) (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. EvalOp. + 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. + EvalOp. rewrite Int.mul_commut. reflexivity. + 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 le a b x y, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le b (Vint y) -> + eval_expr ge sp e m le (mul a b) (Vint (Int.mul x y)). +Proof. + intros until y. + unfold mul; case (mul_match a b); intros; InvEval. + rewrite Int.mul_commut. apply eval_mulimm. auto. + apply eval_mulimm. auto. + EvalOp. +Qed. + +Theorem eval_divs_base: + forall le a b x y, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le b (Vint y) -> + y <> Int.zero -> + eval_expr ge sp e m le (Eop Odiv (a ::: b ::: Enil)) (Vint (Int.divs x y)). +Proof. + intros. EvalOp; simpl. + predSpec Int.eq Int.eq_spec y Int.zero. contradiction. auto. +Qed. + +Theorem eval_divs: + forall le a x b y, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le b (Vint y) -> + y <> Int.zero -> + eval_expr ge sp e m le (divs a b) (Vint (Int.divs x y)). +Proof. + intros until y. + unfold divs; case (divu_match b); intros; InvEval. + caseEq (Int.is_power2 y); intros. + caseEq (Int.ltu i (Int.repr 31)); intros. + EvalOp. simpl. unfold Int.ltu. rewrite zlt_true. + rewrite (Int.divs_pow2 x y i H0). auto. + exploit Int.ltu_inv; eauto. + change (Int.unsigned (Int.repr 31)) with 31. + change (Int.unsigned (Int.repr 32)) with 32. + omega. + apply eval_divs_base. auto. EvalOp. auto. + apply eval_divs_base. auto. EvalOp. auto. + apply eval_divs_base; 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 le a b x y, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le b (Vint y) -> + y <> Int.zero -> + eval_expr ge sp e m le (mod_aux divop a b) + (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. + apply H. assumption. + eapply eval_Econs. apply eval_Eletvar. simpl; reflexivity. + apply eval_Enil. + simpl; reflexivity. apply eval_Enil. + reflexivity. +Qed. + +Theorem eval_mods: + forall le a b x y, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le b (Vint y) -> + y <> Int.zero -> + eval_expr ge sp e m le (mods a b) (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 le a x b y, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le b (Vint y) -> + y <> Int.zero -> + eval_expr ge sp e m le (Eop Odivu (a ::: b ::: Enil)) (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 le a x b y, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le b (Vint y) -> + y <> Int.zero -> + eval_expr ge sp e m le (divu a b) (Vint (Int.divu x y)). +Proof. + intros until y. + unfold divu; case (divu_match b); intros; InvEval. + caseEq (Int.is_power2 y). + intros. rewrite (Int.divu_pow2 x y i H0). + apply eval_shruimm. auto. + apply Int.is_power2_range with y. auto. + intros. apply eval_divu_base. auto. EvalOp. auto. + eapply eval_divu_base; eauto. +Qed. + +Theorem eval_modu: + forall le a x b y, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le b (Vint y) -> + y <> Int.zero -> + eval_expr ge sp e m le (modu a b) (Vint (Int.modu x y)). +Proof. + intros until y; unfold modu; case (divu_match b); intros; InvEval. + caseEq (Int.is_power2 y). + intros. rewrite (Int.modu_and x y i H0). + EvalOp. + intro. rewrite Int.modu_divu. eapply eval_mod_aux. + intros. simpl. predSpec Int.eq Int.eq_spec y0 Int.zero. + contradiction. auto. + auto. EvalOp. auto. auto. + rewrite Int.modu_divu. eapply eval_mod_aux. + intros. simpl. predSpec Int.eq Int.eq_spec y0 Int.zero. + contradiction. auto. auto. auto. auto. auto. +Qed. + +Theorem eval_and: + forall le a x b y, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le b (Vint y) -> + eval_expr ge sp e m le (and a b) (Vint (Int.and x y)). +Proof. + intros until y; unfold and; case (and_match a b); intros; InvEval. + rewrite Int.and_commut. EvalOp. simpl. congruence. + EvalOp. simpl. congruence. + rewrite Int.and_commut. EvalOp. simpl. congruence. + EvalOp. simpl. congruence. + rewrite Int.and_commut. EvalOp. simpl. congruence. + EvalOp. simpl. congruence. + EvalOp. +Qed. + +Remark eval_same_expr: + forall a1 a2 le v1 v2, + same_expr_pure a1 a2 = true -> + eval_expr ge sp e m le a1 v1 -> + eval_expr ge sp e m le a2 v2 -> + a1 = a2 /\ v1 = v2. +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. split. auto. congruence. + discriminate. +Qed. + +Lemma eval_or: + forall le a x b y, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le b (Vint y) -> + eval_expr ge sp e m le (or a b) (Vint (Int.or x y)). +Proof. + intros until y; unfold or; case (or_match a b); intros; InvEval. + caseEq (Int.eq (Int.add (s_amount n1) (s_amount n2)) (Int.repr 32) + && same_expr_pure t1 t2); intro. + destruct (andb_prop _ _ H1). + generalize (Int.eq_spec (Int.add (s_amount n1) (s_amount n2)) (Int.repr 32)). + rewrite H4. intro. + exploit eval_same_expr; eauto. intros [EQ1 EQ2]. inv EQ1. inv EQ2. + simpl. EvalOp. simpl. decEq. decEq. apply Int.or_ror. + destruct n1; auto. destruct n2; auto. auto. + EvalOp. econstructor. EvalOp. simpl. reflexivity. + econstructor; eauto with evalexpr. + simpl. congruence. + EvalOp. simpl. rewrite Int.or_commut. congruence. + EvalOp. simpl. congruence. + EvalOp. +Qed. + +Theorem eval_xor: + forall le a x b y, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le b (Vint y) -> + eval_expr ge sp e m le (xor a b) (Vint (Int.xor x y)). +Proof. + intros until y; unfold xor; case (xor_match a b); intros; InvEval. + rewrite Int.xor_commut. EvalOp. simpl. congruence. + EvalOp. simpl. congruence. + EvalOp. +Qed. + +Theorem eval_shl: + forall le a x b y, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le b (Vint y) -> + Int.ltu y (Int.repr 32) = true -> + eval_expr ge sp e m le (shl a b) (Vint (Int.shl x y)). +Proof. + intros until y; unfold shl; case (shift_match b); intros. + InvEval. apply eval_shlimm; auto. + EvalOp. simpl. rewrite H1. auto. +Qed. + +Theorem eval_shru: + forall le a x b y, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le b (Vint y) -> + Int.ltu y (Int.repr 32) = true -> + eval_expr ge sp e m le (shru a b) (Vint (Int.shru x y)). +Proof. + intros until y; unfold shru; case (shift_match b); intros. + InvEval. apply eval_shruimm; auto. + EvalOp. simpl. rewrite H1. auto. +Qed. + +Theorem eval_shr: + forall le a x b y, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le b (Vint y) -> + Int.ltu y (Int.repr 32) = true -> + eval_expr ge sp e m le (shr a b) (Vint (Int.shr x y)). +Proof. + intros until y; unfold shr; case (shift_match b); intros. + InvEval. apply eval_shrimm; auto. + EvalOp. simpl. rewrite H1. auto. +Qed. + +Theorem eval_cast8signed: + forall le a v, + eval_expr ge sp e m le a v -> + eval_expr ge sp e m le (cast8signed a) (Val.sign_ext 8 v). +Proof. + intros until v; unfold cast8signed; case (cast8signed_match a); intros; InvEval. + EvalOp. simpl. subst v. destruct v1; simpl; auto. + rewrite Int.sign_ext_idem. reflexivity. vm_compute; auto. + EvalOp. +Qed. + +Theorem eval_cast8unsigned: + forall le a v, + eval_expr ge sp e m le a v -> + eval_expr ge sp e m le (cast8unsigned a) (Val.zero_ext 8 v). +Proof. + intros until v; unfold cast8unsigned; case (cast8unsigned_match a); intros; InvEval. + EvalOp. simpl. subst v. destruct v1; simpl; auto. + rewrite Int.zero_ext_idem. reflexivity. vm_compute; auto. + EvalOp. +Qed. + +Theorem eval_cast16signed: + forall le a v, + eval_expr ge sp e m le a v -> + eval_expr ge sp e m le (cast16signed a) (Val.sign_ext 16 v). +Proof. + intros until v; unfold cast16signed; case (cast16signed_match a); intros; InvEval. + EvalOp. simpl. subst v. destruct v1; simpl; auto. + rewrite Int.sign_ext_idem. reflexivity. vm_compute; auto. + EvalOp. +Qed. + +Theorem eval_cast16unsigned: + forall le a v, + eval_expr ge sp e m le a v -> + eval_expr ge sp e m le (cast16unsigned a) (Val.zero_ext 16 v). +Proof. + intros until v; unfold cast16unsigned; case (cast16unsigned_match a); intros; InvEval. + EvalOp. simpl. subst v. destruct v1; simpl; auto. + rewrite Int.zero_ext_idem. reflexivity. vm_compute; auto. + EvalOp. +Qed. + +Theorem eval_singleoffloat: + forall le a v, + eval_expr ge sp e m le a v -> + eval_expr ge sp e m le (singleoffloat a) (Val.singleoffloat v). +Proof. + intros until v; unfold singleoffloat; case (singleoffloat_match a); intros; InvEval. + EvalOp. simpl. subst v. destruct v1; simpl; auto. rewrite Float.singleoffloat_idem. reflexivity. + EvalOp. +Qed. + +Theorem eval_comp_int: + forall le c a x b y, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le b (Vint y) -> + eval_expr ge sp e m le (comp c a b) (Val.of_bool(Int.cmp c x y)). +Proof. + intros until y. + unfold comp; case (comp_match a b); intros; InvEval. + EvalOp. simpl. rewrite Int.swap_cmp. destruct (Int.cmp c x y); reflexivity. + EvalOp. simpl. destruct (Int.cmp c x y); reflexivity. + EvalOp. simpl. rewrite Int.swap_cmp. rewrite H. destruct (Int.cmp c x y); reflexivity. + EvalOp. simpl. rewrite H0. destruct (Int.cmp c x y); reflexivity. + EvalOp. simpl. destruct (Int.cmp c x y); reflexivity. +Qed. + +Remark eval_compare_null_trans: + forall c x v, + (if Int.eq x Int.zero then Cminor.eval_compare_mismatch c else None) = Some v -> + match eval_compare_null c x with + | Some true => Some Vtrue + | Some false => Some Vfalse + | None => None (A:=val) + end = Some v. +Proof. + unfold Cminor.eval_compare_mismatch, eval_compare_null; intros. + destruct (Int.eq x Int.zero); try discriminate. + destruct c; try discriminate; auto. +Qed. + +Theorem eval_comp_ptr_int: + forall le c a x1 x2 b y v, + eval_expr ge sp e m le a (Vptr x1 x2) -> + eval_expr ge sp e m le b (Vint y) -> + (if Int.eq y Int.zero then Cminor.eval_compare_mismatch c else None) = Some v -> + eval_expr ge sp e m le (comp c a b) v. +Proof. + intros until v. + unfold comp; case (comp_match a b); intros; InvEval. + EvalOp. simpl. apply eval_compare_null_trans; auto. + EvalOp. simpl. rewrite H0. apply eval_compare_null_trans; auto. + EvalOp. simpl. apply eval_compare_null_trans; auto. +Qed. + +Remark eval_swap_compare_null_trans: + forall c x v, + (if Int.eq x Int.zero then Cminor.eval_compare_mismatch c else None) = Some v -> + match eval_compare_null (swap_comparison c) x with + | Some true => Some Vtrue + | Some false => Some Vfalse + | None => None (A:=val) + end = Some v. +Proof. + unfold Cminor.eval_compare_mismatch, eval_compare_null; intros. + destruct (Int.eq x Int.zero); try discriminate. + destruct c; simpl; try discriminate; auto. +Qed. + +Theorem eval_comp_int_ptr: + forall le c a x b y1 y2 v, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le b (Vptr y1 y2) -> + (if Int.eq x Int.zero then Cminor.eval_compare_mismatch c else None) = Some v -> + eval_expr ge sp e m le (comp c a b) v. +Proof. + intros until v. + unfold comp; case (comp_match a b); intros; InvEval. + EvalOp. simpl. apply eval_swap_compare_null_trans; auto. + EvalOp. simpl. rewrite H. apply eval_swap_compare_null_trans; auto. + EvalOp. simpl. apply eval_compare_null_trans; auto. +Qed. + +Theorem eval_comp_ptr_ptr: + forall le c a x1 x2 b y1 y2, + eval_expr ge sp e m le a (Vptr x1 x2) -> + eval_expr ge sp e m le b (Vptr y1 y2) -> + valid_pointer m x1 (Int.signed x2) && + valid_pointer m y1 (Int.signed y2) = true -> + x1 = y1 -> + eval_expr ge sp e m le (comp c a b) (Val.of_bool(Int.cmp c x2 y2)). +Proof. + intros until y2. + unfold comp; case (comp_match a b); intros; InvEval. + EvalOp. simpl. rewrite H1. simpl. + subst y1. rewrite dec_eq_true. + destruct (Int.cmp c x2 y2); reflexivity. +Qed. + +Theorem eval_comp_ptr_ptr_2: + forall le c a x1 x2 b y1 y2 v, + eval_expr ge sp e m le a (Vptr x1 x2) -> + eval_expr ge sp e m le b (Vptr y1 y2) -> + valid_pointer m x1 (Int.signed x2) && + valid_pointer m y1 (Int.signed y2) = true -> + x1 <> y1 -> + Cminor.eval_compare_mismatch c = Some v -> + eval_expr ge sp e m le (comp c a b) v. +Proof. + intros until y2. + unfold comp; case (comp_match a b); intros; InvEval. + EvalOp. simpl. rewrite H1. rewrite dec_eq_false; auto. + destruct c; simpl in H3; inv H3; auto. +Qed. + + +Theorem eval_compu: + forall le c a x b y, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le b (Vint y) -> + eval_expr ge sp e m le (compu c a b) (Val.of_bool(Int.cmpu c x y)). +Proof. + intros until y. + unfold compu; case (comp_match a b); intros; InvEval. + EvalOp. simpl. rewrite Int.swap_cmpu. destruct (Int.cmpu c x y); reflexivity. + EvalOp. simpl. destruct (Int.cmpu c x y); reflexivity. + EvalOp. simpl. rewrite H. rewrite Int.swap_cmpu. destruct (Int.cmpu c x y); reflexivity. + EvalOp. simpl. rewrite H0. destruct (Int.cmpu c x y); reflexivity. + EvalOp. simpl. destruct (Int.cmpu c x y); reflexivity. +Qed. + +Theorem eval_compf: + forall le c a x b y, + eval_expr ge sp e m le a (Vfloat x) -> + eval_expr ge sp e m le b (Vfloat y) -> + eval_expr ge sp e m le (compf c a b) (Val.of_bool(Float.cmp c x y)). +Proof. + intros. unfold compf. EvalOp. simpl. + destruct (Float.cmp c x y); reflexivity. +Qed. + +Lemma negate_condexpr_correct: + forall le a b, + eval_condexpr ge sp e m le a b -> + eval_condexpr ge sp e m le (negate_condexpr a) (negb b). +Proof. + induction 1; simpl. + constructor. + constructor. + econstructor. eauto. apply eval_negate_condition. auto. + econstructor. eauto. destruct vb1; auto. +Qed. + +Scheme expr_ind2 := Induction for expr Sort Prop + with exprlist_ind2 := Induction for exprlist Sort Prop. + +Fixpoint forall_exprlist (P: expr -> Prop) (el: exprlist) {struct el}: Prop := + match el with + | Enil => True + | Econs e el' => P e /\ forall_exprlist P el' + end. + +Lemma expr_induction_principle: + forall (P: expr -> Prop), + (forall i : ident, P (Evar i)) -> + (forall (o : operation) (e : exprlist), + forall_exprlist P e -> P (Eop o e)) -> + (forall (m : memory_chunk) (a : Op.addressing) (e : exprlist), + forall_exprlist P e -> P (Eload m a e)) -> + (forall (c : condexpr) (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. +Proof. + intros. apply expr_ind2 with (P := P) (P0 := forall_exprlist P); auto. + simpl. auto. + intros. simpl. auto. +Qed. + +Lemma eval_base_condition_of_expr: + forall le a v b, + eval_expr ge sp e m le a v -> + Val.bool_of_val v b -> + eval_condexpr ge sp e m le + (CEcond (Ccompimm Cne Int.zero) (a ::: Enil)) + b. +Proof. + intros. + eapply eval_CEcond. eauto with evalexpr. + inversion H0; simpl. rewrite Int.eq_false; auto. auto. auto. +Qed. + +Lemma is_compare_neq_zero_correct: + forall c v b, + is_compare_neq_zero c = true -> + eval_condition c (v :: nil) m = Some b -> + Val.bool_of_val v b. +Proof. + intros. + destruct c; simpl in H; try discriminate; + destruct c; simpl in H; try discriminate; + generalize (Int.eq_spec i Int.zero); rewrite H; intro; subst i. + + simpl in H0. destruct v; inv H0. + generalize (Int.eq_spec i Int.zero). destruct (Int.eq i Int.zero); intros; simpl. + subst i; constructor. constructor; auto. constructor. + + simpl in H0. destruct v; inv H0. + generalize (Int.eq_spec i Int.zero). destruct (Int.eq i Int.zero); intros; simpl. + subst i; constructor. constructor; auto. +Qed. + +Lemma is_compare_eq_zero_correct: + forall c v b, + is_compare_eq_zero c = true -> + eval_condition c (v :: nil) m = Some b -> + Val.bool_of_val v (negb b). +Proof. + intros. apply is_compare_neq_zero_correct with (negate_condition c). + destruct c; simpl in H; simpl; try discriminate; + destruct c; simpl; try discriminate; auto. + apply eval_negate_condition; auto. +Qed. + +Lemma eval_condition_of_expr: + forall a le v b, + eval_expr ge sp e m le a v -> + Val.bool_of_val v b -> + eval_condexpr ge sp e m le (condexpr_of_expr a) b. +Proof. + intro a0; pattern a0. + apply expr_induction_principle; simpl; intros; + try (eapply eval_base_condition_of_expr; eauto; fail). + + destruct o; try (eapply eval_base_condition_of_expr; eauto; fail). + + destruct e0. InvEval. + inversion H1. + rewrite Int.eq_false; auto. constructor. + subst i; rewrite Int.eq_true. constructor. + eapply eval_base_condition_of_expr; eauto. + + inv H0. simpl in H7. + assert (eval_condition c vl m = Some b). + destruct (eval_condition c vl m); try discriminate. + destruct b0; inv H7; inversion H1; congruence. + assert (eval_condexpr ge sp e m le (CEcond c e0) b). + eapply eval_CEcond; eauto. + destruct e0; auto. destruct e1; auto. + simpl in H. destruct H. + inv H5. inv H11. + + case_eq (is_compare_neq_zero c); intros. + eapply H; eauto. + apply is_compare_neq_zero_correct with c; auto. + + case_eq (is_compare_eq_zero c); intros. + replace b with (negb (negb b)). apply negate_condexpr_correct. + eapply H; eauto. + apply is_compare_eq_zero_correct with c; auto. + apply negb_involutive. + + auto. + + inv H1. destruct v1; eauto with evalexpr. +Qed. + +Lemma eval_addressing: + forall le chunk a v b ofs, + eval_expr ge sp e m le a v -> + v = Vptr b ofs -> + match addressing chunk a with (mode, args) => + exists vl, + eval_exprlist ge sp e m le args vl /\ + eval_addressing ge sp mode vl = Some v + end. +Proof. + intros until v. unfold addressing; case (addressing_match a); intros; InvEval. + exists (@nil val). split. eauto with evalexpr. simpl. auto. + exists (Vptr b0 i :: nil). split. eauto with evalexpr. + simpl. congruence. + destruct (is_float_addressing chunk). + exists (Vptr b0 ofs :: nil). + split. constructor. econstructor. eauto with evalexpr. simpl. congruence. constructor. + simpl. rewrite Int.add_zero. congruence. + exists (Vptr b0 i :: Vint i0 :: nil). + split. eauto with evalexpr. simpl. congruence. + destruct (is_float_addressing chunk). + exists (Vptr b0 ofs :: nil). + split. constructor. econstructor. eauto with evalexpr. simpl. congruence. constructor. + simpl. rewrite Int.add_zero. congruence. + exists (Vint i :: Vptr b0 i0 :: nil). + split. eauto with evalexpr. simpl. + rewrite Int.add_commut. congruence. + destruct (is_float_addressing chunk). + exists (Vptr b0 ofs :: nil). + split. constructor. econstructor. eauto with evalexpr. simpl. congruence. constructor. + simpl. rewrite Int.add_zero. 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 le a v chunk v', + eval_expr ge sp e m le a v -> + Mem.loadv chunk m v = Some v' -> + eval_expr ge sp e m le (load chunk a) v'. +Proof. + intros. generalize H0; destruct v; simpl; intro; try discriminate. + unfold load. + generalize (eval_addressing _ chunk _ _ _ _ H (refl_equal _)). + destruct (addressing chunk a). intros [vl [EV EQ]]. + eapply eval_Eload; eauto. +Qed. + +Lemma eval_store: + forall chunk a1 a2 v1 v2 f k m', + eval_expr ge sp e m nil a1 v1 -> + eval_expr ge sp e m nil a2 v2 -> + Mem.storev chunk m v1 v2 = Some m' -> + step ge (State f (store chunk a1 a2) k sp e m) + E0 (State f Sskip k sp e m'). +Proof. + intros. generalize H1; destruct v1; simpl; intro; try discriminate. + unfold store. + generalize (eval_addressing _ chunk _ _ _ _ H (refl_equal _)). + destruct (addressing chunk a1). intros [vl [EV EQ]]. + eapply step_store; 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 le op a1 v1 v, + eval_expr ge sp e m le a1 v1 -> + eval_unop op v1 = Some v -> + eval_expr ge sp e m le (sel_unop op a1) 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. + EvalOp. +Qed. + +Lemma eval_sel_binop: + forall le op a1 a2 v1 v2 v, + eval_expr ge sp e m le a1 v1 -> + eval_expr ge sp e m le a2 v2 -> + eval_binop op v1 v2 m = Some v -> + eval_expr ge sp e m le (sel_binop op a1 a2) v. +Proof. + destruct op; simpl; intros; FuncInv; try subst v. + apply eval_add; auto. + apply eval_add_ptr_2; auto. + apply eval_add_ptr; auto. + apply eval_sub; auto. + apply eval_sub_ptr_int; auto. + destruct (eq_block b b0); inv H1. + eapply eval_sub_ptr_ptr; eauto. + apply eval_mul; eauto. + generalize (Int.eq_spec i0 Int.zero). destruct (Int.eq i0 Int.zero); inv H1. + apply eval_divs; eauto. + generalize (Int.eq_spec i0 Int.zero). destruct (Int.eq i0 Int.zero); inv H1. + apply eval_divu; eauto. + generalize (Int.eq_spec i0 Int.zero). destruct (Int.eq i0 Int.zero); inv H1. + apply eval_mods; eauto. + generalize (Int.eq_spec i0 Int.zero). destruct (Int.eq i0 Int.zero); inv H1. + apply eval_modu; eauto. + apply eval_and; auto. + apply eval_or; auto. + apply eval_xor; auto. + caseEq (Int.ltu i0 (Int.repr 32)); intro; rewrite H2 in H1; inv H1. + apply eval_shl; auto. + caseEq (Int.ltu i0 (Int.repr 32)); intro; rewrite H2 in H1; inv H1. + apply eval_shr; auto. + caseEq (Int.ltu i0 (Int.repr 32)); intro; rewrite H2 in H1; inv H1. + apply eval_shru; auto. + EvalOp. + EvalOp. + EvalOp. + EvalOp. + apply eval_comp_int; auto. + eapply eval_comp_int_ptr; eauto. + eapply eval_comp_ptr_int; eauto. + generalize H1; clear H1. + case_eq (valid_pointer m b (Int.signed i) && valid_pointer m b0 (Int.signed i0)); intros. + destruct (eq_block b b0); inv H2. + eapply eval_comp_ptr_ptr; eauto. + eapply eval_comp_ptr_ptr_2; eauto. + discriminate. + eapply eval_compu; eauto. + eapply eval_compf; eauto. +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. + +(** Semantic preservation for expressions. *) + +Lemma sel_expr_correct: + forall sp e m a v, + Cminor.eval_expr ge sp e m a v -> + forall le, + eval_expr tge sp e m le (sel_expr a) v. +Proof. + induction 1; 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 *) + eapply eval_sel_binop; eauto. + (* Eload *) + eapply eval_load; eauto. + (* Econdition *) + econstructor; eauto. eapply eval_condition_of_expr; eauto. + destruct b1; auto. +Qed. + +Hint Resolve sel_expr_correct: evalexpr. + +Lemma sel_exprlist_correct: + forall sp e m a v, + Cminor.eval_exprlist ge sp e m a v -> + forall le, + eval_exprlist tge sp e m le (sel_exprlist a) v. +Proof. + induction 1; intros; simpl; constructor; auto with evalexpr. +Qed. + +Hint Resolve sel_exprlist_correct: evalexpr. + +(** Semantic preservation for terminating function calls and statements. *) + +Fixpoint sel_cont (k: Cminor.cont) : CminorSel.cont := + match k with + | Cminor.Kstop => Kstop + | Cminor.Kseq s1 k1 => Kseq (sel_stmt s1) (sel_cont k1) + | Cminor.Kblock k1 => Kblock (sel_cont k1) + | Cminor.Kcall id f sp e k1 => + Kcall id (sel_function f) sp e (sel_cont k1) + end. + +Inductive match_states: Cminor.state -> CminorSel.state -> Prop := + | match_state: forall f s k s' k' sp e m, + s' = sel_stmt s -> + k' = sel_cont k -> + match_states + (Cminor.State f s k sp e m) + (State (sel_function f) s' k' sp e m) + | match_callstate: forall f args k k' m, + k' = sel_cont k -> + match_states + (Cminor.Callstate f args k m) + (Callstate (sel_fundef f) args k' m) + | match_returnstate: forall v k k' m, + k' = sel_cont k -> + match_states + (Cminor.Returnstate v k m) + (Returnstate v k' m). + +Remark call_cont_commut: + forall k, call_cont (sel_cont k) = sel_cont (Cminor.call_cont k). +Proof. + induction k; simpl; auto. +Qed. + +Remark find_label_commut: + forall lbl s k, + find_label lbl (sel_stmt s) (sel_cont k) = + option_map (fun sk => (sel_stmt (fst sk), sel_cont (snd sk))) + (Cminor.find_label lbl s k). +Proof. + induction s; intros; simpl; auto. + unfold store. destruct (addressing m (sel_expr e)); auto. + change (Kseq (sel_stmt s2) (sel_cont k)) + with (sel_cont (Cminor.Kseq s2 k)). + rewrite IHs1. rewrite IHs2. + destruct (Cminor.find_label lbl s1 (Cminor.Kseq s2 k)); auto. + rewrite IHs1. rewrite IHs2. + destruct (Cminor.find_label lbl s1 k); auto. + change (Kseq (Sloop (sel_stmt s)) (sel_cont k)) + with (sel_cont (Cminor.Kseq (Cminor.Sloop s) k)). + auto. + change (Kblock (sel_cont k)) + with (sel_cont (Cminor.Kblock k)). + auto. + destruct o; auto. + destruct (ident_eq lbl l); auto. +Qed. + +Lemma sel_step_correct: + forall S1 t S2, Cminor.step ge S1 t S2 -> + forall T1, match_states S1 T1 -> + exists T2, step tge T1 t T2 /\ match_states S2 T2. +Proof. + induction 1; intros T1 ME; inv ME; simpl; + try (econstructor; split; [econstructor; eauto with evalexpr | econstructor; eauto]; fail). + + (* skip call *) + econstructor; split. + econstructor. destruct k; simpl in H; simpl; auto. + rewrite <- H0; reflexivity. + constructor; auto. + (* assign *) + exists (State (sel_function f) Sskip (sel_cont k) sp (PTree.set id v e) m); split. + constructor. auto with evalexpr. + constructor; auto. + (* store *) + econstructor; split. + eapply eval_store; eauto with evalexpr. + constructor; auto. + (* Scall *) + econstructor; split. + econstructor; eauto with evalexpr. + apply functions_translated; eauto. + apply sig_function_translated. + constructor; auto. + (* Stailcall *) + econstructor; split. + econstructor; eauto with evalexpr. + apply functions_translated; eauto. + apply sig_function_translated. + constructor; auto. apply call_cont_commut. + (* Salloc *) + exists (State (sel_function f) Sskip (sel_cont k) sp (PTree.set id (Vptr b Int.zero) e) m'); split. + econstructor; eauto with evalexpr. + constructor; auto. + (* Sifthenelse *) + exists (State (sel_function f) (if b then sel_stmt s1 else sel_stmt s2) (sel_cont k) sp e m); split. + constructor. eapply eval_condition_of_expr; eauto with evalexpr. + constructor; auto. destruct b; auto. + (* Sreturn None *) + econstructor; split. + econstructor. rewrite <- H; reflexivity. + constructor; auto. apply call_cont_commut. + (* Sreturn Some *) + econstructor; split. + econstructor. simpl. auto. eauto with evalexpr. + constructor; auto. apply call_cont_commut. + (* Sgoto *) + econstructor; split. + econstructor. simpl. rewrite call_cont_commut. rewrite find_label_commut. + rewrite H. simpl. reflexivity. + constructor; auto. +Qed. + +Lemma sel_initial_states: + forall S, Cminor.initial_state prog S -> + exists R, initial_state tprog R /\ match_states S R. +Proof. + induction 1. + econstructor; split. + econstructor. + simpl. fold tge. rewrite symbols_preserved. eexact H. + apply function_ptr_translated. eauto. + rewrite <- H1. apply sig_function_translated; auto. + unfold tprog, sel_program. rewrite Genv.init_mem_transf. + constructor; auto. +Qed. + +Lemma sel_final_states: + forall S R r, + match_states S R -> Cminor.final_state S r -> final_state R r. +Proof. + intros. inv H0. inv H. simpl. constructor. +Qed. + +Theorem transf_program_correct: + forall (beh: program_behavior), + Cminor.exec_program prog beh -> CminorSel.exec_program tprog beh. +Proof. + unfold CminorSel.exec_program, Cminor.exec_program; intros. + eapply simulation_step_preservation; eauto. + eexact sel_initial_states. + eexact sel_final_states. + exact sel_step_correct. +Qed. + +End PRESERVATION. diff --git a/arm/linux/Conventions.v b/arm/linux/Conventions.v new file mode 100644 index 0000000..0342521 --- /dev/null +++ b/arm/linux/Conventions.v @@ -0,0 +1,858 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Function calling conventions and other conventions regarding the use of + machine registers and stack slots. *) + +Require Import Coqlib. +Require Import AST. +Require Import Locations. + +(** * Classification of machine registers *) + +(** Machine registers (type [mreg] in module [Locations]) are divided in + the following groups: +- Temporaries used for spilling, reloading, and parallel move operations. +- Allocatable registers, that can be assigned to RTL pseudo-registers. + These are further divided into: +-- Callee-save registers, whose value is preserved across a function call. +-- Caller-save registers that can be modified during a function call. + + We follow the PowerPC application binary interface (ABI) in our choice + of callee- and caller-save registers. +*) + +Definition int_caller_save_regs := + R0 :: R1 :: R2 :: R3 :: nil. + +Definition float_caller_save_regs := + F0 :: F1 :: nil. + +Definition int_callee_save_regs := + R4 :: R5 :: R6 :: R7 :: R8 :: R9 :: R11 :: nil. + +Definition float_callee_save_regs := + F4 :: F5 :: F6 :: F7 :: nil. + +Definition destroyed_at_call_regs := + int_caller_save_regs ++ float_caller_save_regs. + +Definition destroyed_at_call := + List.map R destroyed_at_call_regs. + +Definition int_temporaries := IT1 :: IT2 :: nil. + +Definition float_temporaries := FT1 :: FT2 :: nil. + +Definition temporaries := + R IT1 :: R IT2 :: R FT1 :: R FT2 :: nil. + +(** The [index_int_callee_save] and [index_float_callee_save] associate + a unique positive integer to callee-save registers. This integer is + used in [Stacking] to determine where to save these registers in + the activation record if they are used by the current function. *) + +Definition index_int_callee_save (r: mreg) := + match r with + | R4 => 0 | R5 => 1 | R6 => 2 | R7 => 3 + | R8 => 4 | R9 => 5 | R11 => 6 + | _ => -1 + end. + +Definition index_float_callee_save (r: mreg) := + match r with + | F4 => 0 | F5 => 1 | F6 => 2 | F7 => 3 + | _ => -1 + end. + +Ltac ElimOrEq := + match goal with + | |- (?x = ?y) \/ _ -> _ => + let H := fresh in + (intro H; elim H; clear H; + [intro H; rewrite <- H; clear H | ElimOrEq]) + | |- False -> _ => + let H := fresh in (intro H; contradiction) + end. + +Ltac OrEq := + match goal with + | |- (?x = ?x) \/ _ => left; reflexivity + | |- (?x = ?y) \/ _ => right; OrEq + | |- False => fail + end. + +Ltac NotOrEq := + match goal with + | |- (?x = ?y) \/ _ -> False => + let H := fresh in ( + intro H; elim H; clear H; [intro; discriminate | NotOrEq]) + | |- False -> False => + contradiction + end. + +Lemma index_int_callee_save_pos: + forall r, In r int_callee_save_regs -> index_int_callee_save r >= 0. +Proof. + intro r. simpl; ElimOrEq; unfold index_int_callee_save; omega. +Qed. + +Lemma index_float_callee_save_pos: + forall r, In r float_callee_save_regs -> index_float_callee_save r >= 0. +Proof. + intro r. simpl; ElimOrEq; unfold index_float_callee_save; omega. +Qed. + +Lemma index_int_callee_save_pos2: + forall r, index_int_callee_save r >= 0 -> In r int_callee_save_regs. +Proof. + destruct r; simpl; intro; omegaContradiction || OrEq. +Qed. + +Lemma index_float_callee_save_pos2: + forall r, index_float_callee_save r >= 0 -> In r float_callee_save_regs. +Proof. + destruct r; simpl; intro; omegaContradiction || OrEq. +Qed. + +Lemma index_int_callee_save_inj: + forall r1 r2, + In r1 int_callee_save_regs -> + In r2 int_callee_save_regs -> + r1 <> r2 -> + index_int_callee_save r1 <> index_int_callee_save r2. +Proof. + intros r1 r2. + simpl; ElimOrEq; ElimOrEq; unfold index_int_callee_save; + intros; congruence. +Qed. + +Lemma index_float_callee_save_inj: + forall r1 r2, + In r1 float_callee_save_regs -> + In r2 float_callee_save_regs -> + r1 <> r2 -> + index_float_callee_save r1 <> index_float_callee_save r2. +Proof. + intros r1 r2. + simpl; ElimOrEq; ElimOrEq; unfold index_float_callee_save; + intros; congruence. +Qed. + +(** The following lemmas show that + (temporaries, destroyed at call, integer callee-save, float callee-save) + is a partition of the set of machine registers. *) + +Lemma int_float_callee_save_disjoint: + list_disjoint int_callee_save_regs float_callee_save_regs. +Proof. + red; intros r1 r2. simpl; ElimOrEq; ElimOrEq; discriminate. +Qed. + +Lemma register_classification: + forall r, + (In (R r) temporaries \/ In (R r) destroyed_at_call) \/ + (In r int_callee_save_regs \/ In r float_callee_save_regs). +Proof. + destruct r; + try (left; left; simpl; OrEq); + try (left; right; simpl; OrEq); + try (right; left; simpl; OrEq); + try (right; right; simpl; OrEq). +Qed. + +Lemma int_callee_save_not_destroyed: + forall r, + In (R r) temporaries \/ In (R r) destroyed_at_call -> + ~(In r int_callee_save_regs). +Proof. + intros; red; intros. elim H. + generalize H0. simpl; ElimOrEq; NotOrEq. + generalize H0. simpl; ElimOrEq; NotOrEq. +Qed. + +Lemma float_callee_save_not_destroyed: + forall r, + In (R r) temporaries \/ In (R r) destroyed_at_call -> + ~(In r float_callee_save_regs). +Proof. + intros; red; intros. elim H. + generalize H0. simpl; ElimOrEq; NotOrEq. + generalize H0. simpl; ElimOrEq; NotOrEq. +Qed. + +Lemma int_callee_save_type: + forall r, In r int_callee_save_regs -> mreg_type r = Tint. +Proof. + intro. simpl; ElimOrEq; reflexivity. +Qed. + +Lemma float_callee_save_type: + forall r, In r float_callee_save_regs -> mreg_type r = Tfloat. +Proof. + intro. simpl; ElimOrEq; reflexivity. +Qed. + +Ltac NoRepet := + match goal with + | |- list_norepet nil => + apply list_norepet_nil + | |- list_norepet (?a :: ?b) => + apply list_norepet_cons; [simpl; intuition discriminate | NoRepet] + end. + +Lemma int_callee_save_norepet: + list_norepet int_callee_save_regs. +Proof. + unfold int_callee_save_regs; NoRepet. +Qed. + +Lemma float_callee_save_norepet: + list_norepet float_callee_save_regs. +Proof. + unfold float_callee_save_regs; NoRepet. +Qed. + +(** * Acceptable locations for register allocation *) + +(** The following predicate describes the locations that can be assigned + to an RTL pseudo-register during register allocation: a non-temporary + machine register or a [Local] stack slot are acceptable. *) + +Definition loc_acceptable (l: loc) : Prop := + match l with + | R r => ~(In l temporaries) + | S (Local ofs ty) => ofs >= 0 + | S (Incoming _ _) => False + | S (Outgoing _ _) => False + end. + +Definition locs_acceptable (ll: list loc) : Prop := + forall l, In l ll -> loc_acceptable l. + +Lemma temporaries_not_acceptable: + forall l, loc_acceptable l -> Loc.notin l temporaries. +Proof. + unfold loc_acceptable; destruct l. + simpl. intuition congruence. + destruct s; try contradiction. + intro. simpl. tauto. +Qed. +Hint Resolve temporaries_not_acceptable: locs. + +Lemma locs_acceptable_disj_temporaries: + forall ll, locs_acceptable ll -> Loc.disjoint ll temporaries. +Proof. + intros. apply Loc.notin_disjoint. intros. + 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 + and stack slots) used to communicate arguments and results between the + caller and the callee during function calls. These locations are functions + of the signature of the function and of the call instruction. + Agreement between the caller and the callee on the locations to use + is guaranteed by our dynamic semantics for Cminor and RTL, which demand + that the signature of the call instruction is identical to that of the + called function. + + Calling conventions are largely arbitrary: they must respect the properties + proved in this section (such as no overlapping between the locations + of function arguments), but this leaves much liberty in choosing actual + locations. To ensure binary interoperability of code generated by our + compiler with libraries compiled by another PowerPC compiler, we + implement the standard conventions defined in the PowerPC application + binary interface. *) + +(** ** Location of function result *) + +(** The result value of a function is passed back to the caller in + registers [R0] or [F0], depending on the type of the returned value. + We treat a function without result as a function with one integer result. *) + +Definition loc_result (s: signature) : mreg := + match s.(sig_res) with + | None => R0 + | Some Tint => R0 + | Some Tfloat => F0 + end. + +(** The result location has the type stated in the signature. *) + +Lemma loc_result_type: + forall sig, + mreg_type (loc_result sig) = + match sig.(sig_res) with None => Tint | Some ty => ty end. +Proof. + intros; unfold loc_result. + destruct (sig_res sig). + destruct t; reflexivity. + reflexivity. +Qed. + +(** 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. + destruct (sig_res s). + destruct t; simpl; OrEq. + simpl; OrEq. +Qed. + +(** The result location is not a callee-save register. *) + +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_caller_save s). + generalize (int_callee_save_not_destroyed (loc_result s)). + generalize (float_callee_save_not_destroyed (loc_result s)). + tauto. +Qed. + +(** ** Location of function arguments *) + +(** We use the following calling conventions, adapted from the ARM ABI: +- The first 4 integer arguments are passed in registers [R0] to [R3]. +- The first 2 float arguments are passed in registers [F0] and [F1]. +- Each float argument passed in a float register ``consumes'' two + integer arguments. +- Extra arguments are passed on the stack, in [Outgoing] slots, consecutively + assigned (1 word for an integer argument, 2 words for a float), + starting at word offset 0. + +These conventions are somewhat baroque, but they are mandated by the ABI. +*) + +Fixpoint loc_arguments_rec + (tyl: list typ) (iregl: list mreg) (fregl: list mreg) + (ofs: Z) {struct tyl} : list loc := + match tyl with + | nil => nil + | Tint :: tys => + match iregl with + | 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) :: + loc_arguments_rec tys iregl nil (ofs + 2) + | freg :: fregs => + match iregl with + | nil => + S (Outgoing ofs Tfloat) :: + loc_arguments_rec tys nil fregl (ofs + 2) + | ireg :: nil => + R freg :: + loc_arguments_rec tys nil fregs (ofs + 1) + | ireg1 :: ireg2 :: iregs => + R freg :: + loc_arguments_rec tys iregs fregs ofs + end + end + end. + +Definition int_param_regs := + R0 :: R1 :: R2 :: R3 :: nil. +Definition float_param_regs := + F0 :: F1 :: nil. + +(** [loc_arguments s] returns the list of locations where to store arguments + 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 0. + +(** [size_arguments s] returns the number of [Outgoing] slots used + to call a function with signature [s]. *) + +Fixpoint size_arguments_rec + (tyl: list typ) (iregl: list mreg) (fregl: list mreg) + (ofs: Z) {struct tyl} : Z := + match tyl with + | 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 => + match iregl with + | nil => + size_arguments_rec tys nil fregl (ofs + 2) + | ireg :: nil => + size_arguments_rec tys nil fregs (ofs + 1) + | ireg1 :: ireg2 :: iregs => + size_arguments_rec tys iregs fregs ofs + end + end + end. + +Definition size_arguments (s: signature) : Z := + size_arguments_rec s.(sig_args) int_param_regs float_param_regs 0. + +(** A tail-call is possible for a signature if the corresponding + arguments are all passed in registers. *) + +Definition tailcall_possible (s: signature) : Prop := + forall l, In l (loc_arguments s) -> + match l with R _ => True | S _ => False end. + +(** Argument locations are either non-temporary registers or [Outgoing] + stack slots at nonnegative offsets. *) + +Definition loc_argument_acceptable (l: loc) : Prop := + match l with + | R r => ~(In l temporaries) + | S (Outgoing ofs ty) => ofs >= 0 + | _ => False + end. + +Remark loc_arguments_rec_charact: + forall tyl iregl fregl ofs l, + In l (loc_arguments_rec tyl iregl fregl ofs) -> + match l with + | R r => In r iregl \/ In r fregl + | S (Outgoing ofs' ty) => ofs' >= ofs + | S _ => False + end. +Proof. + induction tyl; simpl loc_arguments_rec; intros. + elim H. + 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. + destruct iregl. + elim H; intro. + subst l. omega. + generalize (IHtyl _ _ _ _ H0). destruct l; auto. destruct s; auto. omega. + destruct iregl. + elim H; intro. + subst l. auto with coqlib. + generalize (IHtyl _ _ _ _ H0). destruct l; auto. + intros [A|B]. elim A. auto with coqlib. + destruct s; auto. omega. + elim H; intro. + subst l. auto with coqlib. + generalize (IHtyl _ _ _ _ H0). destruct l; auto. + intros [A|B]; auto with coqlib. +Qed. + +Lemma loc_arguments_acceptable: + forall (s: signature) (r: loc), + In r (loc_arguments s) -> loc_argument_acceptable r. +Proof. + unfold loc_arguments; intros. + generalize (loc_arguments_rec_charact _ _ _ _ _ H). + destruct r. + intro H0; elim H0. simpl. unfold not. ElimOrEq; NotOrEq. + simpl. unfold not. ElimOrEq; NotOrEq. + destruct s0; try contradiction. + simpl. omega. +Qed. +Hint Resolve loc_arguments_acceptable: locs. + +(** Arguments are parwise disjoint (in the sense of [Loc.norepet]). *) + +Remark loc_arguments_rec_notin_reg: + forall tyl iregl fregl ofs r, + ~(In r iregl) -> ~(In r fregl) -> + Loc.notin (R r) (loc_arguments_rec tyl iregl fregl ofs). +Proof. + induction tyl; simpl; intros. + 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. + destruct iregl; simpl. auto. + destruct iregl; simpl. + split. apply sym_not_equal. tauto. apply IHtyl. hnf. tauto. tauto. + split. apply sym_not_equal. tauto. apply IHtyl. + red; intro. apply H. auto with coqlib. tauto. +Qed. + +Remark loc_arguments_rec_notin_local: + forall tyl iregl fregl ofs ofs0 ty0, + Loc.notin (S (Local ofs0 ty0)) (loc_arguments_rec tyl iregl fregl ofs). +Proof. + induction tyl; simpl; intros. + auto. + destruct a. + destruct iregl; simpl; auto. + destruct fregl; simpl; auto. + destruct iregl; simpl; auto. + destruct iregl; simpl; auto. +Qed. + +Remark loc_arguments_rec_notin_outgoing: + forall tyl iregl fregl ofs ofs0 ty0, + ofs0 + typesize ty0 <= ofs -> + Loc.notin (S (Outgoing ofs0 ty0)) (loc_arguments_rec tyl iregl fregl ofs). +Proof. + induction tyl; simpl; intros. + auto. + destruct a. + destruct iregl; simpl. + split. omega. eapply IHtyl. omega. + auto. + destruct fregl; simpl. + split. omega. eapply IHtyl. omega. + destruct iregl; simpl. + split. omega. eapply IHtyl. omega. + destruct iregl; simpl. + split; auto. eapply IHtyl. omega. + split; auto. +Qed. + +Lemma loc_arguments_norepet: + forall (s: signature), Loc.norepet (loc_arguments s). +Proof. + assert (forall tyl iregl fregl ofs, + list_norepet iregl -> + list_norepet fregl -> + list_disjoint iregl fregl -> + Loc.norepet (loc_arguments_rec tyl iregl fregl ofs)). + induction tyl; simpl; intros. + constructor. + 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. inv H; auto. auto. + eapply list_disjoint_cons_left; eauto. + + destruct fregl. constructor. + apply loc_arguments_rec_notin_outgoing. simpl; omega. auto. + destruct iregl. constructor. + apply loc_arguments_rec_notin_outgoing. simpl; omega. auto. + destruct iregl; constructor. + apply loc_arguments_rec_notin_reg. + red; intro. apply (H1 m m). auto with coqlib. auto with coqlib. auto. + inv H0; auto. + apply IHtyl. constructor. inv H0; auto. + red; intros. elim H2. + apply loc_arguments_rec_notin_reg. + red; intros. elim (H1 m m); auto with coqlib. + inv H0; auto. + apply IHtyl. inv H. inv H5. auto. inv H0; auto. + red; intros. apply H1; auto with coqlib. + + intro. unfold loc_arguments. apply H. + unfold int_param_regs. NoRepet. + unfold float_param_regs. NoRepet. + red; intros x y; simpl. ElimOrEq; ElimOrEq; discriminate. +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. + destruct iregl. apply Zle_trans with (ofs0 + 2); auto; omega. + destruct iregl. apply Zle_trans with (ofs0 + 1); auto; omega. + auto. +Qed. + +Lemma size_arguments_above: + forall s, size_arguments s >= 0. +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 iregl fregl ofs0, + In (S (Outgoing ofs ty)) (loc_arguments_rec tyl iregl fregl ofs0) -> + 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. + destruct iregl. elim H0; intro. + inv H1. simpl. apply size_arguments_rec_above. auto. + destruct iregl. + elim H0; intro. inv H1. auto. + elim H0; intro. inv H1. auto. + + unfold size_arguments. eapply H0. unfold loc_arguments in H. eauto. +Qed. + +(** Temporary registers do not overlap with argument locations. *) + +Lemma loc_arguments_not_temporaries: + forall sig, Loc.disjoint (loc_arguments sig) temporaries. +Proof. + intros; red; intros x1 x2 H. + generalize (loc_arguments_rec_charact _ _ _ _ _ H). + destruct x1. + intro H0; elim H0; simpl; (ElimOrEq; ElimOrEq; congruence). + destruct s; try contradiction. intro. + simpl; ElimOrEq; auto. +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: + forall sig l, + Loc.notin l destroyed_at_call -> loc_acceptable l -> + Loc.notin l (loc_arguments sig). +Proof. + intros. unfold loc_arguments. destruct l. + apply loc_arguments_rec_notin_reg. + generalize (Loc.notin_not_in _ _ H). intro; red; intro. + apply H1. generalize H2. simpl. ElimOrEq; OrEq. + generalize (Loc.notin_not_in _ _ H). intro; red; intro. + apply H1. generalize H2. simpl. ElimOrEq; OrEq. + destruct s; simpl in H0; try contradiction. + apply loc_arguments_rec_notin_local. +Qed. +Hint Resolve arguments_not_preserved: locs. + +(** Argument locations agree in number with the function signature. *) + +Lemma loc_arguments_length: + forall sig, + List.length (loc_arguments sig) = List.length sig.(sig_args). +Proof. + assert (forall tyl iregl fregl ofs, + List.length (loc_arguments_rec tyl iregl fregl ofs) = List.length tyl). + induction tyl; simpl; intros. + auto. + destruct a. + destruct iregl; simpl; decEq; auto. + destruct fregl; simpl; decEq; auto. + destruct iregl; simpl. decEq; auto. + destruct iregl; simpl; decEq; auto. + + intros. unfold loc_arguments. auto. +Qed. + +(** Argument locations agree in types with the function signature. *) + +Lemma loc_arguments_type: + forall sig, List.map Loc.type (loc_arguments sig) = sig.(sig_args). +Proof. + assert (forall tyl iregl fregl ofs, + (forall r, In r iregl -> mreg_type r = Tint) -> + (forall r, In r fregl -> mreg_type r = Tfloat) -> + List.map Loc.type (loc_arguments_rec tyl iregl fregl ofs) = tyl). + induction tyl; simpl; intros. + auto. + destruct a. + destruct iregl; simpl; f_equal; eauto with coqlib. + destruct fregl; simpl. + f_equal; eauto with coqlib. + destruct iregl; simpl. + f_equal; eauto with coqlib. + destruct iregl; simpl; f_equal; eauto with coqlib. + apply IHtyl. simpl; tauto. auto with coqlib. + apply IHtyl. auto with coqlib. auto with coqlib. + + intros. unfold loc_arguments. apply H. + intro; simpl. ElimOrEq; reflexivity. + intro; simpl. ElimOrEq; reflexivity. +Qed. + +(** There is no partial overlap between an argument location and an + acceptable location: they are either identical or disjoint. *) + +Lemma no_overlap_arguments: + forall args sg, + locs_acceptable args -> + Loc.no_overlap args (loc_arguments sg). +Proof. + unfold Loc.no_overlap; intros. + generalize (H r H0). + generalize (loc_arguments_acceptable _ _ H1). + destruct s; destruct r; simpl. + intros. case (mreg_eq m0 m); intro. left; congruence. tauto. + intros. right; destruct s; auto. + intros. right. auto. + destruct s; try tauto. destruct s0; tauto. +Qed. + +(** Decide whether a tailcall is possible. *) + +Definition tailcall_is_possible (sg: signature) : bool := + let fix tcisp (l: list loc) := + match l with + | nil => true + | R _ :: l' => tcisp l' + | S _ :: l' => false + end + in tcisp (loc_arguments sg). + +Lemma tailcall_is_possible_correct: + forall s, tailcall_is_possible s = true -> tailcall_possible s. +Proof. + intro s. unfold tailcall_is_possible, tailcall_possible. + generalize (loc_arguments s). induction l; simpl; intros. + elim H0. + destruct a. + destruct H0. subst l0. auto. apply IHl. auto. auto. discriminate. +Qed. + +(** ** Location of function parameters *) + +(** A function finds the values of its parameter in the same locations + where its caller stored them, except that the stack-allocated arguments, + viewed as [Outgoing] slots by the caller, are accessed via [Incoming] + slots (at the same offsets and types) in the callee. *) + +Definition parameter_of_argument (l: loc) : loc := + match l with + | S (Outgoing n ty) => S (Incoming n ty) + | _ => l + end. + +Definition loc_parameters (s: signature) := + List.map parameter_of_argument (loc_arguments s). + +Lemma loc_parameters_type: + forall sig, List.map Loc.type (loc_parameters sig) = sig.(sig_args). +Proof. + intros. unfold loc_parameters. + rewrite list_map_compose. + rewrite <- loc_arguments_type. + apply list_map_exten. + intros. destruct x; simpl. auto. + 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. + intro; red; intros. + unfold loc_parameters in H. + elim (list_in_map_inv _ _ _ H). intros y [EQ IN]. + generalize (loc_arguments_not_temporaries sig y x2 IN H0). + subst x1. destruct x2. + destruct y; simpl. auto. destruct s; auto. + byContradiction. generalize H0. simpl. NotOrEq. +Qed. + +Lemma no_overlap_parameters: + forall params sg, + locs_acceptable params -> + Loc.no_overlap (loc_parameters sg) params. +Proof. + unfold Loc.no_overlap; intros. + unfold loc_parameters in H0. + elim (list_in_map_inv _ _ _ H0). intros t [EQ IN]. + rewrite EQ. + generalize (loc_arguments_acceptable _ _ IN). + generalize (H s H1). + destruct s; destruct t; simpl. + intros. case (mreg_eq m0 m); intro. left; congruence. tauto. + intros. right; destruct s; simpl; auto. + intros; right; auto. + destruct s; try tauto. destruct s0; try tauto. + intros; simpl. tauto. +Qed. + +(** ** Location of argument and result for dynamic memory allocation *) + +Definition loc_alloc_argument := R0. +Definition loc_alloc_result := R0. diff --git a/arm/linux/Stacklayout.v b/arm/linux/Stacklayout.v new file mode 100644 index 0000000..dd3c6a1 --- /dev/null +++ b/arm/linux/Stacklayout.v @@ -0,0 +1,79 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Machine- and ABI-dependent layout information for activation records. *) + +Require Import Coqlib. +Require Import Bounds. + +(** The general shape of activation records is as follows, + from bottom (lowest offsets) to top: +- Space for outgoing arguments to function calls. +- Local stack slots of integer type. +- Saved values of integer callee-save registers used by the function. +- One word of padding, if necessary to align the following data + on a 8-byte boundary. +- Local stack slots of float type. +- Saved values of float callee-save registers used by the function. +- Saved return address into caller. +- Pointer to activation record of the caller. +- Space for the stack-allocated data declared in Cminor. + +To facilitate some of the proofs, the Cminor stack-allocated data +starts at offset 0; the preceding areas in the activation record +therefore have negative offsets. This part (with negative offsets) +is called the ``frame'', by opposition with the ``Cminor stack data'' +which is the part with positive offsets. + +The [frame_env] compilation environment records the positions of +the boundaries between areas in the frame part. +*) + +Definition fe_ofs_arg := 0. + +Record frame_env : Set := mk_frame_env { + fe_size: Z; + fe_ofs_link: Z; + fe_ofs_retaddr: Z; + fe_ofs_int_local: Z; + fe_ofs_int_callee_save: Z; + fe_num_int_callee_save: Z; + fe_ofs_float_local: Z; + fe_ofs_float_callee_save: Z; + fe_num_float_callee_save: Z +}. + +(** Computation of the frame environment from the bounds of the current + function. *) + +Definition make_env (b: bounds) := + let oil := 4 * b.(bound_outgoing) in (* integer locals *) + let oics := oil + 4 * b.(bound_int_local) in (* integer callee-saves *) + let oendi := oics + 4 * b.(bound_int_callee_save) in + let ofl := align oendi 8 in (* float locals *) + let ofcs := ofl + 8 * b.(bound_float_local) in (* float callee-saves *) + let ora := ofcs + 8 * b.(bound_float_callee_save) in (* retaddr *) + let olink := ora + 4 in (* back link *) + let sz := olink + 4 in (* total frame size *) + mk_frame_env sz olink ora + oil oics b.(bound_int_callee_save) + ofl ofcs b.(bound_float_callee_save). + + +Remark align_float_part: + forall b, + 4 * bound_outgoing b + 4 * bound_int_local b + 4 * bound_int_callee_save b <= + align (4 * bound_outgoing b + 4 * bound_int_local b + 4 * bound_int_callee_save b) 8. +Proof. + intros. apply align_le. omega. +Qed. + diff --git a/backend/CMlexer.mli b/backend/CMlexer.mli new file mode 100644 index 0000000..c6afb72 --- /dev/null +++ b/backend/CMlexer.mli @@ -0,0 +1,17 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU General Public License as published by *) +(* the Free Software Foundation, either version 2 of the License, or *) +(* (at your option) any later version. This file is also distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +val token: Lexing.lexbuf -> CMparser.token +exception Error of string diff --git a/backend/CMlexer.mll b/backend/CMlexer.mll new file mode 100644 index 0000000..9854117 --- /dev/null +++ b/backend/CMlexer.mll @@ -0,0 +1,132 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU General Public License as published by *) +(* the Free Software Foundation, either version 2 of the License, or *) +(* (at your option) any later version. This file is also distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +{ +open Camlcoq +open CMparser +exception Error of string +} + +let blank = [' ' '\009' '\012' '\010' '\013'] +let floatlit = + ['0'-'9'] ['0'-'9' '_']* + ('.' ['0'-'9' '_']* )? + (['e' 'E'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']*)? +let ident = ['A'-'Z' 'a'-'z' '_'] ['A'-'Z' 'a'-'z' '_' '0'-'9']* +let intlit = "-"? ( ['0'-'9']+ | "0x" ['0'-'9' 'a'-'f' 'A'-'F']+ + | "0o" ['0'-'7']+ | "0b" ['0'-'1']+ ) +let stringlit = "\"" [ ^ '"' ] * '"' + +rule token = parse + | blank + { token lexbuf } + | "/*" { comment lexbuf; token lexbuf } + | "absf" { ABSF } + | "alloc" { ALLOC } + | "&" { AMPERSAND } + | "&&" { AMPERSANDAMPERSAND } + | "!" { BANG } + | "!=" { BANGEQUAL } + | "!=f" { BANGEQUALF } + | "!=u" { BANGEQUALU } + | "|" { BAR } + | "||" { BARBAR } + | "^" { CARET } + | "case" { CASE } + | ":" { COLON } + | "," { COMMA } + | "default" { DEFAULT } + | "$" { DOLLAR } + | "else" { ELSE } + | "=" { EQUAL } + | "==" { EQUALEQUAL } + | "==f" { EQUALEQUALF } + | "==u" { EQUALEQUALU } + | "exit" { EXIT } + | "extern" { EXTERN } + | "float" { FLOAT } + | "float32" { FLOAT32 } + | "float64" { FLOAT64 } + | "floatofint" { FLOATOFINT } + | "floatofintu" { FLOATOFINTU } + | ">" { GREATER } + | ">f" { GREATERF } + | ">u" { GREATERU } + | ">=" { GREATEREQUAL } + | ">=f" { GREATEREQUALF } + | ">=u" { GREATEREQUALU } + | ">>" { GREATERGREATER } + | ">>u" { GREATERGREATERU } + | "if" { IF } + | "in" { IN } + | "int" { INT } + | "int16s" { INT16S } + | "int16u" { INT16U } + | "int32" { INT32 } + | "int8s" { INT8S } + | "int8u" { INT8U } + | "intoffloat" { INTOFFLOAT } + | "intuoffloat" { INTUOFFLOAT } + | "{" { LBRACE } + | "{{" { LBRACELBRACE } + | "[" { LBRACKET } + | "<" { LESS } + | "" { MINUSGREATER } + | "-f" { MINUSF } + | "%" { PERCENT } + | "%u" { PERCENTU } + | "+" { PLUS } + | "+f" { PLUSF } + | "?" { QUESTION } + | "}" { RBRACE } + | "}}" { RBRACERBRACE } + | "]" { RBRACKET } + | "return" { RETURN } + | ")" { RPAREN } + | ";" { SEMICOLON } + | "/" { SLASH } + | "/f" { SLASHF } + | "/u" { SLASHU } + | "stack" { STACK } + | "*" { STAR } + | "*f" { STARF } + | "switch" { SWITCH } + | "tailcall" { TAILCALL } + | "~" { TILDE } + | "var" { VAR } + | "void" { VOID } + + | intlit { INTLIT(Int32.of_string(Lexing.lexeme lexbuf)) } + | floatlit { FLOATLIT(float_of_string(Lexing.lexeme lexbuf)) } + | stringlit { let s = Lexing.lexeme lexbuf in + STRINGLIT(intern_string(String.sub s 1 (String.length s - 2))) } + | ident { IDENT(intern_string(Lexing.lexeme lexbuf)) } + | eof { EOF } + | _ { raise(Error("illegal character `" ^ Char.escaped (Lexing.lexeme_char lexbuf 0) ^ "'")) } + +and comment = parse + "*/" { () } + | eof { raise(Error "unterminated comment") } + | _ { comment lexbuf } diff --git a/backend/CMparser.mly b/backend/CMparser.mly new file mode 100644 index 0000000..25fb032 --- /dev/null +++ b/backend/CMparser.mly @@ -0,0 +1,541 @@ +/* *********************************************************************/ +/* */ +/* The Compcert verified compiler */ +/* */ +/* Xavier Leroy, INRIA Paris-Rocquencourt */ +/* */ +/* Copyright Institut National de Recherche en Informatique et en */ +/* Automatique. All rights reserved. This file is distributed */ +/* under the terms of the GNU General Public License as published by */ +/* the Free Software Foundation, either version 2 of the License, or */ +/* (at your option) any later version. This file is also distributed */ +/* under the terms of the INRIA Non-Commercial License Agreement. */ +/* */ +/* *********************************************************************/ + +%{ +open Datatypes +open CList +open Camlcoq +open BinPos +open BinInt +open Integers +open AST +open Cminor + +(** Naming function calls in expressions *) + +type rexpr = + | Rvar of ident + | Rconst of constant + | Runop of unary_operation * rexpr + | Rbinop of binary_operation * rexpr * rexpr + | Rload of memory_chunk * rexpr + | Rcondition of rexpr * rexpr * rexpr + | Rcall of signature * rexpr * rexpr list + | Ralloc of rexpr + +let temp_counter = ref 0 + +let temporaries = ref [] + +let mktemp () = + incr temp_counter; + let n = Printf.sprintf "__t%d" !temp_counter in + let id = intern_string n in + temporaries := id :: !temporaries; + id + +let convert_accu = ref [] + +let rec convert_rexpr = function + | Rvar id -> Evar id + | Rconst c -> Econst c + | Runop(op, e1) -> Eunop(op, convert_rexpr e1) + | Rbinop(op, e1, e2) -> + let c1 = convert_rexpr e1 in + let c2 = convert_rexpr e2 in + Ebinop(op, c1, c2) + | Rload(chunk, e1) -> Eload(chunk, convert_rexpr e1) + | Rcondition(e1, e2, e3) -> + let c1 = convert_rexpr e1 in + let c2 = convert_rexpr e2 in + let c3 = convert_rexpr e3 in + Econdition(c1, c2, c3) + | Rcall(sg, e1, el) -> + let c1 = convert_rexpr e1 in + let cl = convert_rexpr_list el in + let t = mktemp() in + convert_accu := Scall(Some t, sg, c1, cl) :: !convert_accu; + Evar t + | Ralloc e1 -> + let c1 = convert_rexpr e1 in + let t = mktemp() in + convert_accu := Salloc(t, c1) :: !convert_accu; + Evar t + +and convert_rexpr_list = function + | [] -> [] + | e1 :: el -> + let c1 = convert_rexpr e1 in + let cl = convert_rexpr_list el in + c1 :: cl + +let rec prepend_seq stmts last = + match stmts with + | [] -> last + | s1 :: sl -> prepend_seq sl (Sseq(s1, last)) + +let mkeval e = + convert_accu := []; + match e with + | Rcall(sg, e1, el) -> + let c1 = convert_rexpr e1 in + let cl = convert_rexpr_list el in + prepend_seq !convert_accu (Scall(None, sg, c1, cl)) + | _ -> + ignore (convert_rexpr e); + prepend_seq !convert_accu Sskip + +let mkassign id e = + convert_accu := []; + match e with + | Rcall(sg, e1, el) -> + let c1 = convert_rexpr e1 in + let cl = convert_rexpr_list el in + prepend_seq !convert_accu (Scall(Some id, sg, c1, cl)) + | Ralloc(e1) -> + let c1 = convert_rexpr e1 in + prepend_seq !convert_accu (Salloc(id, c1)) + | _ -> + let c = convert_rexpr e in + prepend_seq !convert_accu (Sassign(id, c)) + +let mkstore chunk e1 e2 = + convert_accu := []; + let c1 = convert_rexpr e1 in + let c2 = convert_rexpr e2 in + prepend_seq !convert_accu (Sstore(chunk, c1, c2)) + +let mkifthenelse e s1 s2 = + convert_accu := []; + let c = convert_rexpr e in + prepend_seq !convert_accu (Sifthenelse(c, s1, s2)) + +let mkreturn_some e = + convert_accu := []; + let c = convert_rexpr e in + prepend_seq !convert_accu (Sreturn (Some c)) + +let mktailcall sg e1 el = + convert_accu := []; + let c1 = convert_rexpr e1 in + let cl = convert_rexpr_list el in + prepend_seq !convert_accu (Stailcall(sg, c1, cl)) + +(** Other constructors *) + +let intconst n = + Rconst(Ointconst(coqint_of_camlint n)) + +let andbool e1 e2 = + Rcondition(e1, e2, intconst 0l) +let orbool e1 e2 = + Rcondition(e1, intconst 1l, e2) + +let exitnum n = nat_of_camlint(Int32.pred n) + +let mkswitch expr (cases, dfl) = + convert_accu := []; + let c = convert_rexpr expr in + let rec mktable = function + | [] -> [] + | (key, exit) :: rem -> + Coq_pair(coqint_of_camlint key, exitnum exit) :: mktable rem in + prepend_seq !convert_accu (Sswitch(c, 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] -> [] + | (key, action) :: rem -> + 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 = + convert_accu := []; + let c = convert_rexpr expr in + let s = + match cases with + | [] -> Sskip (* ??? *) + | [key, action] -> action + | _ -> mkmatch_aux c cases in + prepend_seq !convert_accu s + +%} + +%token ABSF +%token AMPERSAND +%token AMPERSANDAMPERSAND +%token ALLOC +%token BANG +%token BANGEQUAL +%token BANGEQUALF +%token BANGEQUALU +%token BAR +%token BARBAR +%token CARET +%token CASE +%token COLON +%token COMMA +%token DEFAULT +%token DOLLAR +%token ELSE +%token EQUAL +%token EQUALEQUAL +%token EQUALEQUALF +%token EQUALEQUALU +%token EOF +%token EXIT +%token EXTERN +%token FLOAT +%token FLOAT32 +%token FLOAT64 +%token FLOATLIT +%token FLOATOFINT +%token FLOATOFINTU +%token GREATER +%token GREATERF +%token GREATERU +%token GREATEREQUAL +%token GREATEREQUALF +%token GREATEREQUALU +%token GREATERGREATER +%token GREATERGREATERU +%token IDENT +%token IF +%token IN +%token INT +%token INT16S +%token INT16U +%token INT32 +%token INT8S +%token INT8U +%token INTLIT +%token INTOFFLOAT +%token INTUOFFLOAT +%token LBRACE +%token LBRACELBRACE +%token LBRACKET +%token LESS +%token LESSU +%token LESSF +%token LESSEQUAL +%token LESSEQUALU +%token LESSEQUALF +%token LESSLESS +%token LET +%token LOOP +%token LPAREN +%token MATCH +%token MINUS +%token MINUSF +%token MINUSGREATER +%token PERCENT +%token PERCENTU +%token PLUS +%token PLUSF +%token QUESTION +%token RBRACE +%token RBRACERBRACE +%token RBRACKET +%token RETURN +%token RPAREN +%token SEMICOLON +%token SLASH +%token SLASHF +%token SLASHU +%token STACK +%token STAR +%token STARF +%token STRINGLIT +%token SWITCH +%token TILDE +%token TAILCALL +%token VAR +%token VOID + +/* Precedences from low to high */ + +%left COMMA +%left p_let +%right EQUAL +%right QUESTION COLON +%left BARBAR +%left AMPERSANDAMPERSAND +%left BAR +%left CARET +%left AMPERSAND +%left EQUALEQUAL BANGEQUAL LESS LESSEQUAL GREATER GREATEREQUAL EQUALEQUALU BANGEQUALU LESSU LESSEQUALU GREATERU GREATEREQUALU EQUALEQUALF BANGEQUALF LESSF LESSEQUALF GREATERF GREATEREQUALF +%left LESSLESS GREATERGREATER GREATERGREATERU +%left PLUS PLUSF MINUS MINUSF +%left STAR SLASH PERCENT STARF SLASHF SLASHU PERCENTU +%nonassoc BANG TILDE p_uminus ABSF INTOFFLOAT INTUOFFLOAT FLOATOFINT FLOATOFINTU INT8S INT8U INT16S INT16U FLOAT32 ALLOC +%left LPAREN + +/* Entry point */ + +%start prog +%type prog + +%% + +/* Programs */ + +prog: + global_declarations proc_list EOF + { { prog_funct = CList.rev $2; + prog_main = intern_string "main"; + prog_vars = CList.rev $1; } } +; + +global_declarations: + /* empty */ { [] } + | global_declarations global_declaration { $2 :: $1 } +; + +global_declaration: + VAR STRINGLIT LBRACKET INTLIT RBRACKET + { Coq_pair(Coq_pair($2, [ Init_space (z_of_camlint $4) ]), ()) } +; + +proc_list: + /* empty */ { [] } + | proc_list proc { $2 :: $1 } +; + +/* Procedures */ + +proc: + STRINGLIT LPAREN parameters RPAREN COLON signature + LBRACE + stack_declaration + var_declarations + stmt_list + RBRACE + { let tmp = !temporaries in + temporaries := []; + temp_counter := 0; + Coq_pair($1, + Internal { fn_sig = $6; + fn_params = CList.rev $3; + fn_vars = CList.rev (CList.app tmp $9); + fn_stackspace = $8; + fn_body = $10 }) } + | EXTERN STRINGLIT COLON signature + { Coq_pair($2, + External { ef_id = $2; + ef_sig = $4 }) } +; + +signature: + type_ + { {sig_args = []; sig_res = Some $1} } + | VOID + { {sig_args = []; sig_res = None} } + | type_ MINUSGREATER signature + { let s = $3 in {s with sig_args = $1 :: s.sig_args} } +; + +parameters: + /* empty */ { [] } + | parameter_list { $1 } +; + +parameter_list: + IDENT { $1 :: [] } + | parameter_list COMMA IDENT { $3 :: $1 } +; + +stack_declaration: + /* empty */ { Z0 } + | STACK INTLIT SEMICOLON { z_of_camlint $2 } +; + +var_declarations: + /* empty */ { [] } + | var_declarations var_declaration { CList.app $2 $1 } +; + +var_declaration: + VAR parameter_list SEMICOLON { $2 } +; + +/* Statements */ + +stmt: + expr SEMICOLON { mkeval $1 } + | IDENT EQUAL expr SEMICOLON { mkassign $1 $3 } + | memory_chunk LBRACKET expr RBRACKET EQUAL expr SEMICOLON + { mkstore $1 $3 $6 } + | IF LPAREN expr RPAREN stmts ELSE stmts { mkifthenelse $3 $5 $7 } + | IF LPAREN expr RPAREN stmts { mkifthenelse $3 $5 Sskip } + | LOOP stmts { Sloop($2) } + | LBRACELBRACE stmt_list RBRACERBRACE { Sblock($2) } + | EXIT SEMICOLON { Sexit O } + | EXIT INTLIT SEMICOLON { Sexit (exitnum $2) } + | RETURN SEMICOLON { Sreturn None } + | RETURN expr SEMICOLON { mkreturn_some $2 } + | SWITCH LPAREN expr RPAREN LBRACE switch_cases RBRACE + { mkswitch $3 $6 } + | MATCH LPAREN expr RPAREN LBRACE match_cases RBRACE + { mkmatch $3 $6 } + | TAILCALL expr LPAREN expr_list RPAREN COLON signature SEMICOLON + { mktailcall $7 $2 $4 } +; + +stmts: + LBRACE stmt_list RBRACE { $2 } + | stmt { $1 } +; + +stmt_list: + /* empty */ { Sskip } + | 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 { Rvar $1 } + | INTLIT { intconst $1 } + | FLOATLIT { Rconst(Ofloatconst $1) } + | STRINGLIT { Rconst(Oaddrsymbol($1, Int.zero)) } + | AMPERSAND INTLIT { Rconst(Oaddrstack(coqint_of_camlint $2)) } + | MINUS expr %prec p_uminus { Rbinop(Osub, intconst 0l, $2) } /***FIXME***/ + | MINUSF expr %prec p_uminus { Runop(Onegf, $2) } + | ABSF expr { Runop(Oabsf, $2) } + | INTOFFLOAT expr { Runop(Ointoffloat, $2) } + | INTUOFFLOAT expr { Runop(Ointuoffloat, $2) } + | FLOATOFINT expr { Runop(Ofloatofint, $2) } + | FLOATOFINTU expr { Runop(Ofloatofintu, $2) } + | TILDE expr { Runop(Onotint, $2) } + | BANG expr { Runop(Onotbool, $2) } + | INT8S expr { Runop(Ocast8signed, $2) } + | INT8U expr { Runop(Ocast8unsigned, $2) } + | INT16S expr { Runop(Ocast16signed, $2) } + | INT16U expr { Runop(Ocast16unsigned, $2) } + | FLOAT32 expr { Runop(Osingleoffloat, $2) } + | expr PLUS expr { Rbinop(Oadd, $1, $3) } + | expr MINUS expr { Rbinop(Osub, $1, $3) } + | expr STAR expr { Rbinop(Omul, $1, $3) } + | expr SLASH expr { Rbinop(Odiv, $1, $3) } + | expr PERCENT expr { Rbinop(Omod, $1, $3) } + | expr SLASHU expr { Rbinop(Odivu, $1, $3) } + | expr PERCENTU expr { Rbinop(Omodu, $1, $3) } + | expr AMPERSAND expr { Rbinop(Oand, $1, $3) } + | expr BAR expr { Rbinop(Oor, $1, $3) } + | expr CARET expr { Rbinop(Oxor, $1, $3) } + | expr LESSLESS expr { Rbinop(Oshl, $1, $3) } + | expr GREATERGREATER expr { Rbinop(Oshr, $1, $3) } + | expr GREATERGREATERU expr { Rbinop(Oshru, $1, $3) } + | expr PLUSF expr { Rbinop(Oaddf, $1, $3) } + | expr MINUSF expr { Rbinop(Osubf, $1, $3) } + | expr STARF expr { Rbinop(Omulf, $1, $3) } + | expr SLASHF expr { Rbinop(Odivf, $1, $3) } + | expr EQUALEQUAL expr { Rbinop(Ocmp Ceq, $1, $3) } + | expr BANGEQUAL expr { Rbinop(Ocmp Cne, $1, $3) } + | expr LESS expr { Rbinop(Ocmp Clt, $1, $3) } + | expr LESSEQUAL expr { Rbinop(Ocmp Cle, $1, $3) } + | expr GREATER expr { Rbinop(Ocmp Cgt, $1, $3) } + | expr GREATEREQUAL expr { Rbinop(Ocmp Cge, $1, $3) } + | expr EQUALEQUALU expr { Rbinop(Ocmpu Ceq, $1, $3) } + | expr BANGEQUALU expr { Rbinop(Ocmpu Cne, $1, $3) } + | expr LESSU expr { Rbinop(Ocmpu Clt, $1, $3) } + | expr LESSEQUALU expr { Rbinop(Ocmpu Cle, $1, $3) } + | expr GREATERU expr { Rbinop(Ocmpu Cgt, $1, $3) } + | expr GREATEREQUALU expr { Rbinop(Ocmpu Cge, $1, $3) } + | expr EQUALEQUALF expr { Rbinop(Ocmpf Ceq, $1, $3) } + | expr BANGEQUALF expr { Rbinop(Ocmpf Cne, $1, $3) } + | expr LESSF expr { Rbinop(Ocmpf Clt, $1, $3) } + | expr LESSEQUALF expr { Rbinop(Ocmpf Cle, $1, $3) } + | expr GREATERF expr { Rbinop(Ocmpf Cgt, $1, $3) } + | expr GREATEREQUALF expr { Rbinop(Ocmpf Cge, $1, $3) } + | memory_chunk LBRACKET expr RBRACKET { Rload($1, $3) } + | expr AMPERSANDAMPERSAND expr { andbool $1 $3 } + | expr BARBAR expr { orbool $1 $3 } + | expr QUESTION expr COLON expr { Rcondition($1, $3, $5) } + | expr LPAREN expr_list RPAREN COLON signature{ Rcall($6, $1, $3) } + | ALLOC expr { Ralloc $2 } +; + +expr_list: + /* empty */ { [] } + | expr_list_1 { $1 } +; + +expr_list_1: + expr %prec COMMA { $1 :: [] } + | expr COMMA expr_list_1 { $1 :: $3 } +; + +memory_chunk: + INT8S { Mint8signed } + | INT8U { Mint8unsigned } + | INT16S { Mint16signed } + | INT16U { Mint16unsigned } + | INT32 { Mint32 } + | INT { Mint32 } + | FLOAT32 { Mfloat32 } + | FLOAT64 { Mfloat64 } + | FLOAT { Mfloat64 } +; + +/* Types */ + +type_: + INT { Tint } + | FLOAT { Tfloat } +; diff --git a/backend/CMtypecheck.ml b/backend/CMtypecheck.ml new file mode 100644 index 0000000..d761f75 --- /dev/null +++ b/backend/CMtypecheck.ml @@ -0,0 +1,370 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU General Public License as published by *) +(* the Free Software Foundation, either version 2 of the License, or *) +(* (at your option) any later version. This file is also distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(* A type-checker for Cminor *) + +open Printf +open Datatypes +open CList +open Camlcoq +open AST +open Integers +open Cminor + +exception Error of string + +let name_of_typ = function Tint -> "int" | Tfloat -> "float" + +type ty = Base of typ | Var of ty option ref + +let newvar () = Var (ref None) +let tint = Base Tint +let tfloat = Base Tfloat + +let ty_of_typ = function Tint -> tint | Tfloat -> tfloat + +let ty_of_sig_args tyl = List.map ty_of_typ tyl + +let rec repr t = + match t with + | Base _ -> t + | Var r -> match !r with None -> t | Some t' -> repr t' + +let unify t1 t2 = + match (repr t1, repr t2) with + | Base b1, Base b2 -> + if b1 <> b2 then + raise (Error (sprintf "Expected type %s, actual type %s\n" + (name_of_typ b1) (name_of_typ b2))) + | Base b, Var r -> r := Some (Base b) + | Var r, Base b -> r := Some (Base b) + | Var r1, Var r2 -> r1 := Some (Var r2) + +let unify_list l1 l2 = + let ll1 = List.length l1 and ll2 = List.length l2 in + if ll1 <> ll2 then + raise (Error (sprintf "Arity mismatch: expected %d, actual %d\n" ll1 ll2)); + List.iter2 unify l1 l2 + +let type_var env id = + try + List.assoc id env + with Not_found -> + raise (Error (sprintf "Unbound variable %s\n" (extern_atom id))) + +let type_letvar env n = + let n = camlint_of_nat n in + try + List.nth env n + with Not_found -> + raise (Error (sprintf "Unbound let variable #%d\n" n)) + +let name_of_comparison = function + | Ceq -> "eq" + | Cne -> "ne" + | Clt -> "lt" + | Cle -> "le" + | Cgt -> "gt" + | Cge -> "ge" + +let type_constant = function + | Ointconst _ -> tint + | Ofloatconst _ -> tfloat + | Oaddrsymbol _ -> tint + | Oaddrstack _ -> tint + +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 + | Ointuoffloat -> tfloat, tint + | Ofloatofint -> tint, tfloat + | Ofloatofintu -> tint, tfloat + +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_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) + +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" + | Ointuoffloat -> "intuoffloat" + | Ofloatofint -> "floatofint" + | Ofloatofintu -> "floatofintu" + +let name_of_binary_operation = function + | Oadd -> "add" + | Osub -> "sub" + | Omul -> "mul" + | Odiv -> "div" + | Odivu -> "divu" + | Omod -> "mod" + | Omodu -> "modu" + | Oand -> "and" + | Oor -> "or" + | Oxor -> "xor" + | Oshl -> "shl" + | Oshr -> "shr" + | Oshru -> "shru" + | Oaddf -> "addf" + | Osubf -> "subf" + | Omulf -> "mulf" + | Odivf -> "divf" + | 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 + | Mint8unsigned -> tint + | Mint16signed -> tint + | Mint16unsigned -> tint + | Mint32 -> tint + | Mfloat32 -> tfloat + | Mfloat64 -> tfloat + +let name_of_chunk = function + | Mint8signed -> "int8signed" + | Mint8unsigned -> "int8unsigned" + | Mint16signed -> "int16signed" + | Mint16unsigned -> "int16unsigned" + | Mint32 -> "int32" + | Mfloat32 -> "float32" + | Mfloat64 -> "float64" + +let rec type_expr env lenv e = + match e with + | Evar id -> + type_var env id + | 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 targ te1 + with Error s -> + raise (Error (sprintf "In application of operator %s:\n%s" + (name_of_unary_operation op) s)) + end; + tres + | 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 targ1 te1; unify targ2 te2 + with Error 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 + | Econdition(e1, e2, e3) -> + type_condexpr env lenv e1; + let te2 = type_expr env lenv e2 in + let te3 = type_expr env lenv e3 in + begin try + unify te2 te3 + with Error s -> + raise (Error (sprintf "In conditional expression:\n%s" s)) + end; + te2 +(* + | Elet(e1, e2) -> + let te1 = type_expr env lenv e1 in + let te2 = type_expr env (te1 :: lenv) e2 in + te2 + | Eletvar n -> + type_letvar lenv n +*) + +and type_exprlist env lenv el = + match el with + | [] -> [] + | e1 :: et -> + let te1 = type_expr env lenv e1 in + let tet = type_exprlist env lenv et in + (te1 :: tet) + +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 + | Sskip -> () + | Sassign(id, e1) -> + let tid = type_var env id in + let te1 = type_expr env [] e1 in + begin try + unify tid te1 + with Error s -> + raise (Error (sprintf "In assignment to %s:\n%s" (extern_atom id) s)) + end + | Sstore(chunk, e1, e2) -> + let te1 = type_expr env [] e1 in + let te2 = type_expr env [] e2 in + begin try + unify tint te1; + unify (type_chunk chunk) te2 + with Error s -> + raise (Error (sprintf "In store %s:\n%s" + (name_of_chunk chunk) s)) + end + | Scall(optid, 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; + let ty_res = + match sg.sig_res with + | None -> tint (*???*) + | Some t -> ty_of_typ t in + begin match optid with + | None -> () + | Some id -> unify (type_var env id) ty_res + end + with Error s -> + raise (Error (sprintf "In call:\n%s" s)) + end + | Salloc(id, e) -> + let tid = type_var env id in + let te = type_expr env [] e in + begin try + unify tint te; + unify tint tid + with Error s -> + raise (Error (sprintf "In alloc:\n%s" s)) + end + | Sseq(s1, s2) -> + type_stmt env blk ret s1; + type_stmt env blk ret s2 + | Sifthenelse(ce, s1, s2) -> + type_condexpr env [] ce; + type_stmt env blk ret s1; + type_stmt env blk ret s2 + | Sloop s1 -> + type_stmt env blk ret s1 + | Sblock s1 -> + type_stmt env (blk + 1) ret s1 + | Sexit n -> + if camlint_of_nat n >= blk then + raise (Error (sprintf "Bad exit(%d)\n" (camlint_of_nat n))) + | Sswitch(e, cases, deflt) -> + unify (type_expr env [] e) tint + | Sreturn None -> + begin match ret with + | None -> () + | Some tret -> raise (Error ("return without argument")) + end + | Sreturn (Some e) -> + begin match ret with + | None -> raise (Error "return with argument") + | Some tret -> + begin try + unify (type_expr env [] e) (ty_of_typ tret) + with Error 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 + | Slabel(lbl, s1) -> + type_stmt env blk ret s1 + | Sgoto lbl -> + () + +let rec env_of_vars idl = + match idl with + | [] -> [] + | id1 :: idt -> (id1, newvar()) :: env_of_vars idt + +let type_function id f = + try + type_stmt + (env_of_vars f.fn_vars @ env_of_vars f.fn_params) + 0 f.fn_sig.sig_res f.fn_body + with Error s -> + raise (Error (sprintf "In function %s:\n%s" (extern_atom id) s)) + +let type_fundef (Coq_pair (id, fd)) = + match fd with + | Internal f -> type_function id f + | External ef -> () + +let type_program p = + List.iter type_fundef p.prog_funct; p diff --git a/backend/CMtypecheck.mli b/backend/CMtypecheck.mli new file mode 100644 index 0000000..44c7654 --- /dev/null +++ b/backend/CMtypecheck.mli @@ -0,0 +1,19 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU General Public License as published by *) +(* the Free Software Foundation, either version 2 of the License, or *) +(* (at your option) any later version. This file is also distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +exception Error of string + +val type_program: Cminor.program -> Cminor.program + diff --git a/backend/CSE.v b/backend/CSE.v index b7e19c1..49b8489 100644 --- a/backend/CSE.v +++ b/backend/CSE.v @@ -72,12 +72,9 @@ Definition eq_rhs (x y: rhs) : {x=y}+{x<>y}. Proof. generalize Int.eq_dec; intro. generalize Float.eq_dec; intro. - assert (forall (x y: ident), {x=y}+{x<>y}). exact peq. - assert (forall (x y: comparison), {x=y}+{x<>y}). decide equality. - assert (forall (x y: condition), {x=y}+{x<>y}). decide equality. - assert (forall (x y: operation), {x=y}+{x<>y}). decide equality. + generalize eq_operation; intro. + generalize eq_addressing; intro. assert (forall (x y: memory_chunk), {x=y}+{x<>y}). decide equality. - assert (forall (x y: addressing), {x=y}+{x<>y}). decide equality. generalize eq_valnum; intro. generalize eq_list_valnum; intro. decide equality. diff --git a/backend/Coloringaux.ml b/backend/Coloringaux.ml new file mode 100644 index 0000000..19efe43 --- /dev/null +++ b/backend/Coloringaux.ml @@ -0,0 +1,626 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +open Camlcoq +open Datatypes +open BinPos +open BinInt +open AST +open Maps +open Registers +open Machregs +open Locations +open RTL +open RTLtyping +open InterfGraph +open Conventions + +(* George-Appel graph coloring *) + +(* \subsection{Internal representation of the interference graph} *) + +(* To implement George-Appel coloring, we first transform the representation + of the interference graph, switching to the following + imperative representation that is well suited to the coloring algorithm. *) + +(* Each node of the graph (i.e. each pseudo-register) is represented as + follows. *) + +type node = + { ident: reg; (*r register identifier *) + typ: typ; (*r its type *) + regclass: int; (*r identifier of register class *) + spillcost: float; (*r estimated cost of spilling *) + mutable adjlist: node list; (*r all nodes it interferes with *) + mutable degree: int; (*r number of adjacent nodes *) + mutable movelist: move list; (*r list of moves it is involved in *) + mutable alias: node option; (*r [Some n] if coalesced with [n] *) + mutable color: loc option; (*r chosen color *) + mutable nstate: nodestate; (*r in which set of nodes it is *) + mutable nprev: node; (*r for double linking *) + mutable nnext: node (*r for double linking *) + } + +(* These are the possible states for nodes. *) + +and nodestate = + | Colored + | Initial + | SimplifyWorklist + | FreezeWorklist + | SpillWorklist + | CoalescedNodes + | SelectStack + +(* Each move (i.e. wish to be put in the same location) is represented + as follows. *) + +and move = + { src: node; (*r source of the move *) + dst: node; (*r destination of the move *) + mutable mstate: movestate; (*r in which set of moves it is *) + mutable mprev: move; (*r for double linking *) + mutable mnext: move (*r for double linking *) + } + +(* These are the possible states for moves *) + +and movestate = + | CoalescedMoves + | ConstrainedMoves + | FrozenMoves + | WorklistMoves + | ActiveMoves + +(* The algorithm manipulates partitions of the nodes and of the moves + according to their states, frequently moving a node or a move from + a state to another, and frequently enumerating all nodes or all moves + of a given state. To support these operations efficiently, + nodes or moves having the same state are put into imperative doubly-linked + lists, allowing for constant-time insertion and removal, and linear-time + scanning. We now define the operations over these doubly-linked lists. *) + +module DLinkNode = struct + type t = node + let make state = + let rec empty = + { ident = Coq_xH; typ = Tint; regclass = 0; + adjlist = []; degree = 0; spillcost = 0.0; + movelist = []; alias = None; color = None; + nstate = state; nprev = empty; nnext = empty } + in empty + let dummy = make Colored + let clear dl = dl.nnext <- dl; dl.nprev <- dl + let notempty dl = dl.nnext != dl + let insert n dl = + n.nstate <- dl.nstate; + n.nnext <- dl.nnext; n.nprev <- dl; + dl.nnext.nprev <- n; dl.nnext <- n + let remove n dl = + assert (n.nstate = dl.nstate); + n.nnext.nprev <- n.nprev; n.nprev.nnext <- n.nnext + let move n dl1 dl2 = + remove n dl1; insert n dl2 + let pick dl = + let n = dl.nnext in remove n dl; n + let iter f dl = + let rec iter n = if n != dl then (f n; iter n.nnext) + in iter dl.nnext + let fold f dl accu = + let rec fold n accu = if n == dl then accu else fold n.nnext (f n accu) + in fold dl.nnext accu +end + +module DLinkMove = struct + type t = move + let make state = + let rec empty = + { src = DLinkNode.dummy; dst = DLinkNode.dummy; + mstate = state; mprev = empty; mnext = empty } + in empty + let dummy = make CoalescedMoves + let clear dl = dl.mnext <- dl; dl.mprev <- dl + let notempty dl = dl.mnext != dl + let insert m dl = + m.mstate <- dl.mstate; + m.mnext <- dl.mnext; m.mprev <- dl; + dl.mnext.mprev <- m; dl.mnext <- m + let remove m dl = + assert (m.mstate = dl.mstate); + m.mnext.mprev <- m.mprev; m.mprev.mnext <- m.mnext + let move m dl1 dl2 = + remove m dl1; insert m dl2 + let pick dl = + let m = dl.mnext in remove m dl; m + let iter f dl = + let rec iter m = if m != dl then (f m; iter m.mnext) + in iter dl.mnext + let fold f dl accu = + let rec fold m accu = if m == dl then accu else fold m.mnext (f m accu) + in fold dl.mnext accu +end + +(* \subsection{The George-Appel algorithm} *) + +(* Below is a straigthforward translation of the pseudo-code at the end + of the TOPLAS article by George and Appel. Two bugs were fixed + and are marked as such. Please refer to the article for explanations. *) + +(* Low-degree, non-move-related nodes *) +let simplifyWorklist = DLinkNode.make SimplifyWorklist + +(* Low-degree, move-related nodes *) +let freezeWorklist = DLinkNode.make FreezeWorklist + +(* High-degree nodes *) +let spillWorklist = DLinkNode.make SpillWorklist + +(* Nodes that have been coalesced *) +let coalescedNodes = DLinkNode.make CoalescedNodes + +(* Moves that have been coalesced *) +let coalescedMoves = DLinkMove.make CoalescedMoves + +(* Moves whose source and destination interfere *) +let constrainedMoves = DLinkMove.make ConstrainedMoves + +(* Moves that will no longer be considered for coalescing *) +let frozenMoves = DLinkMove.make FrozenMoves + +(* Moves enabled for possible coalescing *) +let worklistMoves = DLinkMove.make WorklistMoves + +(* Moves not yet ready for coalescing *) +let activeMoves = DLinkMove.make ActiveMoves + +(* Initialization of all global data structures *) + +let init() = + DLinkNode.clear simplifyWorklist; + DLinkNode.clear freezeWorklist; + DLinkNode.clear spillWorklist; + DLinkNode.clear coalescedNodes; + DLinkMove.clear coalescedMoves; + DLinkMove.clear frozenMoves; + DLinkMove.clear worklistMoves; + DLinkMove.clear activeMoves + +(* Determine if two nodes interfere *) + +let interfere n1 n2 = + if n1.degree < n2.degree + 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 *) + +let addEdge n1 n2 = + n1.adjlist <- n2 :: n1.adjlist; + n1.degree <- 1 + n1.degree; + n2.adjlist <- n1 :: n2.adjlist; + n2.degree <- 1 + n2.degree + +(* Apply the given function to the relevant adjacent nodes of a node *) + +let iterAdjacent f n = + List.iter + (fun n -> + match n.nstate with + | SelectStack | CoalescedNodes -> () + | _ -> f n) + n.adjlist + +(* Determine the moves affecting a node *) + +let moveIsActiveOrWorklist m = + match m.mstate with + | ActiveMoves | WorklistMoves -> true + | _ -> false + +let nodeMoves n = + List.filter moveIsActiveOrWorklist n.movelist + +(* Determine whether a node is involved in a move *) + +let moveRelated n = + List.exists moveIsActiveOrWorklist n.movelist + +(*i +(* Check invariants *) + +let degreeInvariant n = + let c = ref 0 in + iterAdjacent (fun n -> incr c) n; + if !c <> n.degree then + fatal_error("degree invariant violated by " ^ name_of_node n) + +let simplifyWorklistInvariant n = + if n.degree < num_available_registers.(n.regclass) + && not (moveRelated n) + then () + else fatal_error("simplify worklist invariant violated by " ^ name_of_node n) + +let freezeWorklistInvariant n = + if n.degree < num_available_registers.(n.regclass) + && moveRelated n + then () + else fatal_error("freeze worklist invariant violated by " ^ name_of_node n) + +let spillWorklistInvariant n = + if n.degree >= num_available_registers.(n.regclass) + then () + else fatal_error("spill worklist invariant violated by " ^ name_of_node n) + +let checkInvariants () = + DLinkNode.iter + (fun n -> degreeInvariant n; simplifyWorklistInvariant n) + simplifyWorklist; + DLinkNode.iter + (fun n -> degreeInvariant n; freezeWorklistInvariant n) + freezeWorklist; + DLinkNode.iter + (fun n -> degreeInvariant n; spillWorklistInvariant n) + spillWorklist +i*) + +(* Register classes *) + +let class_of_type = function Tint -> 0 | Tfloat -> 1 + +let num_register_classes = 2 + +let caller_save_registers = [| + Array.of_list Conventions.int_caller_save_regs; + Array.of_list Conventions.float_caller_save_regs +|] + +let callee_save_registers = [| + Array.of_list Conventions.int_callee_save_regs; + Array.of_list Conventions.float_callee_save_regs +|] + +let num_available_registers = + [| Array.length caller_save_registers.(0) + + Array.length callee_save_registers.(0); + Array.length caller_save_registers.(1) + + Array.length callee_save_registers.(1) |] + +(* Build the internal representation of the graph *) + +let nodeOfReg r typenv spillcosts = + let ty = typenv r in + { ident = r; typ = ty; regclass = class_of_type ty; + spillcost = (try float(Hashtbl.find spillcosts r) with Not_found -> 0.0); + adjlist = []; degree = 0; movelist = []; alias = None; + color = None; + nstate = Initial; + nprev = DLinkNode.dummy; nnext = DLinkNode.dummy } + +let nodeOfMreg mr = + let ty = mreg_type mr in + { ident = Coq_xH; typ = ty; regclass = class_of_type ty; + spillcost = 0.0; + adjlist = []; degree = 0; movelist = []; alias = None; + color = Some (R mr); + nstate = Colored; + nprev = DLinkNode.dummy; nnext = DLinkNode.dummy } + +let build g typenv spillcosts = + (* Associate an internal node to each pseudo-register and each location *) + let reg_mapping = Hashtbl.create 27 + and mreg_mapping = Hashtbl.create 27 in + let find_reg_node r = + try + Hashtbl.find reg_mapping r + with Not_found -> + let n = nodeOfReg r typenv spillcosts in + Hashtbl.add reg_mapping r n; + n + and find_mreg_node mr = + try + Hashtbl.find mreg_mapping mr + with Not_found -> + let n = nodeOfMreg mr in + Hashtbl.add mreg_mapping mr n; + n in + (* Fill the adjacency lists and compute the degrees. *) + SetRegReg.fold + (fun (Coq_pair(r1, r2)) () -> + addEdge (find_reg_node r1) (find_reg_node r2)) + g.interf_reg_reg (); + SetRegMreg.fold + (fun (Coq_pair(r1, mr2)) () -> + addEdge (find_reg_node r1) (find_mreg_node mr2)) + g.interf_reg_mreg (); + (* Process the moves and insert them in worklistMoves *) + let add_move n1 n2 = + let m = + { src = n1; dst = n2; mstate = WorklistMoves; + mnext = DLinkMove.dummy; mprev = DLinkMove.dummy } in + n1.movelist <- m :: n1.movelist; + n2.movelist <- m :: n2.movelist; + DLinkMove.insert m worklistMoves in + SetRegReg.fold + (fun (Coq_pair(r1, r2)) () -> + add_move (find_reg_node r1) (find_reg_node r2)) + g.pref_reg_reg (); + SetRegMreg.fold + (fun (Coq_pair(r1, mr2)) () -> + add_move (find_reg_node r1) (find_mreg_node mr2)) + g.pref_reg_mreg (); + (* Initial partition of nodes into spill / freeze / simplify *) + Hashtbl.iter + (fun r n -> + assert (n.nstate = Initial); + let k = num_available_registers.(n.regclass) in + if n.degree >= k then + DLinkNode.insert n spillWorklist + else if moveRelated n then + DLinkNode.insert n freezeWorklist + else + DLinkNode.insert n simplifyWorklist) + reg_mapping; + reg_mapping + +(* Enable moves that have become low-degree related *) + +let enableMoves n = + List.iter + (fun m -> + if m.mstate = ActiveMoves + then DLinkMove.move m activeMoves worklistMoves) + (nodeMoves n) + +(* Simulate the removal of a node from the graph *) + +let decrementDegree n = + let k = num_available_registers.(n.regclass) in + let d = n.degree in + n.degree <- d - 1; + if d = k then begin + enableMoves n; + iterAdjacent enableMoves n; + if n.nstate <> Colored then begin + if moveRelated n + then DLinkNode.move n spillWorklist freezeWorklist + else DLinkNode.move n spillWorklist simplifyWorklist + end + end + +(* Simulate the effect of combining nodes [n1] and [n3] on [n2], + where [n2] is a node adjacent to [n3]. *) + +let combineEdge n1 n2 = + assert (n1 != n2); + if interfere n1 n2 then begin + decrementDegree n2 + end else begin + n1.adjlist <- n2 :: n1.adjlist; + n2.adjlist <- n1 :: n2.adjlist; + n1.degree <- n1.degree + 1 + end + +(* Simplification of a low-degree node *) + +let simplify () = + let n = DLinkNode.pick simplifyWorklist in + (*i Printf.printf "Simplifying %s\n" (name_of_node n); i*) + n.nstate <- SelectStack; + iterAdjacent decrementDegree n; + n + +(* Briggs' conservative coalescing criterion *) + +let canConservativelyCoalesce n1 n2 = + let seen = ref Regset.empty in + let k = num_available_registers.(n1.regclass) in + let c = ref 0 in + let consider n = + if not (Regset.mem n.ident !seen) then begin + seen := Regset.add n.ident !seen; + if n.degree >= k then incr c + end in + iterAdjacent consider n1; + iterAdjacent consider n2; + !c < k + +(* Update worklists after a move was processed *) + +let addWorkList u = + if (not (u.nstate = Colored)) + && u.degree < num_available_registers.(u.regclass) + && (not (moveRelated u)) + then DLinkNode.move u freezeWorklist simplifyWorklist + +(* Return the canonical representative of a possibly coalesced node *) + +let rec getAlias n = + match n.alias with None -> n | Some n' -> getAlias n' + +(* Combine two nodes *) + +let combine u v = + (*i Printf.printf "Combining %s and %s\n" (name_of_node u) (name_of_node v); i*) + if v.nstate = FreezeWorklist + then DLinkNode.move v freezeWorklist coalescedNodes + else DLinkNode.move v spillWorklist coalescedNodes; + v.alias <- Some u; + u.movelist <- u.movelist @ v.movelist; + iterAdjacent (combineEdge u) v; (*r original code using [decrementDegree] is buggy *) + enableMoves v; (*r added as per Appel's book erratum *) + if u.degree >= num_available_registers.(u.regclass) + && u.nstate = FreezeWorklist + then DLinkNode.move u freezeWorklist spillWorklist + +(* Attempt coalescing *) + +let coalesce () = + let m = DLinkMove.pick worklistMoves in + let x = getAlias m.src and y = getAlias m.dst in + let (u, v) = if y.nstate = Colored then (y, x) else (x, y) in + if u == v then begin + DLinkMove.insert m coalescedMoves; + addWorkList u + end else if v.nstate = Colored || interfere u v then begin + DLinkMove.insert m constrainedMoves; + addWorkList u; + addWorkList v + end else if canConservativelyCoalesce u v then begin + DLinkMove.insert m coalescedMoves; + combine u v; + addWorkList u + end else begin + DLinkMove.insert m activeMoves + end + +(* Freeze moves associated with node [u] *) + +let freezeMoves u = + let au = getAlias u in + let freeze m = + let y = getAlias m.src in + let v = if y == au then getAlias m.dst else y in + DLinkMove.move m activeMoves frozenMoves; + if not (moveRelated v) + && v.degree < num_available_registers.(v.regclass) + && v.nstate <> Colored + then DLinkNode.move v freezeWorklist simplifyWorklist in + List.iter freeze (nodeMoves u) + +(* Pick a move and freeze it *) + +let freeze () = + let u = DLinkNode.pick freezeWorklist in + (*i Printf.printf "Freezing %s\n" (name_of_node u); i*) + DLinkNode.insert u simplifyWorklist; + freezeMoves u + +(* Chaitin's cost measure *) + +let spillCost n = n.spillcost /. float n.degree + +(* Spill a node *) + +let selectSpill () = + (* Find a spillable node of minimal cost *) + let (n, cost) = + DLinkNode.fold + (fun n (best_node, best_cost as best) -> + let cost = spillCost n in + if cost < best_cost then (n, cost) else best) + spillWorklist (DLinkNode.dummy, infinity) in + assert (n != DLinkNode.dummy); + DLinkNode.remove n spillWorklist; + (*i Printf.printf "Spilling %s\n" (name_of_node n); i*) + freezeMoves n; + n.nstate <- SelectStack; + iterAdjacent decrementDegree n; + n + +(* Produce the order of nodes that we'll use for coloring *) + +let rec nodeOrder stack = + (*i checkInvariants(); i*) + if DLinkNode.notempty simplifyWorklist then + (let n = simplify() in nodeOrder (n :: stack)) + else if DLinkMove.notempty worklistMoves then + (coalesce(); nodeOrder stack) + else if DLinkNode.notempty freezeWorklist then + (freeze(); nodeOrder stack) + else if DLinkNode.notempty spillWorklist then + (let n = selectSpill() in nodeOrder (n :: stack)) + else + stack + +(* Assign a color (i.e. a hardware register or a stack location) + to a node. The color is chosen among the colors that are not + assigned to nodes with which this node interferes. The choice + is guided by the following heuristics: consider first caller-save + hardware register of the correct type; second, callee-save registers; + third, a stack location. Callee-save registers and stack locations + are ``expensive'' resources, so we try to minimize their number + by picking the smallest available callee-save register or stack location. + In contrast, caller-save registers are ``free'', so we pick an + available one pseudo-randomly. *) + +module Locset = + Set.Make(struct type t = loc let compare = compare end) + +let start_points = Array.make num_register_classes 0 + +let find_reg conflicts regclass = + let rec find avail curr last = + if curr >= last then None else begin + let l = R avail.(curr) in + if Locset.mem l conflicts + then find avail (curr + 1) last + else Some l + end in + let caller_save = caller_save_registers.(regclass) + and callee_save = callee_save_registers.(regclass) + and start = start_points.(regclass) in + match find caller_save start (Array.length caller_save) with + | Some _ as res -> + start_points.(regclass) <- + (if start + 1 < Array.length caller_save then start + 1 else 0); + res + | None -> + match find caller_save 0 start with + | Some _ as res -> + start_points.(regclass) <- + (if start + 1 < Array.length caller_save then start + 1 else 0); + res + | None -> + find callee_save 0 (Array.length callee_save) + +let find_slot conflicts typ = + let rec find curr = + let l = S(Local(curr, typ)) in + if Locset.mem l conflicts then find (coq_Zsucc curr) else l + in find Z0 + +let assign_color n = + let conflicts = ref Locset.empty in + List.iter + (fun n' -> + match (getAlias n').color with + | None -> () + | Some l -> conflicts := Locset.add l !conflicts) + n.adjlist; + match find_reg !conflicts n.regclass with + | Some loc -> + n.color <- Some loc + | None -> + n.color <- Some (find_slot !conflicts n.typ) + +(* Extract the location of a node *) + +let location_of_node n = + match n.color with + | None -> assert false + | Some loc -> loc + +(* Estimate spilling costs - TODO *) + +let spill_costs f = Hashtbl.create 7 + +(* This is the entry point for graph coloring. *) + +let graph_coloring (f: coq_function) (g: graph) (env: regenv) (regs: Regset.t) + : (reg -> loc) = + init(); + Array.fill start_points 0 num_register_classes 0; + let mapping = build g env (spill_costs f) in + 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/backend/Coloringaux.mli b/backend/Coloringaux.mli new file mode 100644 index 0000000..c5070f2 --- /dev/null +++ b/backend/Coloringaux.mli @@ -0,0 +1,20 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +open Registers +open Locations +open RTL +open RTLtyping +open InterfGraph + +val graph_coloring: + coq_function -> graph -> regenv -> Regset.t -> (reg -> loc) diff --git a/backend/Constprop.v b/backend/Constprop.v deleted file mode 100644 index 75fb148..0000000 --- a/backend/Constprop.v +++ /dev/null @@ -1,1093 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** Constant propagation over RTL. This is the first of the two - optimizations performed at RTL level. It proceeds by a standard - dataflow analysis and the corresponding code transformation. *) - -Require Import Coqlib. -Require Import Maps. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import Globalenvs. -Require Import Op. -Require Import Registers. -Require Import RTL. -Require Import Lattice. -Require Import Kildall. - -(** * Static analysis *) - -(** To each pseudo-register at each program point, the static analysis - associates a compile-time approximation taken from the following set. *) - -Inductive approx : Set := - | Novalue: approx (** No value possible, code is unreachable. *) - | Unknown: approx (** All values are possible, - no compile-time information is available. *) - | I: int -> approx (** A known integer value. *) - | F: float -> approx (** A known floating-point value. *) - | S: ident -> int -> approx. - (** The value is the address of the given global - symbol plus the given integer offset. *) - -(** We equip this set of approximations with a semi-lattice structure. - The ordering is inclusion between the sets of values denoted by - the approximations. *) - -Module Approx <: SEMILATTICE_WITH_TOP. - Definition t := approx. - Definition eq (x y: t) := (x = y). - Definition eq_refl: forall x, eq x x := (@refl_equal t). - Definition eq_sym: forall x y, eq x y -> eq y x := (@sym_equal t). - Definition eq_trans: forall x y z, eq x y -> eq y z -> eq x z := (@trans_equal t). - Lemma eq_dec: forall (x y: t), {x=y} + {x<>y}. - Proof. - decide equality. - apply Int.eq_dec. - apply Float.eq_dec. - apply Int.eq_dec. - apply ident_eq. - Qed. - Definition beq (x y: t) := if eq_dec x y then true else false. - Lemma beq_correct: forall x y, beq x y = true -> x = y. - Proof. - unfold beq; intros. destruct (eq_dec x y). auto. congruence. - Qed. - Definition ge (x y: t) : Prop := - x = Unknown \/ y = Novalue \/ x = y. - Lemma ge_refl: forall x y, eq x y -> ge x y. - Proof. - unfold eq, ge; tauto. - Qed. - Lemma ge_trans: forall x y z, ge x y -> ge y z -> ge x z. - Proof. - unfold ge; intuition congruence. - Qed. - Lemma ge_compat: forall x x' y y', eq x x' -> eq y y' -> ge x y -> ge x' y'. - Proof. - unfold eq, ge; intros; congruence. - Qed. - Definition bot := Novalue. - Definition top := Unknown. - Lemma ge_bot: forall x, ge x bot. - Proof. - unfold ge, bot; tauto. - Qed. - Lemma ge_top: forall x, ge top x. - Proof. - unfold ge, bot; tauto. - Qed. - Definition lub (x y: t) : t := - if eq_dec x y then x else - match x, y with - | Novalue, _ => y - | _, Novalue => x - | _, _ => Unknown - end. - Lemma lub_commut: forall x y, eq (lub x y) (lub y x). - Proof. - unfold lub, eq; intros. - case (eq_dec x y); case (eq_dec y x); intros; try congruence. - destruct x; destruct y; auto. - Qed. - Lemma ge_lub_left: forall x y, ge (lub x y) x. - Proof. - unfold lub; intros. - case (eq_dec x y); intro. - apply ge_refl. apply eq_refl. - destruct x; destruct y; unfold ge; tauto. - Qed. -End Approx. - -Module D := LPMap Approx. - -(** We now define the abstract interpretations of conditions and operators - over this set of approximations. For instance, the abstract interpretation - of the operator [Oaddf] applied to two expressions [a] and [b] is - [F(Float.add f g)] if [a] and [b] have static approximations [Vfloat f] - and [Vfloat g] respectively, and [Unknown] otherwise. - - The static approximations are defined by large pattern-matchings over - the approximations of the results. We write these matchings in the - indirect style described in file [Cmconstr] to avoid excessive - duplication of cases in proofs. *) - -(* -Definition eval_static_condition (cond: condition) (vl: list approx) := - match cond, vl with - | Ccomp c, I n1 :: I n2 :: nil => Some(Int.cmp c n1 n2) - | Ccompu c, I n1 :: I n2 :: nil => Some(Int.cmpu c n1 n2) - | Ccompimm c n, I n1 :: nil => Some(Int.cmp c n1 n) - | Ccompuimm c n, I n1 :: nil => Some(Int.cmpu c n1 n) - | Ccompf c, F n1 :: F n2 :: nil => Some(Float.cmp c n1 n2) - | Cnotcompf c, F n1 :: F n2 :: nil => Some(negb(Float.cmp c n1 n2)) - | Cmaskzero n, I n1 :: nil => Some(Int.eq (Int.and n1 n) Int.zero) - | Cmasknotzero n, n1::nil => Some(negb(Int.eq (Int.and n1 n) Int.zero)) - | _, _ => None - end. -*) - -Inductive eval_static_condition_cases: forall (cond: condition) (vl: list approx), Set := - | eval_static_condition_case1: - forall c n1 n2, - eval_static_condition_cases (Ccomp c) (I n1 :: I n2 :: nil) - | eval_static_condition_case2: - forall c n1 n2, - eval_static_condition_cases (Ccompu c) (I n1 :: I n2 :: nil) - | eval_static_condition_case3: - forall c n n1, - eval_static_condition_cases (Ccompimm c n) (I n1 :: nil) - | eval_static_condition_case4: - forall c n n1, - eval_static_condition_cases (Ccompuimm c n) (I n1 :: nil) - | eval_static_condition_case5: - forall c n1 n2, - eval_static_condition_cases (Ccompf c) (F n1 :: F n2 :: nil) - | eval_static_condition_case6: - forall c n1 n2, - eval_static_condition_cases (Cnotcompf c) (F n1 :: F n2 :: nil) - | eval_static_condition_case7: - forall n n1, - eval_static_condition_cases (Cmaskzero n) (I n1 :: nil) - | eval_static_condition_case8: - forall n n1, - eval_static_condition_cases (Cmasknotzero n) (I n1 :: nil) - | eval_static_condition_default: - forall (cond: condition) (vl: list approx), - eval_static_condition_cases cond vl. - -Definition eval_static_condition_match (cond: condition) (vl: list approx) := - match cond as z1, vl as z2 return eval_static_condition_cases z1 z2 with - | Ccomp c, I n1 :: I n2 :: nil => - eval_static_condition_case1 c n1 n2 - | Ccompu c, I n1 :: I n2 :: nil => - eval_static_condition_case2 c n1 n2 - | Ccompimm c n, I n1 :: nil => - eval_static_condition_case3 c n n1 - | Ccompuimm c n, I n1 :: nil => - eval_static_condition_case4 c n n1 - | Ccompf c, F n1 :: F n2 :: nil => - eval_static_condition_case5 c n1 n2 - | Cnotcompf c, F n1 :: F n2 :: nil => - eval_static_condition_case6 c n1 n2 - | Cmaskzero n, I n1 :: nil => - eval_static_condition_case7 n n1 - | Cmasknotzero n, I n1 :: nil => - eval_static_condition_case8 n n1 - | cond, vl => - eval_static_condition_default cond vl - end. - -Definition eval_static_condition (cond: condition) (vl: list approx) := - match eval_static_condition_match cond vl with - | eval_static_condition_case1 c n1 n2 => - Some(Int.cmp c n1 n2) - | eval_static_condition_case2 c n1 n2 => - Some(Int.cmpu c n1 n2) - | eval_static_condition_case3 c n n1 => - Some(Int.cmp c n1 n) - | eval_static_condition_case4 c n n1 => - Some(Int.cmpu c n1 n) - | eval_static_condition_case5 c n1 n2 => - Some(Float.cmp c n1 n2) - | eval_static_condition_case6 c n1 n2 => - Some(negb(Float.cmp c n1 n2)) - | eval_static_condition_case7 n n1 => - Some(Int.eq (Int.and n1 n) Int.zero) - | eval_static_condition_case8 n n1 => - Some(negb(Int.eq (Int.and n1 n) Int.zero)) - | eval_static_condition_default cond vl => - None - end. - -(* -Definition eval_static_operation (op: operation) (vl: list approx) := - match op, vl with - | Omove, v1::nil => v1 - | Ointconst n, nil => I n - | Ofloatconst n, nil => F n - | Oaddrsymbol s n, nil => S s n - | Ocast8signed, I n1 :: nil => I(Int.sign_ext 8 n) - | Ocast8unsigned, I n1 :: nil => I(Int.zero_ext 8 n) - | Ocast16signed, I n1 :: nil => I(Int.sign_ext 16 n) - | Ocast16unsigned, I n1 :: nil => I(Int.zero_ext 16 n) - | Oadd, I n1 :: I n2 :: nil => I(Int.add n1 n2) - | Oadd, S s1 n1 :: I n2 :: nil => S s1 (Int.add n1 n2) - | Oaddimm n, I n1 :: nil => I (Int.add n1 n) - | Oaddimm n, S s1 n1 :: nil => S s1 (Int.add n1 n) - | Osub, I n1 :: I n2 :: nil => I(Int.sub n1 n2) - | Osub, S s1 n1 :: I n2 :: nil => S s1 (Int.sub n1 n2) - | Osubimm n, I n1 :: nil => I (Int.sub n n1) - | Omul, I n1 :: I n2 :: nil => I(Int.mul n1 n2) - | Omulimm n, I n1 :: nil => I(Int.mul n1 n) - | Odiv, I n1 :: I n2 :: nil => if Int.eq n2 Int.zero then Unknown else I(Int.divs n1 n2) - | Odivu, I n1 :: I n2 :: nil => if Int.eq n2 Int.zero then Unknown else I(Int.divu n1 n2) - | Oand, I n1 :: I n2 :: nil => I(Int.and n1 n2) - | Oandimm n, I n1 :: nil => I(Int.and n1 n) - | Oor, I n1 :: I n2 :: nil => I(Int.or n1 n2) - | Oorimm n, I n1 :: nil => I(Int.or n1 n) - | Oxor, I n1 :: I n2 :: nil => I(Int.xor n1 n2) - | Oxorimm n, I n1 :: nil => I(Int.xor n1 n) - | Onand, I n1 :: I n2 :: nil => I(Int.xor (Int.and n1 n2) Int.mone) - | Onor, I n1 :: I n2 :: nil => I(Int.xor (Int.or n1 n2) Int.mone) - | Onxor, I n1 :: I n2 :: nil => I(Int.xor (Int.xor n1 n2) Int.mone) - | Oshl, I n1 :: I n2 :: nil => if Int.ltu n2 (Int.repr 32) then I(Int.shl n1 n2) else Unknown - | Oshr, I n1 :: I n2 :: nil => if Int.ltu n2 (Int.repr 32) then I(Int.shr n1 n2) else Unknown - | Oshrimm n, I n1 :: nil => if Int.ltu n (Int.repr 32) then I(Int.shr n1 n) else Unknown - | Oshrximm n, I n1 :: nil => if Int.ltu n (Int.repr 32) then I(Int.shrx n1 n) else Unknown - | Oshru, I n1 :: I n2 :: nil => if Int.ltu n2 (Int.repr 32) then I(Int.shru n1 n2) else Unknown - | Orolm amount mask, I n1 :: nil => I(Int.rolm n1 amount mask) - | Onegf, F n1 :: nil => F(Float.neg n1) - | Oabsf, F n1 :: nil => F(Float.abs n1) - | Oaddf, F n1 :: F n2 :: nil => F(Float.add n1 n2) - | Osubf, F n1 :: F n2 :: nil => F(Float.sub n1 n2) - | Omulf, F n1 :: F n2 :: nil => F(Float.mul n1 n2) - | Odivf, F n1 :: F n2 :: nil => F(Float.div n1 n2) - | Omuladdf, F n1 :: F n2 :: F n3 :: nil => F(Float.add (Float.mul n1 n2) n3) - | Omulsubf, F n1 :: F n2 :: F n3 :: nil => F(Float.sub (Float.mul n1 n2) n3) - | Osingleoffloat, F n1 :: nil => F(Float.singleoffloat n1) - | Ointoffloat, F n1 :: nil => I(Float.intoffloat n1) - | Ointuoffloat, F n1 :: nil => I(Float.intuoffloat n1) - | Ofloatofint, I n1 :: nil => F(Float.floatofint n1) - | Ofloatofintu, I n1 :: nil => F(Float.floatofintu n1) - | Ocmp c, vl => - match eval_static_condition c vl with - | None => Unknown - | Some b => I(if b then Int.one else Int.zero) - end - | _, _ => Unknown - end. -*) - -Inductive eval_static_operation_cases: forall (op: operation) (vl: list approx), Set := - | eval_static_operation_case1: - forall v1, - eval_static_operation_cases (Omove) (v1::nil) - | eval_static_operation_case2: - forall n, - eval_static_operation_cases (Ointconst n) (nil) - | eval_static_operation_case3: - forall n, - eval_static_operation_cases (Ofloatconst n) (nil) - | eval_static_operation_case4: - forall s n, - eval_static_operation_cases (Oaddrsymbol s n) (nil) - | eval_static_operation_case6: - forall n1, - eval_static_operation_cases (Ocast8signed) (I n1 :: nil) - | eval_static_operation_case7: - forall n1, - eval_static_operation_cases (Ocast16signed) (I n1 :: nil) - | eval_static_operation_case8: - forall n1 n2, - eval_static_operation_cases (Oadd) (I n1 :: I n2 :: nil) - | eval_static_operation_case9: - forall s1 n1 n2, - eval_static_operation_cases (Oadd) (S s1 n1 :: I n2 :: nil) - | eval_static_operation_case11: - forall n n1, - eval_static_operation_cases (Oaddimm n) (I n1 :: nil) - | eval_static_operation_case12: - forall n s1 n1, - eval_static_operation_cases (Oaddimm n) (S s1 n1 :: nil) - | eval_static_operation_case13: - forall n1 n2, - eval_static_operation_cases (Osub) (I n1 :: I n2 :: nil) - | eval_static_operation_case14: - forall s1 n1 n2, - eval_static_operation_cases (Osub) (S s1 n1 :: I n2 :: nil) - | eval_static_operation_case15: - forall n n1, - eval_static_operation_cases (Osubimm n) (I n1 :: nil) - | eval_static_operation_case16: - forall n1 n2, - eval_static_operation_cases (Omul) (I n1 :: I n2 :: nil) - | eval_static_operation_case17: - forall n n1, - eval_static_operation_cases (Omulimm n) (I n1 :: nil) - | eval_static_operation_case18: - forall n1 n2, - eval_static_operation_cases (Odiv) (I n1 :: I n2 :: nil) - | eval_static_operation_case19: - forall n1 n2, - eval_static_operation_cases (Odivu) (I n1 :: I n2 :: nil) - | eval_static_operation_case20: - forall n1 n2, - eval_static_operation_cases (Oand) (I n1 :: I n2 :: nil) - | eval_static_operation_case21: - forall n n1, - eval_static_operation_cases (Oandimm n) (I n1 :: nil) - | eval_static_operation_case22: - forall n1 n2, - eval_static_operation_cases (Oor) (I n1 :: I n2 :: nil) - | eval_static_operation_case23: - forall n n1, - eval_static_operation_cases (Oorimm n) (I n1 :: nil) - | eval_static_operation_case24: - forall n1 n2, - eval_static_operation_cases (Oxor) (I n1 :: I n2 :: nil) - | eval_static_operation_case25: - forall n n1, - eval_static_operation_cases (Oxorimm n) (I n1 :: nil) - | eval_static_operation_case26: - forall n1 n2, - eval_static_operation_cases (Onand) (I n1 :: I n2 :: nil) - | eval_static_operation_case27: - forall n1 n2, - eval_static_operation_cases (Onor) (I n1 :: I n2 :: nil) - | eval_static_operation_case28: - forall n1 n2, - eval_static_operation_cases (Onxor) (I n1 :: I n2 :: nil) - | eval_static_operation_case29: - forall n1 n2, - eval_static_operation_cases (Oshl) (I n1 :: I n2 :: nil) - | eval_static_operation_case30: - forall n1 n2, - eval_static_operation_cases (Oshr) (I n1 :: I n2 :: nil) - | eval_static_operation_case31: - forall n n1, - eval_static_operation_cases (Oshrimm n) (I n1 :: nil) - | eval_static_operation_case32: - forall n n1, - eval_static_operation_cases (Oshrximm n) (I n1 :: nil) - | eval_static_operation_case33: - forall n1 n2, - eval_static_operation_cases (Oshru) (I n1 :: I n2 :: nil) - | eval_static_operation_case34: - forall amount mask n1, - eval_static_operation_cases (Orolm amount mask) (I n1 :: nil) - | eval_static_operation_case35: - forall n1, - eval_static_operation_cases (Onegf) (F n1 :: nil) - | eval_static_operation_case36: - forall n1, - eval_static_operation_cases (Oabsf) (F n1 :: nil) - | eval_static_operation_case37: - forall n1 n2, - eval_static_operation_cases (Oaddf) (F n1 :: F n2 :: nil) - | eval_static_operation_case38: - forall n1 n2, - eval_static_operation_cases (Osubf) (F n1 :: F n2 :: nil) - | eval_static_operation_case39: - forall n1 n2, - eval_static_operation_cases (Omulf) (F n1 :: F n2 :: nil) - | eval_static_operation_case40: - forall n1 n2, - eval_static_operation_cases (Odivf) (F n1 :: F n2 :: nil) - | eval_static_operation_case41: - forall n1 n2 n3, - eval_static_operation_cases (Omuladdf) (F n1 :: F n2 :: F n3 :: nil) - | eval_static_operation_case42: - forall n1 n2 n3, - eval_static_operation_cases (Omulsubf) (F n1 :: F n2 :: F n3 :: nil) - | eval_static_operation_case43: - forall n1, - eval_static_operation_cases (Osingleoffloat) (F n1 :: nil) - | eval_static_operation_case44: - forall n1, - eval_static_operation_cases (Ointoffloat) (F n1 :: nil) - | eval_static_operation_case45: - forall n1, - eval_static_operation_cases (Ofloatofint) (I n1 :: nil) - | eval_static_operation_case46: - forall n1, - eval_static_operation_cases (Ofloatofintu) (I n1 :: nil) - | eval_static_operation_case47: - forall c vl, - eval_static_operation_cases (Ocmp c) (vl) - | eval_static_operation_case48: - forall n1, - eval_static_operation_cases (Ocast8unsigned) (I n1 :: nil) - | eval_static_operation_case49: - forall n1, - eval_static_operation_cases (Ocast16unsigned) (I n1 :: nil) - | eval_static_operation_case50: - forall n1, - eval_static_operation_cases (Ointuoffloat) (F n1 :: nil) - | eval_static_operation_default: - forall (op: operation) (vl: list approx), - eval_static_operation_cases op vl. - -Definition eval_static_operation_match (op: operation) (vl: list approx) := - match op as z1, vl as z2 return eval_static_operation_cases z1 z2 with - | Omove, v1::nil => - eval_static_operation_case1 v1 - | Ointconst n, nil => - eval_static_operation_case2 n - | Ofloatconst n, nil => - eval_static_operation_case3 n - | Oaddrsymbol s n, nil => - eval_static_operation_case4 s n - | Ocast8signed, I n1 :: nil => - eval_static_operation_case6 n1 - | Ocast16signed, I n1 :: nil => - eval_static_operation_case7 n1 - | Oadd, I n1 :: I n2 :: nil => - eval_static_operation_case8 n1 n2 - | Oadd, S s1 n1 :: I n2 :: nil => - eval_static_operation_case9 s1 n1 n2 - | Oaddimm n, I n1 :: nil => - eval_static_operation_case11 n n1 - | Oaddimm n, S s1 n1 :: nil => - eval_static_operation_case12 n s1 n1 - | Osub, I n1 :: I n2 :: nil => - eval_static_operation_case13 n1 n2 - | Osub, S s1 n1 :: I n2 :: nil => - eval_static_operation_case14 s1 n1 n2 - | Osubimm n, I n1 :: nil => - eval_static_operation_case15 n n1 - | Omul, I n1 :: I n2 :: nil => - eval_static_operation_case16 n1 n2 - | Omulimm n, I n1 :: nil => - eval_static_operation_case17 n n1 - | Odiv, I n1 :: I n2 :: nil => - eval_static_operation_case18 n1 n2 - | Odivu, I n1 :: I n2 :: nil => - eval_static_operation_case19 n1 n2 - | Oand, I n1 :: I n2 :: nil => - eval_static_operation_case20 n1 n2 - | Oandimm n, I n1 :: nil => - eval_static_operation_case21 n n1 - | Oor, I n1 :: I n2 :: nil => - eval_static_operation_case22 n1 n2 - | Oorimm n, I n1 :: nil => - eval_static_operation_case23 n n1 - | Oxor, I n1 :: I n2 :: nil => - eval_static_operation_case24 n1 n2 - | Oxorimm n, I n1 :: nil => - eval_static_operation_case25 n n1 - | Onand, I n1 :: I n2 :: nil => - eval_static_operation_case26 n1 n2 - | Onor, I n1 :: I n2 :: nil => - eval_static_operation_case27 n1 n2 - | Onxor, I n1 :: I n2 :: nil => - eval_static_operation_case28 n1 n2 - | Oshl, I n1 :: I n2 :: nil => - eval_static_operation_case29 n1 n2 - | Oshr, I n1 :: I n2 :: nil => - eval_static_operation_case30 n1 n2 - | Oshrimm n, I n1 :: nil => - eval_static_operation_case31 n n1 - | Oshrximm n, I n1 :: nil => - eval_static_operation_case32 n n1 - | Oshru, I n1 :: I n2 :: nil => - eval_static_operation_case33 n1 n2 - | Orolm amount mask, I n1 :: nil => - eval_static_operation_case34 amount mask n1 - | Onegf, F n1 :: nil => - eval_static_operation_case35 n1 - | Oabsf, F n1 :: nil => - eval_static_operation_case36 n1 - | Oaddf, F n1 :: F n2 :: nil => - eval_static_operation_case37 n1 n2 - | Osubf, F n1 :: F n2 :: nil => - eval_static_operation_case38 n1 n2 - | Omulf, F n1 :: F n2 :: nil => - eval_static_operation_case39 n1 n2 - | Odivf, F n1 :: F n2 :: nil => - eval_static_operation_case40 n1 n2 - | Omuladdf, F n1 :: F n2 :: F n3 :: nil => - eval_static_operation_case41 n1 n2 n3 - | Omulsubf, F n1 :: F n2 :: F n3 :: nil => - eval_static_operation_case42 n1 n2 n3 - | Osingleoffloat, F n1 :: nil => - eval_static_operation_case43 n1 - | Ointoffloat, F n1 :: nil => - eval_static_operation_case44 n1 - | Ofloatofint, I n1 :: nil => - eval_static_operation_case45 n1 - | Ofloatofintu, I n1 :: nil => - eval_static_operation_case46 n1 - | Ocmp c, vl => - eval_static_operation_case47 c vl - | Ocast8unsigned, I n1 :: nil => - eval_static_operation_case48 n1 - | Ocast16unsigned, I n1 :: nil => - eval_static_operation_case49 n1 - | Ointuoffloat, F n1 :: nil => - eval_static_operation_case50 n1 - | op, vl => - eval_static_operation_default op vl - end. - -Definition eval_static_operation (op: operation) (vl: list approx) := - match eval_static_operation_match op vl with - | eval_static_operation_case1 v1 => - v1 - | eval_static_operation_case2 n => - I n - | eval_static_operation_case3 n => - F n - | eval_static_operation_case4 s n => - S s n - | eval_static_operation_case6 n1 => - I(Int.sign_ext 8 n1) - | eval_static_operation_case7 n1 => - I(Int.sign_ext 16 n1) - | eval_static_operation_case8 n1 n2 => - I(Int.add n1 n2) - | eval_static_operation_case9 s1 n1 n2 => - S s1 (Int.add n1 n2) - | eval_static_operation_case11 n n1 => - I (Int.add n1 n) - | eval_static_operation_case12 n s1 n1 => - S s1 (Int.add n1 n) - | eval_static_operation_case13 n1 n2 => - I(Int.sub n1 n2) - | eval_static_operation_case14 s1 n1 n2 => - S s1 (Int.sub n1 n2) - | eval_static_operation_case15 n n1 => - I (Int.sub n n1) - | eval_static_operation_case16 n1 n2 => - I(Int.mul n1 n2) - | eval_static_operation_case17 n n1 => - I(Int.mul n1 n) - | eval_static_operation_case18 n1 n2 => - if Int.eq n2 Int.zero then Unknown else I(Int.divs n1 n2) - | eval_static_operation_case19 n1 n2 => - if Int.eq n2 Int.zero then Unknown else I(Int.divu n1 n2) - | eval_static_operation_case20 n1 n2 => - I(Int.and n1 n2) - | eval_static_operation_case21 n n1 => - I(Int.and n1 n) - | eval_static_operation_case22 n1 n2 => - I(Int.or n1 n2) - | eval_static_operation_case23 n n1 => - I(Int.or n1 n) - | eval_static_operation_case24 n1 n2 => - I(Int.xor n1 n2) - | eval_static_operation_case25 n n1 => - I(Int.xor n1 n) - | eval_static_operation_case26 n1 n2 => - I(Int.xor (Int.and n1 n2) Int.mone) - | eval_static_operation_case27 n1 n2 => - I(Int.xor (Int.or n1 n2) Int.mone) - | eval_static_operation_case28 n1 n2 => - I(Int.xor (Int.xor n1 n2) Int.mone) - | eval_static_operation_case29 n1 n2 => - if Int.ltu n2 (Int.repr 32) then I(Int.shl n1 n2) else Unknown - | eval_static_operation_case30 n1 n2 => - if Int.ltu n2 (Int.repr 32) then I(Int.shr n1 n2) else Unknown - | eval_static_operation_case31 n n1 => - if Int.ltu n (Int.repr 32) then I(Int.shr n1 n) else Unknown - | eval_static_operation_case32 n n1 => - if Int.ltu n (Int.repr 32) then I(Int.shrx n1 n) else Unknown - | eval_static_operation_case33 n1 n2 => - if Int.ltu n2 (Int.repr 32) then I(Int.shru n1 n2) else Unknown - | eval_static_operation_case34 amount mask n1 => - I(Int.rolm n1 amount mask) - | eval_static_operation_case35 n1 => - F(Float.neg n1) - | eval_static_operation_case36 n1 => - F(Float.abs n1) - | eval_static_operation_case37 n1 n2 => - F(Float.add n1 n2) - | eval_static_operation_case38 n1 n2 => - F(Float.sub n1 n2) - | eval_static_operation_case39 n1 n2 => - F(Float.mul n1 n2) - | eval_static_operation_case40 n1 n2 => - F(Float.div n1 n2) - | eval_static_operation_case41 n1 n2 n3 => - F(Float.add (Float.mul n1 n2) n3) - | eval_static_operation_case42 n1 n2 n3 => - F(Float.sub (Float.mul n1 n2) n3) - | eval_static_operation_case43 n1 => - F(Float.singleoffloat n1) - | eval_static_operation_case44 n1 => - I(Float.intoffloat n1) - | eval_static_operation_case45 n1 => - F(Float.floatofint n1) - | eval_static_operation_case46 n1 => - F(Float.floatofintu n1) - | eval_static_operation_case47 c vl => - match eval_static_condition c vl with - | None => Unknown - | Some b => I(if b then Int.one else Int.zero) - end - | eval_static_operation_case48 n1 => - I(Int.zero_ext 8 n1) - | eval_static_operation_case49 n1 => - I(Int.zero_ext 16 n1) - | eval_static_operation_case50 n1 => - I(Float.intuoffloat n1) - | eval_static_operation_default op vl => - Unknown - end. - -(** The transfer function for the dataflow analysis is straightforward: - for [Iop] instructions, we set the approximation of the destination - register to the result of executing abstractly the operation; - for [Iload] and [Icall], we set the approximation of the destination - to [Unknown]. *) - -Definition approx_regs (rl: list reg) (approx: D.t) := - List.map (fun r => D.get r approx) rl. - -Definition transfer (f: function) (pc: node) (before: D.t) := - match f.(fn_code)!pc with - | None => before - | Some i => - match i with - | Inop s => - before - | Iop op args res s => - let a := eval_static_operation op (approx_regs args before) in - D.set res a before - | Iload chunk addr args dst s => - D.set dst Unknown before - | Istore chunk addr args src s => - 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 => - before - | Ireturn optarg => - before - end - end. - -(** The static analysis itself is then an instantiation of Kildall's - generic solver for forward dataflow inequations. [analyze f] - returns a mapping from program points to mappings of pseudo-registers - to approximations. It can fail to reach a fixpoint in a reasonable - number of iterations, in which case [None] is returned. *) - -Module DS := Dataflow_Solver(D)(NodeSetForward). - -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 *) - -(** ** Operator strength reduction *) - -(** We now define auxiliary functions for strength reduction of - operators and addressing modes: replacing an operator with a cheaper - one if some of its arguments are statically known. These are again - large pattern-matchings expressed in indirect style. *) - -Section STRENGTH_REDUCTION. - -Variable approx: D.t. - -Definition intval (r: reg) : option int := - match D.get r approx with I n => Some n | _ => None end. - -Inductive cond_strength_reduction_cases: condition -> list reg -> Set := - | csr_case1: - forall c r1 r2, - cond_strength_reduction_cases (Ccomp c) (r1 :: r2 :: nil) - | csr_case2: - forall c r1 r2, - cond_strength_reduction_cases (Ccompu c) (r1 :: r2 :: nil) - | csr_default: - forall c rl, - cond_strength_reduction_cases c rl. - -Definition cond_strength_reduction_match (cond: condition) (rl: list reg) := - match cond as x, rl as y return cond_strength_reduction_cases x y with - | Ccomp c, r1 :: r2 :: nil => - csr_case1 c r1 r2 - | Ccompu c, r1 :: r2 :: nil => - csr_case2 c r1 r2 - | cond, rl => - csr_default cond rl - end. - -Definition cond_strength_reduction - (cond: condition) (args: list reg) : condition * list reg := - match cond_strength_reduction_match cond args with - | csr_case1 c r1 r2 => - match intval r1, intval r2 with - | Some n, _ => - (Ccompimm (swap_comparison c) n, r2 :: nil) - | _, Some n => - (Ccompimm c n, r1 :: nil) - | _, _ => - (cond, args) - end - | csr_case2 c r1 r2 => - match intval r1, intval r2 with - | Some n, _ => - (Ccompuimm (swap_comparison c) n, r2 :: nil) - | _, Some n => - (Ccompuimm c n, r1 :: nil) - | _, _ => - (cond, args) - end - | csr_default cond args => - (cond, args) - end. - -Definition make_addimm (n: int) (r: reg) := - if Int.eq n Int.zero - then (Omove, r :: nil) - else (Oaddimm n, r :: nil). - -Definition make_shlimm (n: int) (r: reg) := - if Int.eq n Int.zero - then (Omove, r :: nil) - else (Orolm n (Int.shl Int.mone n), r :: nil). - -Definition make_shrimm (n: int) (r: reg) := - if Int.eq n Int.zero - then (Omove, r :: nil) - else (Oshrimm n, r :: nil). - -Definition make_shruimm (n: int) (r: reg) := - if Int.eq n Int.zero - then (Omove, r :: nil) - else (Orolm (Int.sub (Int.repr 32) n) (Int.shru Int.mone n), r :: nil). - -Definition make_mulimm (n: int) (r: reg) := - if Int.eq n Int.zero then - (Ointconst Int.zero, nil) - else if Int.eq n Int.one then - (Omove, r :: nil) - else - match Int.is_power2 n with - | Some l => make_shlimm l r - | None => (Omulimm n, r :: nil) - end. - -Definition make_andimm (n: int) (r: reg) := - if Int.eq n Int.zero - then (Ointconst Int.zero, nil) - else if Int.eq n Int.mone then (Omove, r :: nil) - else (Oandimm n, r :: nil). - -Definition make_orimm (n: int) (r: reg) := - if Int.eq n Int.zero then (Omove, r :: nil) - else if Int.eq n Int.mone then (Ointconst Int.mone, nil) - else (Oorimm n, r :: nil). - -Definition make_xorimm (n: int) (r: reg) := - if Int.eq n Int.zero - then (Omove, r :: nil) - else (Oxorimm n, r :: nil). - -Inductive op_strength_reduction_cases: operation -> list reg -> Set := - | op_strength_reduction_case1: - forall (r1: reg) (r2: reg), - op_strength_reduction_cases Oadd (r1 :: r2 :: nil) - | op_strength_reduction_case2: - forall (r1: reg) (r2: reg), - op_strength_reduction_cases Osub (r1 :: r2 :: nil) - | op_strength_reduction_case3: - forall (r1: reg) (r2: reg), - op_strength_reduction_cases Omul (r1 :: r2 :: nil) - | op_strength_reduction_case4: - forall (r1: reg) (r2: reg), - op_strength_reduction_cases Odiv (r1 :: r2 :: nil) - | op_strength_reduction_case5: - forall (r1: reg) (r2: reg), - op_strength_reduction_cases Odivu (r1 :: r2 :: nil) - | op_strength_reduction_case6: - forall (r1: reg) (r2: reg), - op_strength_reduction_cases Oand (r1 :: r2 :: nil) - | op_strength_reduction_case7: - forall (r1: reg) (r2: reg), - op_strength_reduction_cases Oor (r1 :: r2 :: nil) - | op_strength_reduction_case8: - forall (r1: reg) (r2: reg), - op_strength_reduction_cases Oxor (r1 :: r2 :: nil) - | op_strength_reduction_case9: - forall (r1: reg) (r2: reg), - op_strength_reduction_cases Oshl (r1 :: r2 :: nil) - | op_strength_reduction_case10: - forall (r1: reg) (r2: reg), - op_strength_reduction_cases Oshr (r1 :: r2 :: nil) - | op_strength_reduction_case11: - forall (r1: reg) (r2: reg), - op_strength_reduction_cases Oshru (r1 :: r2 :: nil) - | op_strength_reduction_case12: - forall (c: condition) (rl: list reg), - op_strength_reduction_cases (Ocmp c) rl - | op_strength_reduction_default: - forall (op: operation) (args: list reg), - op_strength_reduction_cases op args. - -Definition op_strength_reduction_match (op: operation) (args: list reg) := - match op as z1, args as z2 return op_strength_reduction_cases z1 z2 with - | Oadd, r1 :: r2 :: nil => - op_strength_reduction_case1 r1 r2 - | Osub, r1 :: r2 :: nil => - op_strength_reduction_case2 r1 r2 - | Omul, r1 :: r2 :: nil => - op_strength_reduction_case3 r1 r2 - | Odiv, r1 :: r2 :: nil => - op_strength_reduction_case4 r1 r2 - | Odivu, r1 :: r2 :: nil => - op_strength_reduction_case5 r1 r2 - | Oand, r1 :: r2 :: nil => - op_strength_reduction_case6 r1 r2 - | Oor, r1 :: r2 :: nil => - op_strength_reduction_case7 r1 r2 - | Oxor, r1 :: r2 :: nil => - op_strength_reduction_case8 r1 r2 - | Oshl, r1 :: r2 :: nil => - op_strength_reduction_case9 r1 r2 - | Oshr, r1 :: r2 :: nil => - op_strength_reduction_case10 r1 r2 - | Oshru, r1 :: r2 :: nil => - op_strength_reduction_case11 r1 r2 - | Ocmp c, rl => - op_strength_reduction_case12 c rl - | op, args => - op_strength_reduction_default op args - end. - -Definition op_strength_reduction (op: operation) (args: list reg) := - match op_strength_reduction_match op args with - | op_strength_reduction_case1 r1 r2 => (* Oadd *) - match intval r1, intval r2 with - | Some n, _ => make_addimm n r2 - | _, Some n => make_addimm n r1 - | _, _ => (op, args) - end - | op_strength_reduction_case2 r1 r2 => (* Osub *) - match intval r1, intval r2 with - | Some n, _ => (Osubimm n, r2 :: nil) - | _, Some n => make_addimm (Int.neg n) r1 - | _, _ => (op, args) - end - | op_strength_reduction_case3 r1 r2 => (* Omul *) - match intval r1, intval r2 with - | Some n, _ => make_mulimm n r2 - | _, Some n => make_mulimm n r1 - | _, _ => (op, args) - end - | op_strength_reduction_case4 r1 r2 => (* Odiv *) - match intval r2 with - | Some n => - match Int.is_power2 n with - | Some l => (Oshrximm l, r1 :: nil) - | None => (op, args) - end - | None => - (op, args) - end - | op_strength_reduction_case5 r1 r2 => (* Odivu *) - match intval r2 with - | Some n => - match Int.is_power2 n with - | Some l => make_shruimm l r1 - | None => (op, args) - end - | None => - (op, args) - end - | op_strength_reduction_case6 r1 r2 => (* Oand *) - match intval r1, intval r2 with - | Some n, _ => make_andimm n r2 - | _, Some n => make_andimm n r1 - | _, _ => (op, args) - end - | op_strength_reduction_case7 r1 r2 => (* Oor *) - match intval r1, intval r2 with - | Some n, _ => make_orimm n r2 - | _, Some n => make_orimm n r1 - | _, _ => (op, args) - end - | op_strength_reduction_case8 r1 r2 => (* Oxor *) - match intval r1, intval r2 with - | Some n, _ => make_xorimm n r2 - | _, Some n => make_xorimm n r1 - | _, _ => (op, args) - end - | op_strength_reduction_case9 r1 r2 => (* Oshl *) - match intval r2 with - | Some n => - if Int.ltu n (Int.repr 32) - then make_shlimm n r1 - else (op, args) - | _ => (op, args) - end - | op_strength_reduction_case10 r1 r2 => (* Oshr *) - match intval r2 with - | Some n => - if Int.ltu n (Int.repr 32) - then make_shrimm n r1 - else (op, args) - | _ => (op, args) - end - | op_strength_reduction_case11 r1 r2 => (* Oshru *) - match intval r2 with - | Some n => - if Int.ltu n (Int.repr 32) - then make_shruimm n r1 - else (op, args) - | _ => (op, args) - end - | op_strength_reduction_case12 c args => (* Ocmp *) - let (c', args') := cond_strength_reduction c args in - (Ocmp c', args') - | op_strength_reduction_default op args => (* default *) - (op, args) - end. - -Inductive addr_strength_reduction_cases: forall (addr: addressing) (args: list reg), Set := - | addr_strength_reduction_case1: - forall (r1: reg) (r2: reg), - addr_strength_reduction_cases (Aindexed2) (r1 :: r2 :: nil) - | addr_strength_reduction_case2: - forall (symb: ident) (ofs: int) (r1: reg), - addr_strength_reduction_cases (Abased symb ofs) (r1 :: nil) - | addr_strength_reduction_case3: - forall n r1, - addr_strength_reduction_cases (Aindexed n) (r1 :: nil) - | addr_strength_reduction_default: - forall (addr: addressing) (args: list reg), - addr_strength_reduction_cases addr args. - -Definition addr_strength_reduction_match (addr: addressing) (args: list reg) := - match addr as z1, args as z2 return addr_strength_reduction_cases z1 z2 with - | Aindexed2, r1 :: r2 :: nil => - addr_strength_reduction_case1 r1 r2 - | Abased symb ofs, r1 :: nil => - addr_strength_reduction_case2 symb ofs r1 - | Aindexed n, r1 :: nil => - addr_strength_reduction_case3 n r1 - | addr, args => - addr_strength_reduction_default addr args - end. - -Definition addr_strength_reduction (addr: addressing) (args: list reg) := - match addr_strength_reduction_match addr args with - | addr_strength_reduction_case1 r1 r2 => (* Aindexed2 *) - match D.get r1 approx, D.get r2 approx with - | S symb n1, I n2 => (Aglobal symb (Int.add n1 n2), nil) - | S symb n1, _ => (Abased symb n1, r2 :: nil) - | I n1, S symb n2 => (Aglobal symb (Int.add n1 n2), nil) - | I n1, _ => (Aindexed n1, r2 :: nil) - | _, S symb n2 => (Abased symb n2, r1 :: nil) - | _, I n2 => (Aindexed n2, r1 :: nil) - | _, _ => (addr, args) - end - | addr_strength_reduction_case2 symb ofs r1 => (* Abased *) - match intval r1 with - | Some n => (Aglobal symb (Int.add ofs n), nil) - | _ => (addr, args) - end - | addr_strength_reduction_case3 n r1 => (* Aindexed *) - match D.get r1 approx with - | S symb ofs => (Aglobal symb (Int.add ofs n), nil) - | _ => (addr, args) - end - | addr_strength_reduction_default addr args => (* default *) - (addr, args) - end. - -End STRENGTH_REDUCTION. - -(** ** Code transformation *) - -(** The code transformation proceeds instruction by instruction. - Operators whose arguments are all statically known are turned - into ``load integer constant'', ``load float constant'' or - ``load symbol address'' operations. Operators for which some - but not all arguments are known are subject to 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 => - match eval_static_operation op (approx_regs args approx) with - | I n => - Iop (Ointconst n) nil res s - | F n => - Iop (Ofloatconst n) nil res s - | S symb ofs => - Iop (Oaddrsymbol symb ofs) nil res s - | _ => - let (op', args') := op_strength_reduction approx op args in - Iop op' args' res s - end - | Iload chunk addr args dst s => - let (addr', args') := addr_strength_reduction approx addr args in - Iload chunk addr' args' dst s - | Istore chunk addr args src s => - let (addr', args') := addr_strength_reduction approx addr args in - Istore chunk addr' args' src s - | 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 => - match eval_static_condition cond (approx_regs args approx) with - | Some b => - if b then Inop s1 else Inop s2 - | None => - let (cond', args') := cond_strength_reduction approx cond args in - Icond cond' args' s1 s2 - end - | _ => - instr - end. - -Definition transf_code (approxs: PMap.t D.t) (instrs: code) : code := - PTree.map (fun pc instr => transf_instr approxs!!pc instr) instrs. - -Lemma transf_code_wf: - forall f approxs, - (forall pc, Plt pc f.(fn_nextpc) \/ f.(fn_code)!pc = None) -> - (forall pc, Plt pc f.(fn_nextpc) - \/ (transf_code approxs f.(fn_code))!pc = None). -Proof. - intros. - elim (H pc); intro. - left; auto. - right. unfold transf_code. rewrite PTree.gmap. - unfold option_map; rewrite H0. reflexivity. -Qed. - -Definition transf_function (f: function) : function := - 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 (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 deleted file mode 100644 index e16f322..0000000 --- a/backend/Constpropproof.v +++ /dev/null @@ -1,954 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** Correctness proof for constant propagation. *) - -Require Import Coqlib. -Require Import Maps. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import Events. -Require Import Mem. -Require Import Globalenvs. -Require Import Smallstep. -Require Import Op. -Require Import Registers. -Require Import RTL. -Require Import Lattice. -Require Import Kildall. -Require Import Constprop. - -(** * Correctness of the static analysis *) - -Section ANALYSIS. - -Variable ge: genv. - -(** We first show that the dataflow analysis is correct with respect - to the dynamic semantics: the approximations (sets of values) - of a register at a program point predicted by the static analysis - are a superset of the values actually encountered during concrete - executions. We formalize this correspondence between run-time values and - compile-time approximations by the following predicate. *) - -Definition val_match_approx (a: approx) (v: val) : Prop := - match a with - | Unknown => True - | I p => v = Vint p - | F p => v = Vfloat p - | S symb ofs => exists b, Genv.find_symbol ge symb = Some b /\ v = Vptr b ofs - | _ => False - end. - -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. -Proof. - intros until v. - intros [A|[B|C]]. - subst a1. simpl. auto. - subst a2. simpl. tauto. - subst a2. auto. -Qed. - -Lemma regs_match_approx_increasing: - forall a1 a2 rs, - D.ge a1 a2 -> regs_match_approx a2 rs -> regs_match_approx a1 rs. -Proof. - unfold D.ge, regs_match_approx. intros. - apply val_match_approx_increasing with (D.get r a2); auto. -Qed. - -Lemma regs_match_approx_update: - forall ra rs a v r, - val_match_approx a v -> - regs_match_approx ra rs -> - regs_match_approx (D.set r a ra) (rs#r <- v). -Proof. - intros; red; intros. rewrite Regmap.gsspec. - case (peq r0 r); intro. - subst r0. rewrite D.gss. auto. - rewrite D.gso; auto. -Qed. - -Inductive val_list_match_approx: list approx -> list val -> Prop := - | vlma_nil: - val_list_match_approx nil nil - | vlma_cons: - forall a al v vl, - val_match_approx a v -> - val_list_match_approx al vl -> - val_list_match_approx (a :: al) (v :: vl). - -Lemma approx_regs_val_list: - forall ra rs rl, - regs_match_approx ra rs -> - val_list_match_approx (approx_regs rl ra) rs##rl. -Proof. - induction rl; simpl; intros. - constructor. - constructor. apply H. auto. -Qed. - -Ltac SimplVMA := - match goal with - | H: (val_match_approx (I _) ?v) |- _ => - simpl in H; (try subst v); SimplVMA - | H: (val_match_approx (F _) ?v) |- _ => - simpl in H; (try subst v); SimplVMA - | H: (val_match_approx (S _ _) ?v) |- _ => - simpl in H; - (try (elim H; - let b := fresh "b" in let A := fresh in let B := fresh in - (intros b [A B]; subst v; clear H))); - SimplVMA - | _ => - idtac - end. - -Ltac InvVLMA := - match goal with - | H: (val_list_match_approx nil ?vl) |- _ => - inversion H - | H: (val_list_match_approx (?a :: ?al) ?vl) |- _ => - inversion H; SimplVMA; InvVLMA - | _ => - idtac - end. - -(** We then show that [eval_static_operation] is a correct abstract - interpretations of [eval_operation]: if the concrete arguments match - the given approximations, the concrete results match the - approximations returned by [eval_static_operation]. *) - -Lemma eval_static_condition_correct: - forall cond al vl m b, - val_list_match_approx al vl -> - eval_static_condition cond al = Some b -> - eval_condition cond vl m = Some b. -Proof. - intros until b. - unfold eval_static_condition. - case (eval_static_condition_match cond al); intros; - InvVLMA; simpl; congruence. -Qed. - -Lemma eval_static_operation_correct: - forall op sp al vl m v, - val_list_match_approx al vl -> - eval_operation ge sp op vl m = Some v -> - val_match_approx (eval_static_operation op al) v. -Proof. - intros until v. - unfold eval_static_operation. - case (eval_static_operation_match op al); intros; - InvVLMA; simpl in *; FuncInv; try congruence. - - destruct (Genv.find_symbol ge s). exists b. intuition congruence. - congruence. - - rewrite <- H3. replace v0 with (Vint n1). reflexivity. congruence. - rewrite <- H3. replace v0 with (Vint n1). reflexivity. congruence. - - exists b. split. auto. congruence. - exists b. split. auto. congruence. - exists b. split. auto. congruence. - - replace n2 with i0. destruct (Int.eq i0 Int.zero). - discriminate. injection H0; intro; subst v. simpl. congruence. congruence. - - replace n2 with i0. destruct (Int.eq i0 Int.zero). - discriminate. injection H0; intro; subst v. simpl. congruence. congruence. - - subst v. unfold Int.not. congruence. - subst v. unfold Int.not. congruence. - subst v. unfold Int.not. congruence. - - replace n2 with i0. destruct (Int.ltu i0 (Int.repr 32)). - injection H0; intro; subst v. simpl. congruence. discriminate. congruence. - - replace n2 with i0. destruct (Int.ltu i0 (Int.repr 32)). - injection H0; intro; subst v. simpl. congruence. discriminate. congruence. - - destruct (Int.ltu n (Int.repr 32)). - injection H0; intro; subst v. simpl. congruence. discriminate. - - destruct (Int.ltu n (Int.repr 32)). - injection H0; intro; subst v. simpl. congruence. discriminate. - - replace n2 with i0. destruct (Int.ltu i0 (Int.repr 32)). - injection H0; intro; subst v. simpl. congruence. discriminate. congruence. - - rewrite <- H3. replace v0 with (Vfloat n1). reflexivity. congruence. - - caseEq (eval_static_condition c vl0). - 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. - - rewrite <- H3. replace v0 with (Vint n1). reflexivity. congruence. - rewrite <- H3. replace v0 with (Vint n1). reflexivity. congruence. - - 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 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 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; eauto. - elim (fn_code_wf f pc); intro. auto. - unfold successors in H0; rewrite H2 in H0; simpl; contradiction. - auto. - intros. rewrite PMap.gi. apply regs_match_approx_top. -Qed. - -Lemma analyze_correct_3: - forall f rs, - regs_match_approx (analyze f)!!(f.(fn_entrypoint)) rs. -Proof. - 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; eauto. auto with coqlib. - apply regs_match_approx_top. - intros. rewrite PMap.gi. apply regs_match_approx_top. -Qed. - -(** * Correctness of strength reduction *) - -(** We now show that strength reduction over operators and addressing - modes preserve semantics: the strength-reduced operations and - addressings evaluate to the same values as the original ones if the - actual arguments match the static approximations used for strength - reduction. *) - -Section STRENGTH_REDUCTION. - -Variable approx: D.t. -Variable sp: val. -Variable rs: regset. -Hypothesis MATCH: regs_match_approx approx rs. - -Lemma intval_correct: - forall r n, - intval approx r = Some n -> rs#r = Vint n. -Proof. - intros until n. - unfold intval. caseEq (D.get r approx); intros; try discriminate. - generalize (MATCH r). unfold val_match_approx. rewrite H. - congruence. -Qed. - -Lemma cond_strength_reduction_correct: - forall cond args m, - let (cond', args') := cond_strength_reduction approx cond args in - 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. - caseEq (intval approx r1); intros. - simpl. rewrite (intval_correct _ _ H). - destruct (rs#r2); auto. rewrite Int.swap_cmp. auto. - destruct c; reflexivity. - caseEq (intval approx r2); intros. - simpl. rewrite (intval_correct _ _ H0). auto. - auto. - caseEq (intval approx r1); intros. - simpl. rewrite (intval_correct _ _ H). - destruct (rs#r2); auto. rewrite Int.swap_cmpu. auto. - caseEq (intval approx r2); intros. - simpl. rewrite (intval_correct _ _ H0). auto. - auto. - auto. -Qed. - -Lemma make_addimm_correct: - forall n r m v, - let (op, args) := make_addimm n r in - 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. - subst n. simpl in *. FuncInv. rewrite Int.add_zero in H. congruence. - rewrite Int.add_zero in H. congruence. - exact H0. -Qed. - -Lemma make_shlimm_correct: - forall n r m v, - let (op, args) := make_shlimm n r in - 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. - subst n. simpl in *. FuncInv. rewrite Int.shl_zero in H. congruence. - simpl in *. FuncInv. caseEq (Int.ltu n (Int.repr 32)); intros. - rewrite H1 in H0. rewrite Int.shl_rolm in H0. auto. exact H1. - rewrite H1 in H0. discriminate. -Qed. - -Lemma make_shrimm_correct: - forall n r m v, - let (op, args) := make_shrimm n r in - 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. - subst n. simpl in *. FuncInv. rewrite Int.shr_zero in H. congruence. - assumption. -Qed. - -Lemma make_shruimm_correct: - forall n r m v, - let (op, args) := make_shruimm n r in - 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. - subst n. simpl in *. FuncInv. rewrite Int.shru_zero in H. congruence. - simpl in *. FuncInv. caseEq (Int.ltu n (Int.repr 32)); intros. - rewrite H1 in H0. rewrite Int.shru_rolm in H0. auto. exact H1. - rewrite H1 in H0. discriminate. -Qed. - -Lemma make_mulimm_correct: - forall n r m v, - let (op, args) := make_mulimm n r in - 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. - subst n. simpl in H0. FuncInv. rewrite Int.mul_zero in H. simpl. congruence. - 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) 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. - destruct rs#r; auto. rewrite (Int.mul_pow2 i0 _ _ H1). auto. - exact H2. -Qed. - -Lemma make_andimm_correct: - forall n r m v, - let (op, args) := make_andimm n r in - 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. - subst n. simpl in *. FuncInv. rewrite Int.and_zero in H. congruence. - generalize (Int.eq_spec n Int.mone); case (Int.eq n Int.mone); intros. - subst n. simpl in *. FuncInv. rewrite Int.and_mone in H0. congruence. - exact H1. -Qed. - -Lemma make_orimm_correct: - forall n r m v, - let (op, args) := make_orimm n r in - 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. - subst n. simpl in *. FuncInv. rewrite Int.or_zero in H. congruence. - generalize (Int.eq_spec n Int.mone); case (Int.eq n Int.mone); intros. - subst n. simpl in *. FuncInv. rewrite Int.or_mone in H0. congruence. - exact H1. -Qed. - -Lemma make_xorimm_correct: - forall n r m v, - let (op, args) := make_xorimm n r in - 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. - subst n. simpl in *. FuncInv. rewrite Int.xor_zero in H. congruence. - exact H0. -Qed. - -Lemma op_strength_reduction_correct: - forall op args m v, - let (op', args') := op_strength_reduction approx op args in - 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) 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. - rewrite (intval_correct _ _ H0). apply make_addimm_correct. - assumption. - (* Osub *) - caseEq (intval approx r1); intros. - 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) 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) 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. - rewrite (intval_correct _ _ H0). apply make_mulimm_correct. - assumption. - (* Odiv *) - caseEq (intval approx r2); intros. - caseEq (Int.is_power2 i); intros. - rewrite (intval_correct _ _ H) in H1. - simpl in *; FuncInv. destruct (Int.eq i Int.zero). congruence. - change 32 with (Z_of_nat wordsize). - rewrite (Int.is_power2_range _ _ H0). - rewrite (Int.divs_pow2 i1 _ _ H0) in H1. auto. - assumption. - assumption. - (* Odivu *) - 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) 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). - rewrite (Int.is_power2_range _ _ H0). - generalize (Int.eq_spec i Int.zero); case (Int.eq i Int.zero); intros. - subst i. discriminate. - rewrite (Int.divu_pow2 i1 _ _ H0). auto. - assumption. - assumption. - (* Oand *) - caseEq (intval approx r1); intros. - rewrite (intval_correct _ _ H). - 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. - rewrite (intval_correct _ _ H0). apply make_andimm_correct. - assumption. - (* Oor *) - caseEq (intval approx r1); intros. - rewrite (intval_correct _ _ H). - 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. - rewrite (intval_correct _ _ H0). apply make_orimm_correct. - assumption. - (* Oxor *) - caseEq (intval approx r1); intros. - rewrite (intval_correct _ _ H). - 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. - rewrite (intval_correct _ _ H0). apply make_xorimm_correct. - assumption. - (* Oshl *) - caseEq (intval approx r2); intros. - caseEq (Int.ltu i (Int.repr 32)); intros. - rewrite (intval_correct _ _ H). apply make_shlimm_correct. - assumption. - assumption. - (* Oshr *) - caseEq (intval approx r2); intros. - caseEq (Int.ltu i (Int.repr 32)); intros. - rewrite (intval_correct _ _ H). apply make_shrimm_correct. - assumption. - assumption. - (* Oshru *) - caseEq (intval approx r2); intros. - caseEq (Int.ltu i (Int.repr 32)); intros. - rewrite (intval_correct _ _ H). apply make_shruimm_correct. - assumption. - assumption. - (* Ocmp *) - generalize (cond_strength_reduction_correct c rl). - destruct (cond_strength_reduction approx c rl). - simpl. intro. rewrite H. auto. - (* default *) - assumption. -Qed. - -Ltac KnownApprox := - match goal with - | MATCH: (regs_match_approx ?approx ?rs), - H: (D.get ?r ?approx = ?a) |- _ => - generalize (MATCH r); rewrite H; intro; clear H; KnownApprox - | _ => idtac - end. - -Lemma addr_strength_reduction_correct: - forall addr args, - let (addr', args') := addr_strength_reduction approx addr args in - eval_addressing ge sp addr' rs##args' = eval_addressing ge sp addr rs##args. -Proof. - intros. - - (* Useful lemmas *) - assert (A0: forall r1 r2, - eval_addressing ge sp Aindexed2 (rs ## (r1 :: r2 :: nil)) = - eval_addressing ge sp Aindexed2 (rs ## (r2 :: r1 :: nil))). - intros. simpl. destruct (rs#r1); destruct (rs#r2); auto; - rewrite Int.add_commut; auto. - - assert (A1: forall r1 r2 n, - val_match_approx (I n) rs#r2 -> - eval_addressing ge sp (Aindexed n) (rs ## (r1 :: nil)) = - eval_addressing ge sp Aindexed2 (rs ## (r1 :: r2 :: nil))). - intros; simpl in *. rewrite H. auto. - - assert (A2: forall r1 r2 n, - val_match_approx (I n) rs#r1 -> - eval_addressing ge sp (Aindexed n) (rs ## (r2 :: nil)) = - eval_addressing ge sp Aindexed2 (rs ## (r1 :: r2 :: nil))). - intros. rewrite A0. apply A1. auto. - - assert (A3: forall r1 r2 id ofs, - val_match_approx (S id ofs) rs#r1 -> - eval_addressing ge sp (Abased id ofs) (rs ## (r2 :: nil)) = - eval_addressing ge sp Aindexed2 (rs ## (r1 :: r2 :: nil))). - intros. elim H. intros b [A B]. simpl. rewrite A; rewrite B. auto. - - assert (A4: forall r1 r2 id ofs, - val_match_approx (S id ofs) rs#r2 -> - eval_addressing ge sp (Abased id ofs) (rs ## (r1 :: nil)) = - eval_addressing ge sp Aindexed2 (rs ## (r1 :: r2 :: nil))). - intros. rewrite A0. apply A3. auto. - - assert (A5: forall r1 r2 id ofs n, - val_match_approx (S id ofs) rs#r1 -> - val_match_approx (I n) rs#r2 -> - eval_addressing ge sp (Aglobal id (Int.add ofs n)) nil = - eval_addressing ge sp Aindexed2 (rs ## (r1 :: r2 :: nil))). - intros. elim H. intros b [A B]. simpl. rewrite A; rewrite B. - simpl in H0. rewrite H0. auto. - - unfold addr_strength_reduction; - case (addr_strength_reduction_match addr args); intros. - - (* Aindexed2 *) - caseEq (D.get r1 approx); intros; - caseEq (D.get r2 approx); intros; - try reflexivity; KnownApprox; auto. - rewrite A0. rewrite Int.add_commut. apply A5; auto. - - (* Abased *) - caseEq (intval approx r1); intros. - simpl; rewrite (intval_correct _ _ H). auto. - auto. - - (* Aindexed *) - caseEq (D.get r1 approx); intros; auto. - simpl; KnownApprox. - elim H0. intros b [A B]. rewrite A; rewrite B. auto. - - (* default *) - reflexivity. -Qed. - -End STRENGTH_REDUCTION. - -End ANALYSIS. - -(** * Correctness of the code transformation *) - -(** We now show that the transformed code after constant propagation - has the same semantics as the original code. *) - -Section PRESERVATION. - -Variable prog: program. -Let tprog := transf_program prog. -Let ge := Genv.globalenv prog. -Let tge := Genv.globalenv tprog. - -Lemma symbols_preserved: - forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. -Proof. - intros; unfold ge, tge, tprog, transf_program. - apply Genv.find_symbol_transf. -Qed. - -Lemma functions_translated: - forall (v: val) (f: fundef), - Genv.find_funct ge v = Some f -> - Genv.find_funct tge v = Some (transf_fundef f). -Proof. - intros. - exact (Genv.find_funct_transf transf_fundef H). -Qed. - -Lemma function_ptr_translated: - forall (b: block) (f: fundef), - Genv.find_funct_ptr ge b = Some f -> - Genv.find_funct_ptr tge b = Some (transf_fundef f). -Proof. - intros. - exact (Genv.find_funct_ptr_transf transf_fundef H). -Qed. - -Lemma sig_function_translated: - forall f, - funsig (transf_fundef f) = funsig f. -Proof. - 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: -<< - st1 --------------- st2 - | | - t| |t - | | - v v - st1'--------------- st2' ->> - The left vertical arrow represents a transition in the - 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 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), 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 proof of simulation proceeds by case analysis on the transition - taken in the source code. *) - -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. - induction 1; intros; inv MS. - - (* Inop *) - 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 *) - 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' m = Some v). - rewrite (eval_operation_preserved symbols_preserved). - 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 (analyze f)!!pc) rs##args m v - (approx_regs_val_list _ _ _ args MATCH) H0). - case (eval_static_operation op (approx_regs args (analyze f)!!pc)); intros; - simpl in H2; - eapply exec_Iop; eauto; simpl. - 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 *) - 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 (analyze f)!!pc sp rs - MATCH addr args). - rewrite ASR; simpl. congruence. - TransfInstr. rewrite ASR. intro. - exists (State s' (transf_code (analyze f) (fn_code f)) sp pc' (rs#dst <- v) m); split. - 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 *) - 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 (analyze f)!!pc sp rs - MATCH addr args). - rewrite ASR; simpl. congruence. - TransfInstr. rewrite ASR. intro. - exists (State s' (transf_code (analyze f) (fn_code f)) sp pc' rs m'); split. - 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 *) - 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 *) - 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 *) - 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' m = Some true). - generalize (cond_strength_reduction_correct - ge (analyze f)!!pc rs MATCH cond args m). - rewrite CSR. intro. congruence. - TransfInstr. rewrite CSR. - caseEq (eval_static_condition cond (approx_regs args (analyze f)!!pc)). - intros b ESC. - 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. - econstructor; eauto. - apply analyze_correct_1 with pc; auto. - unfold successors; rewrite H; auto with coqlib. - unfold transfer; rewrite H; auto. - - (* Icond, false *) - 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' m = Some false). - generalize (cond_strength_reduction_correct - ge (analyze f)!!pc rs MATCH cond args m). - rewrite CSR. intro. congruence. - TransfInstr. rewrite CSR. - caseEq (eval_static_condition cond (approx_regs args (analyze f)!!pc)). - intros b ESC. - 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. - 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 *) - simpl. unfold transf_function. - econstructor; split. - eapply exec_function_internal; simpl; eauto. - simpl. econstructor; eauto. - apply analyze_correct_3; auto. - - (* external function *) - 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, using the generic preservation theorem - [Smallstep.simulation_step_preservation]. *) - -Theorem transf_program_correct: - 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/Conventions.v b/backend/Conventions.v deleted file mode 100644 index b7d931f..0000000 --- a/backend/Conventions.v +++ /dev/null @@ -1,805 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** Function calling conventions and other conventions regarding the use of - machine registers and stack slots. *) - -Require Import Coqlib. -Require Import AST. -Require Import Locations. - -(** * Classification of machine registers *) - -(** Machine registers (type [mreg] in module [Locations]) are divided in - the following groups: -- Temporaries used for spilling, reloading, and parallel move operations. -- Allocatable registers, that can be assigned to RTL pseudo-registers. - These are further divided into: --- Callee-save registers, whose value is preserved across a function call. --- Caller-save registers that can be modified during a function call. - - We follow the PowerPC application binary interface (ABI) in our choice - of callee- and caller-save registers. -*) - -Definition int_caller_save_regs := - R3 :: R4 :: R5 :: R6 :: R7 :: R8 :: R9 :: R10 :: nil. - -Definition float_caller_save_regs := - F1 :: F2 :: F3 :: F4 :: F5 :: F6 :: F7 :: F8 :: F9 :: F10 :: nil. - -Definition int_callee_save_regs := - R13 :: R14 :: R15 :: R16 :: R17 :: R18 :: R19 :: R20 :: R21 :: R22 :: - R23 :: R24 :: R25 :: R26 :: R27 :: R28 :: R29 :: R30 :: R31 :: nil. - -Definition float_callee_save_regs := - F14 :: F15 :: F16 :: F17 :: F18 :: F19 :: F20 :: F21 :: F22 :: - F23 :: F24 :: F25 :: F26 :: F27 :: F28 :: F29 :: F30 :: F31 :: nil. - -Definition destroyed_at_call_regs := - int_caller_save_regs ++ float_caller_save_regs. - -Definition destroyed_at_call := - List.map R destroyed_at_call_regs. - -Definition int_temporaries := IT1 :: IT2 :: nil. - -Definition float_temporaries := FT1 :: FT2 :: FT3 :: nil. - -Definition temporaries := - R IT1 :: R IT2 :: R FT1 :: R FT2 :: R FT3 :: nil. - -(** The [index_int_callee_save] and [index_float_callee_save] associate - a unique positive integer to callee-save registers. This integer is - used in [Stacking] to determine where to save these registers in - the activation record if they are used by the current function. *) - -Definition index_int_callee_save (r: mreg) := - match r with - | R13 => 0 | R14 => 1 | R15 => 2 | R16 => 3 - | R17 => 4 | R18 => 5 | R19 => 6 | R20 => 7 - | R21 => 8 | R22 => 9 | R23 => 10 | R24 => 11 - | R25 => 12 | R26 => 13 | R27 => 14 | R28 => 15 - | R29 => 16 | R30 => 17 | R31 => 18 | _ => -1 - end. - -Definition index_float_callee_save (r: mreg) := - match r with - | F14 => 0 | F15 => 1 | F16 => 2 | F17 => 3 - | F18 => 4 | F19 => 5 | F20 => 6 | F21 => 7 - | F22 => 8 | F23 => 9 | F24 => 10 | F25 => 11 - | F26 => 12 | F27 => 13 | F28 => 14 | F29 => 15 - | F30 => 16 | F31 => 17 | _ => -1 - end. - -Ltac ElimOrEq := - match goal with - | |- (?x = ?y) \/ _ -> _ => - let H := fresh in - (intro H; elim H; clear H; - [intro H; rewrite <- H; clear H | ElimOrEq]) - | |- False -> _ => - let H := fresh in (intro H; contradiction) - end. - -Ltac OrEq := - match goal with - | |- (?x = ?x) \/ _ => left; reflexivity - | |- (?x = ?y) \/ _ => right; OrEq - | |- False => fail - end. - -Ltac NotOrEq := - match goal with - | |- (?x = ?y) \/ _ -> False => - let H := fresh in ( - intro H; elim H; clear H; [intro; discriminate | NotOrEq]) - | |- False -> False => - contradiction - end. - -Lemma index_int_callee_save_pos: - forall r, In r int_callee_save_regs -> index_int_callee_save r >= 0. -Proof. - intro r. simpl; ElimOrEq; unfold index_int_callee_save; omega. -Qed. - -Lemma index_float_callee_save_pos: - forall r, In r float_callee_save_regs -> index_float_callee_save r >= 0. -Proof. - intro r. simpl; ElimOrEq; unfold index_float_callee_save; omega. -Qed. - -Lemma index_int_callee_save_pos2: - forall r, index_int_callee_save r >= 0 -> In r int_callee_save_regs. -Proof. - destruct r; simpl; intro; omegaContradiction || OrEq. -Qed. - -Lemma index_float_callee_save_pos2: - forall r, index_float_callee_save r >= 0 -> In r float_callee_save_regs. -Proof. - destruct r; simpl; intro; omegaContradiction || OrEq. -Qed. - -Lemma index_int_callee_save_inj: - forall r1 r2, - In r1 int_callee_save_regs -> - In r2 int_callee_save_regs -> - r1 <> r2 -> - index_int_callee_save r1 <> index_int_callee_save r2. -Proof. - intros r1 r2. - simpl; ElimOrEq; ElimOrEq; unfold index_int_callee_save; - intros; congruence. -Qed. - -Lemma index_float_callee_save_inj: - forall r1 r2, - In r1 float_callee_save_regs -> - In r2 float_callee_save_regs -> - r1 <> r2 -> - index_float_callee_save r1 <> index_float_callee_save r2. -Proof. - intros r1 r2. - simpl; ElimOrEq; ElimOrEq; unfold index_float_callee_save; - intros; congruence. -Qed. - -(** The following lemmas show that - (temporaries, destroyed at call, integer callee-save, float callee-save) - is a partition of the set of machine registers. *) - -Lemma int_float_callee_save_disjoint: - list_disjoint int_callee_save_regs float_callee_save_regs. -Proof. - red; intros r1 r2. simpl; ElimOrEq; ElimOrEq; discriminate. -Qed. - -Lemma register_classification: - forall r, - (In (R r) temporaries \/ In (R r) destroyed_at_call) \/ - (In r int_callee_save_regs \/ In r float_callee_save_regs). -Proof. - destruct r; - try (left; left; simpl; OrEq); - try (left; right; simpl; OrEq); - try (right; left; simpl; OrEq); - try (right; right; simpl; OrEq). -Qed. - -Lemma int_callee_save_not_destroyed: - forall r, - In (R r) temporaries \/ In (R r) destroyed_at_call -> - ~(In r int_callee_save_regs). -Proof. - intros; red; intros. elim H. - generalize H0. simpl; ElimOrEq; NotOrEq. - generalize H0. simpl; ElimOrEq; NotOrEq. -Qed. - -Lemma float_callee_save_not_destroyed: - forall r, - In (R r) temporaries \/ In (R r) destroyed_at_call -> - ~(In r float_callee_save_regs). -Proof. - intros; red; intros. elim H. - generalize H0. simpl; ElimOrEq; NotOrEq. - generalize H0. simpl; ElimOrEq; NotOrEq. -Qed. - -Lemma int_callee_save_type: - forall r, In r int_callee_save_regs -> mreg_type r = Tint. -Proof. - intro. simpl; ElimOrEq; reflexivity. -Qed. - -Lemma float_callee_save_type: - forall r, In r float_callee_save_regs -> mreg_type r = Tfloat. -Proof. - intro. simpl; ElimOrEq; reflexivity. -Qed. - -Ltac NoRepet := - match goal with - | |- list_norepet nil => - apply list_norepet_nil - | |- list_norepet (?a :: ?b) => - apply list_norepet_cons; [simpl; intuition discriminate | NoRepet] - end. - -Lemma int_callee_save_norepet: - list_norepet int_callee_save_regs. -Proof. - unfold int_callee_save_regs; NoRepet. -Qed. - -Lemma float_callee_save_norepet: - list_norepet float_callee_save_regs. -Proof. - unfold float_callee_save_regs; NoRepet. -Qed. - -(** * Acceptable locations for register allocation *) - -(** The following predicate describes the locations that can be assigned - to an RTL pseudo-register during register allocation: a non-temporary - machine register or a [Local] stack slot are acceptable. *) - -Definition loc_acceptable (l: loc) : Prop := - match l with - | R r => ~(In l temporaries) - | S (Local ofs ty) => ofs >= 0 - | S (Incoming _ _) => False - | S (Outgoing _ _) => False - end. - -Definition locs_acceptable (ll: list loc) : Prop := - forall l, In l ll -> loc_acceptable l. - -Lemma temporaries_not_acceptable: - forall l, loc_acceptable l -> Loc.notin l temporaries. -Proof. - unfold loc_acceptable; destruct l. - simpl. intuition congruence. - destruct s; try contradiction. - intro. simpl. tauto. -Qed. -Hint Resolve temporaries_not_acceptable: locs. - -Lemma locs_acceptable_disj_temporaries: - forall ll, locs_acceptable ll -> Loc.disjoint ll temporaries. -Proof. - intros. apply Loc.notin_disjoint. intros. - 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 - and stack slots) used to communicate arguments and results between the - caller and the callee during function calls. These locations are functions - of the signature of the function and of the call instruction. - Agreement between the caller and the callee on the locations to use - is guaranteed by our dynamic semantics for Cminor and RTL, which demand - that the signature of the call instruction is identical to that of the - called function. - - Calling conventions are largely arbitrary: they must respect the properties - proved in this section (such as no overlapping between the locations - of function arguments), but this leaves much liberty in choosing actual - locations. To ensure binary interoperability of code generated by our - compiler with libraries compiled by another PowerPC compiler, we - implement the standard conventions defined in the PowerPC application - binary interface. *) - -(** ** Location of function result *) - -(** The result value of a function is passed back to the caller in - registers [R3] or [F1], depending on the type of the returned value. - We treat a function without result as a function with one integer result. *) - -Definition loc_result (s: signature) : mreg := - match s.(sig_res) with - | None => R3 - | Some Tint => R3 - | Some Tfloat => F1 - end. - -(** The result location has the type stated in the signature. *) - -Lemma loc_result_type: - forall sig, - mreg_type (loc_result sig) = - match sig.(sig_res) with None => Tint | Some ty => ty end. -Proof. - intros; unfold loc_result. - destruct (sig_res sig). - destruct t; reflexivity. - reflexivity. -Qed. - -(** 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. - destruct (sig_res s). - destruct t; simpl; OrEq. - simpl; OrEq. -Qed. - -(** The result location is not a callee-save register. *) - -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_caller_save s). - generalize (int_callee_save_not_destroyed (loc_result s)). - generalize (float_callee_save_not_destroyed (loc_result s)). - tauto. -Qed. - -(** ** Location of function arguments *) - -(** The PowerPC ABI states the following convention for passing arguments - to a function: -- The first 8 integer arguments are passed in registers [R3] to [R10]. -- The first 10 float arguments are passed in registers [F1] to [F10]. -- Each float argument passed in a float register ``consumes'' two - integer arguments. -- Extra arguments are passed on the stack, in [Outgoing] slots, consecutively - assigned (1 word for an integer argument, 2 words for a float), - starting at word offset 0. -- Stack space is reserved (as unused [Outgoing] slots) for the arguments - that are passed in registers. - -These conventions are somewhat baroque, but they are mandated by the ABI. -*) - -Fixpoint loc_arguments_rec - (tyl: list typ) (iregl: list mreg) (fregl: list mreg) - (ofs: Z) {struct tyl} : list loc := - match tyl with - | nil => nil - | Tint :: tys => - match iregl with - | 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) :: 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 := - R3 :: R4 :: R5 :: R6 :: R7 :: R8 :: R9 :: R10 :: nil. -Definition float_param_regs := - F1 :: F2 :: F3 :: F4 :: F5 :: F6 :: F7 :: F8 :: F9 :: F10 :: nil. - -(** [loc_arguments s] returns the list of locations where to store arguments - 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 8. - -(** [size_arguments s] returns the number of [Outgoing] slots used - to call a function with signature [s]. *) - -Fixpoint size_arguments_rec - (tyl: list typ) (iregl: list mreg) (fregl: list mreg) - (ofs: Z) {struct tyl} : Z := - match tyl with - | 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) int_param_regs float_param_regs 8. - -(** 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 nonnegative offsets. *) - -Definition loc_argument_acceptable (l: loc) : Prop := - match l with - | R r => ~(In l temporaries) - | S (Outgoing ofs ty) => ofs >= 0 - | _ => False - end. - -Remark loc_arguments_rec_charact: - forall tyl iregl fregl ofs l, - In l (loc_arguments_rec tyl iregl fregl ofs) -> - match l with - | R r => In r iregl \/ In r fregl - | S (Outgoing ofs' ty) => ofs' >= ofs - | S _ => False - end. -Proof. - induction tyl; simpl loc_arguments_rec; intros. - elim H. - 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: - forall (s: signature) (r: loc), - In r (loc_arguments s) -> loc_argument_acceptable r. -Proof. - unfold loc_arguments; intros. - generalize (loc_arguments_rec_charact _ _ _ _ _ H). - destruct r. - intro H0; elim H0. simpl. unfold not. ElimOrEq; NotOrEq. - simpl. unfold not. ElimOrEq; NotOrEq. - destruct s0; try contradiction. - simpl. omega. -Qed. -Hint Resolve loc_arguments_acceptable: locs. - -(** Arguments are parwise disjoint (in the sense of [Loc.norepet]). *) - -Remark loc_arguments_rec_notin_reg: - forall tyl iregl fregl ofs r, - ~(In r iregl) -> ~(In r fregl) -> - Loc.notin (R r) (loc_arguments_rec tyl iregl fregl ofs). -Proof. - induction tyl; simpl; intros. - 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: - forall tyl iregl fregl ofs ofs0 ty0, - Loc.notin (S (Local ofs0 ty0)) (loc_arguments_rec tyl iregl fregl ofs). -Proof. - induction tyl; simpl; intros. - auto. - destruct a. - destruct iregl; simpl; auto. - destruct fregl; simpl; auto. -Qed. - -Remark loc_arguments_rec_notin_outgoing: - forall tyl iregl fregl ofs ofs0 ty0, - ofs0 + typesize ty0 <= ofs -> - Loc.notin (S (Outgoing ofs0 ty0)) (loc_arguments_rec tyl iregl fregl ofs). -Proof. - induction tyl; simpl; intros. - auto. - 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: - forall (s: signature), Loc.norepet (loc_arguments s). -Proof. - assert (forall tyl iregl fregl ofs, - list_norepet iregl -> - list_norepet fregl -> - list_disjoint iregl fregl -> - Loc.norepet (loc_arguments_rec tyl iregl fregl ofs)). - induction tyl; simpl; intros. - constructor. - 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. 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. 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. - unfold float_param_regs. NoRepet. - red; intros x y; simpl. ElimOrEq; ElimOrEq; discriminate. -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 >= 0. -Proof. - intros; unfold size_arguments. apply Zle_ge. apply Zle_trans with 8. omega. - 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 iregl fregl ofs0, - In (S (Outgoing ofs ty)) (loc_arguments_rec tyl iregl fregl ofs0) -> - 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. *) - -Lemma loc_arguments_not_temporaries: - forall sig, Loc.disjoint (loc_arguments sig) temporaries. -Proof. - intros; red; intros x1 x2 H. - generalize (loc_arguments_rec_charact _ _ _ _ _ H). - destruct x1. - intro H0; elim H0; simpl; (ElimOrEq; ElimOrEq; congruence). - destruct s; try contradiction. intro. - simpl; ElimOrEq; auto. -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: - forall sig l, - Loc.notin l destroyed_at_call -> loc_acceptable l -> - Loc.notin l (loc_arguments sig). -Proof. - intros. unfold loc_arguments. destruct l. - apply loc_arguments_rec_notin_reg. - generalize (Loc.notin_not_in _ _ H). intro; red; intro. - apply H1. generalize H2. simpl. ElimOrEq; OrEq. - generalize (Loc.notin_not_in _ _ H). intro; red; intro. - apply H1. generalize H2. simpl. ElimOrEq; OrEq. - destruct s; simpl in H0; try contradiction. - apply loc_arguments_rec_notin_local. -Qed. -Hint Resolve arguments_not_preserved: locs. - -(** Argument locations agree in number with the function signature. *) - -Lemma loc_arguments_length: - forall sig, - List.length (loc_arguments sig) = List.length sig.(sig_args). -Proof. - assert (forall tyl iregl fregl ofs, - List.length (loc_arguments_rec tyl iregl fregl ofs) = List.length tyl). - induction tyl; simpl; intros. - auto. - destruct a. - destruct iregl; simpl; decEq; auto. - destruct fregl; simpl; decEq; auto. - intros. unfold loc_arguments. auto. -Qed. - -(** Argument locations agree in types with the function signature. *) - -Lemma loc_arguments_type: - forall sig, List.map Loc.type (loc_arguments sig) = sig.(sig_args). -Proof. - assert (forall tyl iregl fregl ofs, - (forall r, In r iregl -> mreg_type r = Tint) -> - (forall r, In r fregl -> mreg_type r = Tfloat) -> - List.map Loc.type (loc_arguments_rec tyl iregl fregl ofs) = tyl). - induction tyl; simpl; intros. - 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. - intro; simpl. ElimOrEq; reflexivity. -Qed. - -(** There is no partial overlap between an argument location and an - acceptable location: they are either identical or disjoint. *) - -Lemma no_overlap_arguments: - forall args sg, - locs_acceptable args -> - Loc.no_overlap args (loc_arguments sg). -Proof. - unfold Loc.no_overlap; intros. - generalize (H r H0). - generalize (loc_arguments_acceptable _ _ H1). - destruct s; destruct r; simpl. - intros. case (mreg_eq m0 m); intro. left; congruence. tauto. - intros. right; destruct s; auto. - intros. right. auto. - destruct s; try tauto. destruct s0; tauto. -Qed. - -(** Decide whether a tailcall is possible. *) - -Definition tailcall_is_possible (sg: signature) : bool := - let fix tcisp (l: list loc) := - match l with - | nil => true - | R _ :: l' => tcisp l' - | S _ :: l' => false - end - in tcisp (loc_arguments sg). - -Lemma tailcall_is_possible_correct: - forall s, tailcall_is_possible s = true -> tailcall_possible s. -Proof. - intro s. unfold tailcall_is_possible, tailcall_possible. - generalize (loc_arguments s). induction l; simpl; intros. - elim H0. - destruct a. - destruct H0. subst l0. auto. apply IHl. auto. auto. discriminate. -Qed. - -(** ** Location of function parameters *) - -(** A function finds the values of its parameter in the same locations - where its caller stored them, except that the stack-allocated arguments, - viewed as [Outgoing] slots by the caller, are accessed via [Incoming] - slots (at the same offsets and types) in the callee. *) - -Definition parameter_of_argument (l: loc) : loc := - match l with - | S (Outgoing n ty) => S (Incoming n ty) - | _ => l - end. - -Definition loc_parameters (s: signature) := - List.map parameter_of_argument (loc_arguments s). - -Lemma loc_parameters_type: - forall sig, List.map Loc.type (loc_parameters sig) = sig.(sig_args). -Proof. - intros. unfold loc_parameters. - rewrite list_map_compose. - rewrite <- loc_arguments_type. - apply list_map_exten. - intros. destruct x; simpl. auto. - 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. - intro; red; intros. - unfold loc_parameters in H. - elim (list_in_map_inv _ _ _ H). intros y [EQ IN]. - generalize (loc_arguments_not_temporaries sig y x2 IN H0). - subst x1. destruct x2. - destruct y; simpl. auto. destruct s; auto. - byContradiction. generalize H0. simpl. NotOrEq. -Qed. - -Lemma no_overlap_parameters: - forall params sg, - locs_acceptable params -> - Loc.no_overlap (loc_parameters sg) params. -Proof. - unfold Loc.no_overlap; intros. - unfold loc_parameters in H0. - elim (list_in_map_inv _ _ _ H0). intros t [EQ IN]. - rewrite EQ. - generalize (loc_arguments_acceptable _ _ IN). - generalize (H s H1). - destruct s; destruct t; simpl. - intros. case (mreg_eq m0 m); intro. left; congruence. tauto. - intros. right; destruct s; simpl; auto. - intros; right; auto. - destruct s; try tauto. destruct s0; try tauto. - intros; simpl. tauto. -Qed. - -(** ** Location of argument and result for dynamic memory allocation *) - -Definition loc_alloc_argument := R3. -Definition loc_alloc_result := R3. diff --git a/backend/Linear.v b/backend/Linear.v index 900b6a5..629dcc5 100644 --- a/backend/Linear.v +++ b/backend/Linear.v @@ -337,7 +337,7 @@ Inductive initial_state (p: program): state -> Prop := Inductive final_state: state -> int -> Prop := | final_state_intro: forall rs m r, - rs (R R3) = Vint r -> + rs (R (Conventions.loc_result (mksignature nil (Some Tint)))) = Vint r -> final_state (Returnstate nil rs m) r. Definition exec_program (p: program) (beh: program_behavior) : Prop := diff --git a/backend/Linearizeaux.ml b/backend/Linearizeaux.ml new file mode 100644 index 0000000..2f2333f --- /dev/null +++ b/backend/Linearizeaux.ml @@ -0,0 +1,85 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +open BinPos +open Coqlib +open Datatypes +open LTL +open Lattice +open CList +open Maps +open Camlcoq + +(* Trivial enumeration, in decreasing order of PC *) + +(*** +let enumerate_aux f reach = + positive_rec + Coq_nil + (fun pc nodes -> + if PMap.get pc reach + then Coq_cons (pc, nodes) + else nodes) + f.fn_nextpc +***) + +(* More clever enumeration that flattens basic blocks *) + +let rec int_of_pos = function + | Coq_xI p -> (int_of_pos p lsl 1) + 1 + | Coq_xO p -> int_of_pos p lsl 1 + | Coq_xH -> 1 + +let rec pos_of_int n = + if n = 0 then assert false else + if n = 1 then Coq_xH else + if n land 1 = 0 + then Coq_xO (pos_of_int (n lsr 1)) + else Coq_xI (pos_of_int (n lsr 1)) + +(* Build the enumeration *) + +module IntSet = Set.Make(struct type t = int let compare = compare end) + +let enumerate_aux f reach = + let enum = ref [] in + let emitted = Array.make (int_of_pos f.fn_nextpc) false in + let rec emit_block pending pc = + let npc = int_of_pos pc in + if emitted.(npc) + then emit_restart pending + else begin + enum := pc :: !enum; + emitted.(npc) <- true; + match PTree.get pc f.fn_code with + | None -> assert false + | Some i -> + match i with + | Lnop s -> emit_block pending s + | Lop (op, args, res, s) -> emit_block pending s + | Lload (chunk, addr, args, dst, s) -> emit_block pending s + | Lstore (chunk, addr, args, src, s) -> emit_block pending s + | Lcall (sig0, ros, args, res, s) -> emit_block pending s + | Ltailcall (sig0, ros, args) -> emit_restart pending + | Lalloc (arg, res, s) -> emit_block pending s + | Lcond (cond, args, ifso, ifnot) -> + emit_restart (IntSet.add (int_of_pos ifso) + (IntSet.add (int_of_pos ifnot) pending)) + | Lreturn optarg -> emit_restart pending + end + and emit_restart pending = + if not (IntSet.is_empty pending) then begin + let npc = IntSet.max_elt pending in + emit_block (IntSet.remove npc pending) (pos_of_int npc) + end in + emit_block IntSet.empty f.fn_entrypoint; + CList.rev !enum diff --git a/backend/Linearizeproof.v b/backend/Linearizeproof.v index 3451cdb..8378332 100644 --- a/backend/Linearizeproof.v +++ b/backend/Linearizeproof.v @@ -546,8 +546,9 @@ Proof. exploit find_label_lin_succ; eauto. inv WTI; auto. intros [c'' AT']. econstructor; split. eapply plus_left'. - eapply exec_Lload; eauto. + apply exec_Lload with a. rewrite <- H0. apply eval_addressing_preserved. exact symbols_preserved. + eauto. eapply add_branch_correct; eauto. eapply is_tail_add_branch. eapply is_tail_cons_left. eapply is_tail_find_label. eauto. @@ -562,8 +563,9 @@ Proof. exploit find_label_lin_succ; eauto. inv WTI; auto. intros [c'' AT']. econstructor; split. eapply plus_left'. - eapply exec_Lstore; eauto. + apply exec_Lstore with a. rewrite <- H0. apply eval_addressing_preserved. exact symbols_preserved. + eauto. eapply add_branch_correct; eauto. eapply is_tail_add_branch. eapply is_tail_cons_left. eapply is_tail_find_label. eauto. diff --git a/backend/Locations.v b/backend/Locations.v index b03657c..ca2f527 100644 --- a/backend/Locations.v +++ b/backend/Locations.v @@ -17,102 +17,17 @@ Require Import Coqlib. Require Import Maps. Require Import AST. Require Import Values. +Require Export Machregs. (** * Representation of locations *) (** A location is either a processor register or (an abstract designation of) a slot in the activation record of the current function. *) -(** ** Machine registers *) - -(** The following type defines the machine registers that can be referenced - as locations. These include: -- Integer registers that can be allocated to RTL pseudo-registers ([Rxx]). -- Floating-point registers that can be allocated to RTL pseudo-registers - ([Fxx]). -- Two integer registers, not allocatable, reserved as temporaries for - spilling and reloading ([IT1, IT2]). -- Two float registers, not allocatable, reserved as temporaries for - spilling and reloading ([FT1, FT2]). - - The type [mreg] does not include special-purpose machine registers - such as the stack pointer and the condition codes. *) - -Inductive mreg: Set := - (** Allocatable integer regs *) - | R3: mreg | R4: mreg | R5: mreg | R6: mreg - | R7: mreg | R8: mreg | R9: mreg | R10: mreg - | R13: mreg | R14: mreg | R15: mreg | R16: mreg - | R17: mreg | R18: mreg | R19: mreg | R20: mreg - | R21: mreg | R22: mreg | R23: mreg | R24: mreg - | R25: mreg | R26: mreg | R27: mreg | R28: mreg - | R29: mreg | R30: mreg | R31: mreg - (** Allocatable float regs *) - | F1: mreg | F2: mreg | F3: mreg | F4: mreg - | F5: mreg | F6: mreg | F7: mreg | F8: mreg - | F9: mreg | F10: mreg | F14: mreg | F15: mreg - | F16: mreg | F17: mreg | F18: mreg | F19: mreg - | F20: mreg | F21: mreg | F22: mreg | F23: mreg - | F24: mreg | F25: mreg | F26: mreg | F27: mreg - | F28: mreg | F29: mreg | F30: mreg | F31: mreg - (** Integer temporaries *) - | IT1: mreg (* R11 *) | IT2: mreg (* R0 *) - (** Float temporaries *) - | FT1: mreg (* F11 *) | FT2: mreg (* F12 *) | FT3: mreg (* F0 *). - -Lemma mreg_eq: forall (r1 r2: mreg), {r1 = r2} + {r1 <> r2}. -Proof. decide equality. Qed. - -Definition mreg_type (r: mreg): typ := - match r with - | R3 => Tint | R4 => Tint | R5 => Tint | R6 => Tint - | R7 => Tint | R8 => Tint | R9 => Tint | R10 => Tint - | R13 => Tint | R14 => Tint | R15 => Tint | R16 => Tint - | R17 => Tint | R18 => Tint | R19 => Tint | R20 => Tint - | R21 => Tint | R22 => Tint | R23 => Tint | R24 => Tint - | R25 => Tint | R26 => Tint | R27 => Tint | R28 => Tint - | R29 => Tint | R30 => Tint | R31 => Tint - | F1 => Tfloat | F2 => Tfloat | F3 => Tfloat | F4 => Tfloat - | F5 => Tfloat | F6 => Tfloat | F7 => Tfloat | F8 => Tfloat - | F9 => Tfloat | F10 => Tfloat | F14 => Tfloat | F15 => Tfloat - | F16 => Tfloat | F17 => Tfloat | F18 => Tfloat | F19 => Tfloat - | F20 => Tfloat | F21 => Tfloat | F22 => Tfloat | F23 => Tfloat - | F24 => Tfloat | F25 => Tfloat | F26 => Tfloat | F27 => Tfloat - | F28 => Tfloat | F29 => Tfloat | F30 => Tfloat | F31 => Tfloat - | IT1 => Tint | IT2 => Tint - | FT1 => Tfloat | FT2 => Tfloat | FT3 => Tfloat - end. +(** ** Processor registers *) -Open Scope positive_scope. - -Module IndexedMreg <: INDEXED_TYPE. - Definition t := mreg. - Definition eq := mreg_eq. - Definition index (r: mreg): positive := - match r with - | R3 => 1 | R4 => 2 | R5 => 3 | R6 => 4 - | R7 => 5 | R8 => 6 | R9 => 7 | R10 => 8 - | R13 => 9 | R14 => 10 | R15 => 11 | R16 => 12 - | R17 => 13 | R18 => 14 | R19 => 15 | R20 => 16 - | R21 => 17 | R22 => 18 | R23 => 19 | R24 => 20 - | R25 => 21 | R26 => 22 | R27 => 23 | R28 => 24 - | R29 => 25 | R30 => 26 | R31 => 27 - | F1 => 28 | F2 => 29 | F3 => 30 | F4 => 31 - | F5 => 32 | F6 => 33 | F7 => 34 | F8 => 35 - | F9 => 36 | F10 => 37 | F14 => 38 | F15 => 39 - | F16 => 40 | F17 => 41 | F18 => 42 | F19 => 43 - | F20 => 44 | F21 => 45 | F22 => 46 | F23 => 47 - | F24 => 48 | F25 => 49 | F26 => 50 | F27 => 51 - | F28 => 52 | F29 => 53 | F30 => 54 | F31 => 55 - | IT1 => 56 | IT2 => 57 - | FT1 => 58 | FT2 => 59 | FT3 => 60 - end. - Lemma index_inj: - forall r1 r2, index r1 = index r2 -> r1 = r2. - Proof. - destruct r1; destruct r2; simpl; intro; discriminate || reflexivity. - Qed. -End IndexedMreg. +(** Processor registers usable for register allocation are defined + in module [Machregs]. *) (** ** Slots in activation records *) diff --git a/backend/Machabstr.v b/backend/Machabstr.v index 9ef75ec..e145c89 100644 --- a/backend/Machabstr.v +++ b/backend/Machabstr.v @@ -26,7 +26,7 @@ Require Import Op. Require Import Locations. Require Conventions. Require Import Mach. -Require Stacking. +Require Stacklayout. (** This file defines the "abstract" semantics for the Mach intermediate language, as opposed to the more concrete @@ -134,7 +134,7 @@ Inductive extcall_arg: regset -> frame -> loc -> val -> Prop := | extcall_arg_reg: forall rs fr r, extcall_arg rs fr (R r) (rs r) | extcall_arg_stack: forall rs fr ofs ty v, - get_slot fr ty (Int.signed (Int.repr (Stacking.fe_ofs_arg + 4 * ofs))) v -> + get_slot fr ty (Int.signed (Int.repr (Stacklayout.fe_ofs_arg + 4 * ofs))) v -> extcall_arg rs fr (S (Outgoing ofs ty)) v. Inductive extcall_args: regset -> frame -> list loc -> list val -> Prop := @@ -323,7 +323,7 @@ Inductive initial_state (p: program): state -> Prop := Inductive final_state: state -> int -> Prop := | final_state_intro: forall rs m r, - rs R3 = Vint r -> + rs (Conventions.loc_result (mksignature nil (Some Tint))) = Vint r -> final_state (Returnstate nil rs m) r. Definition exec_program (p: program) (beh: program_behavior) : Prop := diff --git a/backend/Machabstr2concr.v b/backend/Machabstr2concr.v index 2dd3134..7eae610 100644 --- a/backend/Machabstr2concr.v +++ b/backend/Machabstr2concr.v @@ -27,7 +27,7 @@ Require Import Mach. Require Import Machtyping. Require Import Machabstr. Require Import Machconcr. -Require Import PPCgenretaddr. +Require Import Asmgenretaddr. (** Two semantics were defined for the Mach intermediate language: - The concrete semantics (file [Mach]), where the whole activation @@ -43,7 +43,7 @@ Require Import PPCgenretaddr. 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 + as output) and that in file [Asmgenproof] (which uses the concrete Mach semantics as input). *) diff --git a/backend/Machconcr.v b/backend/Machconcr.v index 5ca3cad..41216d2 100644 --- a/backend/Machconcr.v +++ b/backend/Machconcr.v @@ -25,8 +25,8 @@ Require Import Op. Require Import Locations. Require Conventions. Require Import Mach. -Require Stacking. -Require PPCgenretaddr. +Require Stacklayout. +Require Asmgenretaddr. (** In the concrete semantics for Mach, the three stack-related Mach instructions are interpreted as memory accesses relative to the @@ -45,14 +45,14 @@ In addition to this linking of activation records, the concrete semantics also make provisions for storing a back link at offset [f.(fn_link_ofs)] from the stack pointer, and a return address at offset [f.(fn_retaddr_ofs)]. The latter stack location will be used -by the PPC code generated by [PPCgen] to save the return address into +by the Asm code generated by [Asmgen] 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. +[Asmgenretaddr] is used to guess the value of the return address that +the Asm code generated later will store in the reserved location. *) Definition chunk_of_type (ty: typ) := @@ -70,7 +70,7 @@ 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 (Stacking.fe_ofs_arg + 4 * ofs)) = Some v -> + load_stack m sp ty (Int.repr (Stacklayout.fe_ofs_arg + 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 := @@ -90,7 +90,7 @@ Inductive stackframe: Set := | Stackframe: forall (f: block) (**r pointer to calling function *) (sp: val) (**r stack pointer in calling function *) - (retaddr: val) (**r PPC return address in calling function *) + (retaddr: val) (**r Asm return address in calling function *) (c: code), (**r program point in calling function *) stackframe. @@ -174,7 +174,7 @@ Inductive step: state -> trace -> state -> Prop := 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 -> + Asmgenretaddr.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) @@ -252,7 +252,7 @@ Inductive initial_state (p: program): state -> Prop := Inductive final_state: state -> int -> Prop := | final_state_intro: forall rs m r, - rs R3 = Vint r -> + rs (Conventions.loc_result (mksignature nil (Some Tint))) = Vint r -> final_state (Returnstate nil rs m) r. Definition exec_program (p: program) (beh: program_behavior) : Prop := diff --git a/backend/Op.v b/backend/Op.v deleted file mode 100644 index 5665d72..0000000 --- a/backend/Op.v +++ /dev/null @@ -1,906 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** Operators and addressing modes. The abstract syntax and dynamic - 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; -- [addressing]: addressing modes for load and store operations. - - These types are PowerPC-specific and correspond roughly to what the - 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 Cminor language. -*) - -Require Import Coqlib. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import Mem. -Require Import Globalenvs. - -Set Implicit Arguments. - -(** Conditions (boolean-valued operators). *) - -Inductive condition : Set := - | Ccomp: comparison -> condition (**r signed integer comparison *) - | Ccompu: comparison -> condition (**r unsigned integer comparison *) - | Ccompimm: comparison -> int -> condition (**r signed integer comparison with a constant *) - | Ccompuimm: comparison -> int -> condition (**r unsigned integer comparison with a constant *) - | Ccompf: comparison -> condition (**r floating-point comparison *) - | Cnotcompf: comparison -> condition (**r negation of a floating-point comparison *) - | Cmaskzero: int -> condition (**r test [(arg & constant) == 0] *) - | Cmasknotzero: int -> condition. (**r test [(arg & constant) != 0] *) - -(** Arithmetic and logical operations. In the descriptions, [rd] is the - result of the operation and [r1], [r2], etc, are the arguments. *) - -Inductive operation : Set := - | Omove: operation (**r [rd = r1] *) - | Ointconst: int -> operation (**r [rd] is set to the given integer constant *) - | 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 *) -(*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] *) - | Ocast16signed: operation (**r [rd] is 16-bit sign extension of [r1] *) - | Ocast16unsigned: operation (**r [rd] is 16-bit zero extension of [r1] *) - | Oadd: operation (**r [rd = r1 + r2] *) - | Oaddimm: int -> operation (**r [rd = r1 + n] *) - | Osub: operation (**r [rd = r1 - r2] *) - | Osubimm: int -> operation (**r [rd = n - r1] *) - | Omul: operation (**r [rd = r1 * r2] *) - | Omulimm: int -> operation (**r [rd = r1 * n] *) - | Odiv: operation (**r [rd = r1 / r2] (signed) *) - | Odivu: operation (**r [rd = r1 / r2] (unsigned) *) - | Oand: operation (**r [rd = r1 & r2] *) - | Oandimm: int -> operation (**r [rd = r1 & n] *) - | Oor: operation (**r [rd = r1 | r2] *) - | Oorimm: int -> operation (**r [rd = r1 | n] *) - | Oxor: operation (**r [rd = r1 ^ r2] *) - | Oxorimm: int -> operation (**r [rd = r1 ^ n] *) - | Onand: operation (**r [rd = ~(r1 & r2)] *) - | Onor: operation (**r [rd = ~(r1 | r2)] *) - | Onxor: operation (**r [rd = ~(r1 ^ r2)] *) - | Oshl: operation (**r [rd = r1 << r2] *) - | Oshr: operation (**r [rd = r1 >> r2] (signed) *) - | Oshrimm: int -> operation (**r [rd = r1 >> n] (signed) *) - | Oshrximm: int -> operation (**r [rd = r1 / 2^n] (signed) *) - | Oshru: operation (**r [rd = r1 >> r2] (unsigned) *) - | Orolm: int -> int -> operation (**r rotate left and mask *) -(*c Floating-point arithmetic: *) - | Onegf: operation (**r [rd = - r1] *) - | Oabsf: operation (**r [rd = abs(r1)] *) - | Oaddf: operation (**r [rd = r1 + r2] *) - | Osubf: operation (**r [rd = r1 - r2] *) - | Omulf: operation (**r [rd = r1 * r2] *) - | Odivf: operation (**r [rd = r1 / r2] *) - | Omuladdf: operation (**r [rd = r1 * r2 + r3] *) - | Omulsubf: operation (**r [rd = r1 * r2 - r3] *) - | Osingleoffloat: operation (**r [rd] is [r1] truncated to single-precision float *) -(*c Conversions between int and float: *) - | Ointoffloat: operation (**r [rd = signed_int_of_float(r1)] *) - | Ointuoffloat: operation (**r [rd = unsigned_int_of_float(r1)] *) - | Ofloatofint: operation (**r [rd = float_of_signed_int(r1)] *) - | Ofloatofintu: operation (**r [rd = float_of_unsigned_int(r1)] *) -(*c Boolean tests: *) - | Ocmp: condition -> operation. (**r [rd = 1] if condition holds, [rd = 0] otherwise. *) - -(** Addressing modes. [r1], [r2], etc, are the arguments to the - addressing. *) - -Inductive addressing: Set := - | Aindexed: int -> addressing (**r Address is [r1 + offset] *) - | Aindexed2: addressing (**r Address is [r1 + r2] *) - | Aglobal: ident -> int -> addressing (**r Address is [symbol + offset] *) - | Abased: ident -> int -> addressing (**r Address is [symbol + offset + r1] *) - | Ainstack: int -> addressing. (**r Address is [stack_pointer + offset] *) - -(** Evaluation of conditions, operators and addressing modes applied - to lists of values. Return [None] when the computation is undefined: - wrong number of arguments, arguments of the wrong types, undefined - operations such as division by zero. [eval_condition] returns a boolean, - [eval_operation] and [eval_addressing] return a value. *) - -Definition eval_compare_mismatch (c: comparison) : option bool := - match c with Ceq => Some false | Cne => Some true | _ => None end. - -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 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 eval_compare_mismatch c - else None - | Ccomp c, Vptr b1 n1 :: Vint n2 :: nil => - if Int.eq n2 Int.zero then eval_compare_mismatch c else None - | Ccomp c, Vint n1 :: Vptr b2 n2 :: nil => - if Int.eq n1 Int.zero then eval_compare_mismatch c else None - | Ccompu c, Vint n1 :: Vint n2 :: nil => - Some (Int.cmpu c n1 n2) - | Ccompimm c n, Vint n1 :: nil => - Some (Int.cmp c n1 n) - | Ccompimm c n, Vptr b1 n1 :: nil => - if Int.eq n Int.zero then eval_compare_mismatch c else None - | Ccompuimm c n, Vint n1 :: nil => - Some (Int.cmpu c n1 n) - | Ccompf c, Vfloat f1 :: Vfloat f2 :: nil => - Some (Float.cmp c f1 f2) - | Cnotcompf c, Vfloat f1 :: Vfloat f2 :: nil => - Some (negb (Float.cmp c f1 f2)) - | Cmaskzero n, Vint n1 :: nil => - Some (Int.eq (Int.and n1 n) Int.zero) - | Cmasknotzero n, Vint n1 :: nil => - Some (negb (Int.eq (Int.and n1 n) Int.zero)) - | _, _ => - None - end. - -Definition offset_sp (sp: val) (delta: int) : option val := - match sp with - | Vptr b n => Some (Vptr b (Int.add n delta)) - | _ => None - end. - -Definition eval_operation - (F: Set) (genv: Genv.t F) (sp: 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) - | Ofloatconst n, nil => Some (Vfloat n) - | Oaddrsymbol s ofs, nil => - match Genv.find_symbol genv s with - | None => None - | Some b => Some (Vptr b ofs) - end - | Oaddrstack ofs, nil => offset_sp sp ofs - | Ocast8signed, v1 :: nil => Some (Val.sign_ext 8 v1) - | Ocast8unsigned, v1 :: nil => Some (Val.zero_ext 8 v1) - | Ocast16signed, v1 :: nil => Some (Val.sign_ext 16 v1) - | Ocast16unsigned, v1 :: nil => Some (Val.zero_ext 16 v1) - | 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)) - | Oaddimm n, Vint n1 :: nil => Some (Vint (Int.add n1 n)) - | Oaddimm n, Vptr b1 n1 :: nil => Some (Vptr b1 (Int.add n1 n)) - | 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 - | Osubimm n, Vint n1 :: nil => Some (Vint (Int.sub n n1)) - | Omul, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.mul n1 n2)) - | Omulimm n, Vint n1 :: nil => Some (Vint (Int.mul n1 n)) - | 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)) - | Oand, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.and n1 n2)) - | Oandimm n, Vint n1 :: nil => Some (Vint (Int.and n1 n)) - | Oor, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.or n1 n2)) - | Oorimm n, Vint n1 :: nil => Some (Vint (Int.or n1 n)) - | Oxor, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.xor n1 n2)) - | Oxorimm n, Vint n1 :: nil => Some (Vint (Int.xor n1 n)) - | Onand, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.not (Int.and n1 n2))) - | Onor, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.not (Int.or n1 n2))) - | Onxor, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.not (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 - | Oshrimm n, Vint n1 :: nil => - if Int.ltu n (Int.repr 32) then Some (Vint (Int.shr n1 n)) else None - | Oshrximm n, Vint n1 :: nil => - if Int.ltu n (Int.repr 32) then Some (Vint (Int.shrx n1 n)) else None - | Oshru, Vint n1 :: Vint n2 :: nil => - if Int.ltu n2 (Int.repr 32) then Some (Vint (Int.shru n1 n2)) else None - | Orolm amount mask, Vint n1 :: nil => - Some (Vint (Int.rolm n1 amount mask)) - | 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)) - | Omuladdf, Vfloat f1 :: Vfloat f2 :: Vfloat f3 :: nil => - Some (Vfloat (Float.add (Float.mul f1 f2) f3)) - | Omulsubf, Vfloat f1 :: Vfloat f2 :: Vfloat f3 :: nil => - Some (Vfloat (Float.sub (Float.mul f1 f2) f3)) - | Osingleoffloat, v1 :: nil => - Some (Val.singleoffloat v1) - | Ointoffloat, Vfloat f1 :: nil => - Some (Vint (Float.intoffloat f1)) - | Ointuoffloat, Vfloat f1 :: nil => - Some (Vint (Float.intuoffloat f1)) - | Ofloatofint, Vint n1 :: nil => - Some (Vfloat (Float.floatofint n1)) - | Ofloatofintu, Vint n1 :: nil => - Some (Vfloat (Float.floatofintu n1)) - | Ocmp c, _ => - match eval_condition c vl m with - | None => None - | Some false => Some Vfalse - | Some true => Some Vtrue - end - | _, _ => None - end. - -Definition eval_addressing - (F: Set) (genv: Genv.t F) (sp: val) - (addr: addressing) (vl: list val) : option val := - match addr, vl with - | Aindexed n, Vptr b1 n1 :: nil => - Some (Vptr b1 (Int.add n1 n)) - | Aindexed2, Vptr b1 n1 :: Vint n2 :: nil => - Some (Vptr b1 (Int.add n1 n2)) - | Aindexed2, Vint n1 :: Vptr b2 n2 :: nil => - Some (Vptr b2 (Int.add n2 n1)) - | Aglobal s ofs, nil => - match Genv.find_symbol genv s with - | None => None - | Some b => Some (Vptr b ofs) - end - | Abased s ofs, Vint n1 :: nil => - match Genv.find_symbol genv s with - | None => None - | Some b => Some (Vptr b (Int.add ofs n1)) - end - | Ainstack ofs, nil => - offset_sp sp ofs - | _, _ => None - end. - -Definition negate_condition (cond: condition): condition := - match cond with - | Ccomp c => Ccomp(negate_comparison c) - | Ccompu c => Ccompu(negate_comparison c) - | Ccompimm c n => Ccompimm (negate_comparison c) n - | Ccompuimm c n => Ccompuimm (negate_comparison c) n - | Ccompf c => Cnotcompf c - | Cnotcompf c => Ccompf c - | Cmaskzero n => Cmasknotzero n - | Cmasknotzero n => Cmaskzero n - end. - -Ltac FuncInv := - match goal with - | H: (match ?x with nil => _ | _ :: _ => _ end = Some _) |- _ => - destruct x; simpl in H; try discriminate; FuncInv - | H: (match ?v with Vundef => _ | Vint _ => _ | Vfloat _ => _ | Vptr _ _ => _ end = Some _) |- _ => - destruct v; simpl in H; try discriminate; FuncInv - | H: (Some _ = Some _) |- _ => - injection H; intros; clear H; FuncInv - | _ => - idtac - end. - -Remark eval_negate_compare_mismatch: - forall c b, - eval_compare_mismatch c = Some b -> - eval_compare_mismatch (negate_comparison c) = Some (negb b). -Proof. - intros until b. unfold eval_compare_mismatch. - destruct c; intro EQ; inv EQ; auto. -Qed. - -Lemma eval_negate_condition: - 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. - destruct (Int.eq i Int.zero). apply eval_negate_compare_mismatch; auto. discriminate. - destruct (Int.eq i0 Int.zero). apply eval_negate_compare_mismatch; auto. discriminate. - 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. - apply eval_negate_compare_mismatch; auto. - discriminate. - rewrite Int.negate_cmpu. auto. - rewrite Int.negate_cmp. auto. - destruct (Int.eq i Int.zero). apply eval_negate_compare_mismatch; auto. discriminate. - rewrite Int.negate_cmpu. auto. - auto. - rewrite negb_elim. auto. - auto. - rewrite negb_elim. auto. -Qed. - -(** [eval_operation] and [eval_addressing] depend on a global environment - for resolving references to global symbols. We show that they give - the same results if a global environment is replaced by another that - assigns the same addresses to the same symbols. *) - -Section GENV_TRANSF. - -Variable F1 F2: Set. -Variable ge1: Genv.t F1. -Variable ge2: Genv.t F2. -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 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; - reflexivity. -Qed. - -Lemma eval_addressing_preserved: - forall sp addr vl, - eval_addressing ge2 sp addr vl = eval_addressing ge1 sp addr vl. -Proof. - intros. - unfold eval_addressing; destruct addr; try rewrite agree_on_symbols; - reflexivity. -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 - (A: Set) (op: operation) (args: list A) : option A := - match op, args with - | Omove, arg :: nil => Some arg - | _, _ => None - end. - -Lemma is_move_operation_correct: - forall (A: Set) (op: operation) (args: list A) (a: A), - is_move_operation op args = Some a -> - op = Omove /\ args = a :: nil. -Proof. - intros until a. unfold is_move_operation; destruct op; - try (intros; discriminate). - destruct args. intros; discriminate. - destruct args. intros. intuition congruence. - intros; discriminate. -Qed. - -(** Static typing of conditions, operators and addressing modes. *) - -Definition type_of_condition (c: condition) : list typ := - match c with - | Ccomp _ => Tint :: Tint :: nil - | Ccompu _ => Tint :: Tint :: nil - | Ccompimm _ _ => Tint :: nil - | Ccompuimm _ _ => Tint :: nil - | Ccompf _ => Tfloat :: Tfloat :: nil - | Cnotcompf _ => Tfloat :: Tfloat :: nil - | Cmaskzero _ => Tint :: nil - | Cmasknotzero _ => Tint :: nil - end. - -Definition type_of_operation (op: operation) : list typ * typ := - match op with - | Omove => (nil, Tint) (* treated specially *) - | Ointconst _ => (nil, Tint) - | Ofloatconst _ => (nil, Tfloat) - | Oaddrsymbol _ _ => (nil, Tint) - | Oaddrstack _ => (nil, Tint) - | Ocast8signed => (Tint :: nil, Tint) - | Ocast8unsigned => (Tint :: nil, Tint) - | Ocast16signed => (Tint :: nil, Tint) - | Ocast16unsigned => (Tint :: nil, Tint) - | Oadd => (Tint :: Tint :: nil, Tint) - | Oaddimm _ => (Tint :: nil, Tint) - | Osub => (Tint :: Tint :: nil, Tint) - | Osubimm _ => (Tint :: nil, Tint) - | Omul => (Tint :: Tint :: nil, Tint) - | Omulimm _ => (Tint :: nil, Tint) - | Odiv => (Tint :: Tint :: nil, Tint) - | Odivu => (Tint :: Tint :: nil, Tint) - | Oand => (Tint :: Tint :: nil, Tint) - | Oandimm _ => (Tint :: nil, Tint) - | Oor => (Tint :: Tint :: nil, Tint) - | Oorimm _ => (Tint :: nil, Tint) - | Oxor => (Tint :: Tint :: nil, Tint) - | Oxorimm _ => (Tint :: nil, Tint) - | Onand => (Tint :: Tint :: nil, Tint) - | Onor => (Tint :: Tint :: nil, Tint) - | Onxor => (Tint :: Tint :: nil, Tint) - | Oshl => (Tint :: Tint :: nil, Tint) - | Oshr => (Tint :: Tint :: nil, Tint) - | Oshrimm _ => (Tint :: nil, Tint) - | Oshrximm _ => (Tint :: nil, Tint) - | Oshru => (Tint :: Tint :: nil, Tint) - | Orolm _ _ => (Tint :: nil, Tint) - | Onegf => (Tfloat :: nil, Tfloat) - | Oabsf => (Tfloat :: nil, Tfloat) - | Oaddf => (Tfloat :: Tfloat :: nil, Tfloat) - | Osubf => (Tfloat :: Tfloat :: nil, Tfloat) - | Omulf => (Tfloat :: Tfloat :: nil, Tfloat) - | Odivf => (Tfloat :: Tfloat :: nil, Tfloat) - | Omuladdf => (Tfloat :: Tfloat :: Tfloat :: nil, Tfloat) - | Omulsubf => (Tfloat :: Tfloat :: Tfloat :: nil, Tfloat) - | Osingleoffloat => (Tfloat :: nil, Tfloat) - | Ointoffloat => (Tfloat :: nil, Tint) - | Ointuoffloat => (Tfloat :: nil, Tint) - | Ofloatofint => (Tint :: nil, Tfloat) - | Ofloatofintu => (Tint :: nil, Tfloat) - | Ocmp c => (type_of_condition c, Tint) - end. - -Definition type_of_addressing (addr: addressing) : list typ := - match addr with - | Aindexed _ => Tint :: nil - | Aindexed2 => Tint :: Tint :: nil - | Aglobal _ _ => nil - | Abased _ _ => Tint :: nil - | Ainstack _ => nil - end. - -Definition type_of_chunk (c: memory_chunk) : typ := - match c with - | Mint8signed => Tint - | Mint8unsigned => Tint - | Mint16signed => Tint - | Mint16unsigned => Tint - | Mint32 => Tint - | Mfloat32 => Tfloat - | Mfloat64 => Tfloat - end. - -(** Weak type soundness results for [eval_operation]: - the result values, when defined, are always of the type predicted - by [type_of_operation]. *) - -Section SOUNDNESS. - -Variable A: Set. -Variable genv: Genv.t A. - -Lemma type_of_operation_sound: - 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 H0; FuncInv; try subst v; try exact I. - congruence. - 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 H0; intro; subst v; exact I. - discriminate. - destruct (Int.eq i0 Int.zero). discriminate. - injection H0; intro; subst v; exact I. - destruct (Int.eq i0 Int.zero). discriminate. - injection H0; intro; subst v; exact I. - destruct (Int.ltu i0 (Int.repr 32)). - injection H0; intro; subst v; exact I. discriminate. - destruct (Int.ltu i0 (Int.repr 32)). - injection H0; intro; subst v; exact I. discriminate. - destruct (Int.ltu i (Int.repr 32)). - injection H0; intro; subst v; exact I. discriminate. - destruct (Int.ltu i (Int.repr 32)). - injection H0; intro; subst v; exact I. discriminate. - destruct (Int.ltu i0 (Int.repr 32)). - injection H0; intro; subst v; exact I. discriminate. - destruct v0; exact I. - destruct (eval_condition c vl). - destruct b; injection H0; intro; subst v; exact I. - discriminate. -Qed. - -Lemma type_of_chunk_correct: - forall chunk m addr v, - Mem.loadv chunk m addr = Some v -> - Val.has_type v (type_of_chunk chunk). -Proof. - intro chunk. - assert (forall v, Val.has_type (Val.load_result chunk v) (type_of_chunk chunk)). - destruct v; destruct chunk; exact I. - intros until v. unfold Mem.loadv. - destruct addr; intros; try discriminate. - generalize (Mem.load_inv _ _ _ _ _ H0). - intros [X Y]. subst v. apply H. -Qed. - -End SOUNDNESS. - -(** Alternate definition of [eval_condition], [eval_op], [eval_addressing] - as total functions that return [Vundef] when not applicable - (instead of [None]). Used in the proof of [PPCgen]. *) - -Section EVAL_OP_TOTAL. - -Variable F: Set. -Variable genv: Genv.t F. - -Definition find_symbol_offset (id: ident) (ofs: int) : val := - match Genv.find_symbol genv id with - | Some b => Vptr b ofs - | None => Vundef - end. - -Definition eval_condition_total (cond: condition) (vl: list val) : val := - match cond, vl with - | Ccomp c, v1::v2::nil => Val.cmp c v1 v2 - | Ccompu c, v1::v2::nil => Val.cmpu c v1 v2 - | Ccompimm c n, v1::nil => Val.cmp c v1 (Vint n) - | Ccompuimm c n, v1::nil => Val.cmpu c v1 (Vint n) - | Ccompf c, v1::v2::nil => Val.cmpf c v1 v2 - | Cnotcompf c, v1::v2::nil => Val.notbool(Val.cmpf c v1 v2) - | Cmaskzero n, v1::nil => Val.notbool (Val.and v1 (Vint n)) - | Cmasknotzero n, v1::nil => Val.notbool(Val.notbool (Val.and v1 (Vint n))) - | _, _ => Vundef - end. - -Definition eval_operation_total (sp: val) (op: operation) (vl: list val) : val := - match op, vl with - | Omove, v1::nil => v1 - | Ointconst n, nil => Vint n - | Ofloatconst n, nil => Vfloat n - | Oaddrsymbol s ofs, nil => find_symbol_offset s ofs - | Oaddrstack ofs, nil => Val.add sp (Vint ofs) - | Ocast8signed, v1::nil => Val.sign_ext 8 v1 - | Ocast8unsigned, v1::nil => Val.zero_ext 8 v1 - | Ocast16signed, v1::nil => Val.sign_ext 16 v1 - | Ocast16unsigned, v1::nil => Val.zero_ext 16 v1 - | Oadd, v1::v2::nil => Val.add v1 v2 - | Oaddimm n, v1::nil => Val.add v1 (Vint n) - | Osub, v1::v2::nil => Val.sub v1 v2 - | Osubimm n, v1::nil => Val.sub (Vint n) v1 - | Omul, v1::v2::nil => Val.mul v1 v2 - | Omulimm n, v1::nil => Val.mul v1 (Vint n) - | Odiv, v1::v2::nil => Val.divs v1 v2 - | Odivu, v1::v2::nil => Val.divu v1 v2 - | Oand, v1::v2::nil => Val.and v1 v2 - | Oandimm n, v1::nil => Val.and v1 (Vint n) - | Oor, v1::v2::nil => Val.or v1 v2 - | Oorimm n, v1::nil => Val.or v1 (Vint n) - | Oxor, v1::v2::nil => Val.xor v1 v2 - | Oxorimm n, v1::nil => Val.xor v1 (Vint n) - | Onand, v1::v2::nil => Val.notint(Val.and v1 v2) - | Onor, v1::v2::nil => Val.notint(Val.or v1 v2) - | Onxor, v1::v2::nil => Val.notint(Val.xor v1 v2) - | Oshl, v1::v2::nil => Val.shl v1 v2 - | Oshr, v1::v2::nil => Val.shr v1 v2 - | Oshrimm n, v1::nil => Val.shr v1 (Vint n) - | Oshrximm n, v1::nil => Val.shrx v1 (Vint n) - | Oshru, v1::v2::nil => Val.shru v1 v2 - | Orolm amount mask, v1::nil => Val.rolm v1 amount mask - | Onegf, v1::nil => Val.negf v1 - | Oabsf, v1::nil => Val.absf v1 - | Oaddf, v1::v2::nil => Val.addf v1 v2 - | Osubf, v1::v2::nil => Val.subf v1 v2 - | Omulf, v1::v2::nil => Val.mulf v1 v2 - | Odivf, v1::v2::nil => Val.divf v1 v2 - | Omuladdf, v1::v2::v3::nil => Val.addf (Val.mulf v1 v2) v3 - | Omulsubf, v1::v2::v3::nil => Val.subf (Val.mulf v1 v2) v3 - | Osingleoffloat, v1::nil => Val.singleoffloat v1 - | Ointoffloat, v1::nil => Val.intoffloat v1 - | Ointuoffloat, v1::nil => Val.intuoffloat v1 - | Ofloatofint, v1::nil => Val.floatofint v1 - | Ofloatofintu, v1::nil => Val.floatofintu v1 - | Ocmp c, _ => eval_condition_total c vl - | _, _ => Vundef - end. - -Definition eval_addressing_total - (sp: val) (addr: addressing) (vl: list val) : val := - match addr, vl with - | Aindexed n, v1::nil => Val.add v1 (Vint n) - | Aindexed2, v1::v2::nil => Val.add v1 v2 - | Aglobal s ofs, nil => find_symbol_offset s ofs - | Abased s ofs, v1::nil => Val.add (find_symbol_offset s ofs) v1 - | Ainstack ofs, nil => Val.add sp (Vint ofs) - | _, _ => Vundef - end. - -Lemma eval_compare_mismatch_weaken: - forall c b, - eval_compare_mismatch c = Some b -> - Val.cmp_mismatch c = Val.of_bool b. -Proof. - unfold eval_compare_mismatch. intros. destruct c; inv H; auto. -Qed. - -Lemma eval_compare_null_weaken: - forall n c b, - (if Int.eq n Int.zero then eval_compare_mismatch c else None) = Some b -> - (if Int.eq n Int.zero then Val.cmp_mismatch c else Vundef) = Val.of_bool b. -Proof. - intros. destruct (Int.eq n Int.zero). apply eval_compare_mismatch_weaken. auto. - discriminate. -Qed. - -Lemma eval_condition_weaken: - 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. - apply eval_compare_mismatch_weaken; auto. - discriminate. - symmetry. apply Val.notbool_negb_1. - symmetry. apply Val.notbool_negb_1. -Qed. - -Lemma eval_operation_weaken: - forall sp op vl m v, - eval_operation genv sp op vl m = Some v -> - eval_operation_total sp op vl = v. -Proof. - intros. - unfold eval_operation in H; destruct op; FuncInv; - try subst v; try reflexivity; simpl. - unfold find_symbol_offset. - destruct (Genv.find_symbol genv i); try discriminate. - congruence. - unfold offset_sp in H. - destruct sp; try discriminate. simpl. congruence. - unfold eq_block in H. destruct (zeq b b0); congruence. - destruct (Int.eq i0 Int.zero); congruence. - destruct (Int.eq i0 Int.zero); congruence. - destruct (Int.ltu i0 (Int.repr 32)); congruence. - destruct (Int.ltu i0 (Int.repr 32)); congruence. - 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 m); intros; rewrite H0 in H. - replace v with (Val.of_bool b). - eapply eval_condition_weaken; eauto. - destruct b; simpl; congruence. - discriminate. -Qed. - -Lemma eval_addressing_weaken: - forall sp addr vl v, - eval_addressing genv sp addr vl = Some v -> - eval_addressing_total sp addr vl = v. -Proof. - intros. - unfold eval_addressing in H; destruct addr; FuncInv; - try subst v; simpl; try reflexivity. - unfold find_symbol_offset. - destruct (Genv.find_symbol genv i); congruence. - unfold find_symbol_offset. - destruct (Genv.find_symbol genv i); try congruence. - inversion H. reflexivity. - unfold offset_sp in H. destruct sp; simpl; congruence. -Qed. - -Lemma eval_condition_total_is_bool: - forall cond vl, Val.is_bool (eval_condition_total cond vl). -Proof. - intros; destruct cond; - destruct vl; try apply Val.undef_is_bool; - destruct vl; try apply Val.undef_is_bool; - try (destruct vl; try apply Val.undef_is_bool); simpl. - apply Val.cmp_is_bool. - apply Val.cmpu_is_bool. - apply Val.cmp_is_bool. - apply Val.cmpu_is_bool. - apply Val.cmpf_is_bool. - apply Val.notbool_is_bool. - apply Val.notbool_is_bool. - apply Val.notbool_is_bool. -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. - rewrite (Mem.valid_pointer_lessdef _ _ _ _ MEM H1). - rewrite (Mem.valid_pointer_lessdef _ _ _ _ MEM H). simpl. - 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.sign_ext 8 v2); split. auto. apply Val.sign_ext_lessdef; auto. - exists (Val.zero_ext 8 v2); split. auto. apply Val.zero_ext_lessdef; auto. - exists (Val.sign_ext 16 v2); split. auto. apply Val.sign_ext_lessdef; auto. - exists (Val.zero_ext 16 v2); split. auto. apply Val.zero_ext_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. - -(** Transformation of addressing modes with two operands or more - into an equivalent arithmetic operation. This is used in the [Reload] - pass when a store instruction cannot be reloaded directly because - it runs out of temporary registers. *) - -(** For the PowerPC, there is only one binary addressing mode: [Aindexed2]. - The corresponding operation is [Oadd]. *) - -Definition op_for_binary_addressing (addr: addressing) : operation := Oadd. - -Lemma eval_op_for_binary_addressing: - forall (F: Set) (ge: Genv.t F) sp addr args m v, - (length args >= 2)%nat -> - eval_addressing ge sp addr args = Some v -> - eval_operation ge sp (op_for_binary_addressing addr) args m = Some v. -Proof. - intros. - unfold eval_addressing in H0; destruct addr; FuncInv; simpl in H; try omegaContradiction; - simpl; congruence. -Qed. - -Lemma type_op_for_binary_addressing: - forall addr, - (length (type_of_addressing addr) >= 2)%nat -> - type_of_operation (op_for_binary_addressing addr) = (type_of_addressing addr, Tint). -Proof. - intros. destruct addr; simpl in H; reflexivity || omegaContradiction. -Qed. diff --git a/backend/PPC.v b/backend/PPC.v deleted file mode 100644 index e47cba0..0000000 --- a/backend/PPC.v +++ /dev/null @@ -1,843 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** Abstract syntax and semantics for PowerPC assembly language *) - -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 Smallstep. - -(** * Abstract syntax *) - -(** Integer registers, floating-point registers. *) - -Inductive ireg: Set := - | GPR0: ireg | GPR1: ireg | GPR2: ireg | GPR3: ireg - | GPR4: ireg | GPR5: ireg | GPR6: ireg | GPR7: ireg - | GPR8: ireg | GPR9: ireg | GPR10: ireg | GPR11: ireg - | GPR12: ireg | GPR13: ireg | GPR14: ireg | GPR15: ireg - | GPR16: ireg | GPR17: ireg | GPR18: ireg | GPR19: ireg - | GPR20: ireg | GPR21: ireg | GPR22: ireg | GPR23: ireg - | GPR24: ireg | GPR25: ireg | GPR26: ireg | GPR27: ireg - | GPR28: ireg | GPR29: ireg | GPR30: ireg | GPR31: ireg. - -Inductive freg: Set := - | FPR0: freg | FPR1: freg | FPR2: freg | FPR3: freg - | FPR4: freg | FPR5: freg | FPR6: freg | FPR7: freg - | FPR8: freg | FPR9: freg | FPR10: freg | FPR11: freg - | FPR12: freg | FPR13: freg | FPR14: freg | FPR15: freg - | FPR16: freg | FPR17: freg | FPR18: freg | FPR19: freg - | FPR20: freg | FPR21: freg | FPR22: freg | FPR23: freg - | FPR24: freg | FPR25: freg | FPR26: freg | FPR27: freg - | FPR28: freg | FPR29: freg | FPR30: freg | FPR31: freg. - -Lemma ireg_eq: forall (x y: ireg), {x=y} + {x<>y}. -Proof. decide equality. Defined. - -Lemma freg_eq: forall (x y: freg), {x=y} + {x<>y}. -Proof. decide equality. Defined. - -(** Symbolic constants. Immediate operands to an arithmetic instruction - or an indexed memory access can be either integer literals - or the low or high 16 bits of a symbolic reference (the address - of a symbol plus a displacement). These symbolic references are - resolved later by the linker. -*) - -Inductive constant: Set := - | Cint: int -> constant - | Csymbol_low: ident -> int -> constant - | Csymbol_high: ident -> int -> constant. - -(** A note on constants: while immediate operands to PowerPC - instructions must be representable in 16 bits (with - sign extension or left shift by 16 positions for some instructions), - we do not attempt to capture these restrictions in the - abstract syntax nor in the semantics. The assembler will - emit an error if immediate operands exceed the representable - range. Of course, our PPC generator (file [PPCgen]) is - careful to respect this range. *) - -(** Bits in the condition register. We are only interested in the - first 4 bits. *) - -Inductive crbit: Set := - | CRbit_0: crbit - | CRbit_1: crbit - | CRbit_2: crbit - | CRbit_3: crbit. - -(** The instruction set. Most instructions correspond exactly to - actual instructions of the PowerPC processor. See the PowerPC - reference manuals for more details. Some instructions, - described below, are pseudo-instructions: they expand to - canned instruction sequences during the printing of the assembly - code. *) - -Definition label := positive. - -Inductive instruction : Set := - | Padd: ireg -> ireg -> ireg -> instruction (**r integer addition *) - | Paddi: ireg -> ireg -> constant -> instruction (**r add immediate *) - | Paddis: ireg -> ireg -> constant -> instruction (**r add immediate high *) - | Paddze: ireg -> ireg -> instruction (**r add Carry bit *) - | Pallocblock: instruction (**r allocate new heap block *) - | Pallocframe: Z -> Z -> int -> instruction (**r allocate new stack frame *) - | Pand_: ireg -> ireg -> ireg -> instruction (**r bitwise and *) - | Pandc: ireg -> ireg -> ireg -> instruction (**r bitwise and-complement *) - | Pandi_: ireg -> ireg -> constant -> instruction (**r and immediate and set conditions *) - | Pandis_: ireg -> ireg -> constant -> instruction (**r and immediate high and set conditions *) - | Pb: label -> instruction (**r unconditional branch *) - | Pbctr: instruction (**r branch to contents of register CTR *) - | 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 *) - | 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 *) - | Pcmpw: ireg -> ireg -> instruction (**r signed integer comparison *) - | Pcmpwi: ireg -> constant -> instruction (**r same, with immediate argument *) - | Pcror: crbit -> crbit -> crbit -> instruction (**r or between condition bits *) - | Pdivw: ireg -> ireg -> ireg -> instruction (**r signed division *) - | Pdivwu: ireg -> ireg -> ireg -> instruction (**r unsigned division *) - | Peqv: ireg -> ireg -> ireg -> instruction (**r bitwise not-xor *) - | Pextsb: ireg -> ireg -> instruction (**r 8-bit sign extension *) - | Pextsh: ireg -> ireg -> instruction (**r 16-bit sign extension *) - | Pfreeframe: int -> instruction (**r deallocate stack frame and restore previous frame *) - | Pfabs: freg -> freg -> instruction (**r float absolute value *) - | Pfadd: freg -> freg -> freg -> instruction (**r float addition *) - | Pfcmpu: freg -> freg -> instruction (**r float comparison *) - | Pfcti: ireg -> freg -> instruction (**r float-to-signed-int conversion *) - | Pfctiu: ireg -> freg -> instruction (**r float-to-unsigned-int conversion *) - | Pfdiv: freg -> freg -> freg -> instruction (**r float division *) - | Pfmadd: freg -> freg -> freg -> freg -> instruction (**r float multiply-add *) - | Pfmr: freg -> freg -> instruction (**r float move *) - | Pfmsub: freg -> freg -> freg -> freg -> instruction (**r float multiply-sub *) - | Pfmul: freg -> freg -> freg -> instruction (**r float multiply *) - | Pfneg: freg -> freg -> instruction (**r float negation *) - | Pfrsp: freg -> freg -> instruction (**r float round to single precision *) - | Pfsub: freg -> freg -> freg -> instruction (**r float subtraction *) - | Pictf: freg -> ireg -> instruction (**r int-to-float conversion *) - | Piuctf: freg -> ireg -> instruction (**r unsigned int-to-float conversion *) - | Plbz: ireg -> constant -> ireg -> instruction (**r load 8-bit unsigned int *) - | Plbzx: ireg -> ireg -> ireg -> instruction (**r same, with 2 index regs *) - | Plfd: freg -> constant -> ireg -> instruction (**r load 64-bit float *) - | Plfdx: freg -> ireg -> ireg -> instruction (**r same, with 2 index regs *) - | Plfs: freg -> constant -> ireg -> instruction (**r load 32-bit float *) - | Plfsx: freg -> ireg -> ireg -> instruction (**r same, with 2 index regs *) - | Plha: ireg -> constant -> ireg -> instruction (**r load 16-bit signed int *) - | Plhax: ireg -> ireg -> ireg -> instruction (**r same, with 2 index regs *) - | Plhz: ireg -> constant -> ireg -> instruction (**r load 16-bit unsigned int *) - | Plhzx: ireg -> ireg -> ireg -> instruction (**r same, with 2 index regs *) - | Plfi: freg -> float -> instruction (**r load float constant *) - | Plwz: ireg -> constant -> ireg -> instruction (**r load 32-bit int *) - | Plwzx: ireg -> ireg -> ireg -> instruction (**r same, with 2 index regs *) - | Pmfcrbit: ireg -> crbit -> instruction (**r move condition bit to reg *) - | Pmflr: ireg -> instruction (**r move LR to reg *) - | Pmr: ireg -> ireg -> instruction (**r integer move *) - | Pmtctr: ireg -> instruction (**r move ireg to CTR *) - | Pmtlr: ireg -> instruction (**r move ireg to LR *) - | Pmulli: ireg -> ireg -> constant -> instruction (**r integer multiply immediate *) - | Pmullw: ireg -> ireg -> ireg -> instruction (**r integer multiply *) - | Pnand: ireg -> ireg -> ireg -> instruction (**r bitwise not-and *) - | Pnor: ireg -> ireg -> ireg -> instruction (**r bitwise not-or *) - | Por: ireg -> ireg -> ireg -> instruction (**r bitwise or *) - | Porc: ireg -> ireg -> ireg -> instruction (**r bitwise or-complement *) - | Pori: ireg -> ireg -> constant -> instruction (**r or with immediate *) - | Poris: ireg -> ireg -> constant -> instruction (**r or with immediate high *) - | Prlwinm: ireg -> ireg -> int -> int -> instruction (**r rotate and mask *) - | Pslw: ireg -> ireg -> ireg -> instruction (**r shift left *) - | Psraw: ireg -> ireg -> ireg -> instruction (**r shift right signed *) - | Psrawi: ireg -> ireg -> int -> instruction (**r shift right signed immediate *) - | Psrw: ireg -> ireg -> ireg -> instruction (**r shift right unsigned *) - | Pstb: ireg -> constant -> ireg -> instruction (**r store 8-bit int *) - | Pstbx: ireg -> ireg -> ireg -> instruction (**r same, with 2 index regs *) - | Pstfd: freg -> constant -> ireg -> instruction (**r store 64-bit float *) - | Pstfdx: freg -> ireg -> ireg -> instruction (**r same, with 2 index regs *) - | Pstfs: freg -> constant -> ireg -> instruction (**r store 32-bit float *) - | Pstfsx: freg -> ireg -> ireg -> instruction (**r same, with 2 index regs *) - | Psth: ireg -> constant -> ireg -> instruction (**r store 16-bit int *) - | Psthx: ireg -> ireg -> ireg -> instruction (**r same, with 2 index regs *) - | Pstw: ireg -> constant -> ireg -> instruction (**r store 32-bit int *) - | Pstwx: ireg -> ireg -> ireg -> instruction (**r same, with 2 index regs *) - | Psubfc: ireg -> ireg -> ireg -> instruction (**r reversed integer subtraction *) - | Psubfic: ireg -> ireg -> constant -> instruction (**r integer subtraction from immediate *) - | 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 *) - | 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: -<< - addis r2, 0, ha16(lbl) - lfd rdst, lo16(lbl)(r2) - .const_data -lbl: .double floatcst - .text ->> - 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 a signed 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: -<< - fctiwz f13, rsrc - stfdu f13, -8(r1) - lwz rdst, 4(r1) - addi r1, r1, 8 ->> -- [Pfctiu]: convert a float to an unsigned integer. The PowerPC way - to do this is to compare the argument against the floating-point - constant [2^31], subtract [2^31] if bigger, then convert to a signed - integer as above, then add back [2^31] if needed. Expands to: -<< - addis r2, 0, ha16(lbl1) - lfd f13, lo16(lbl1)(r2) - fcmpu cr7, rsrc, f13 - cror 30, 29, 30 - beq cr7, lbl2 - fctiwz f13, rsrc - stfdu f13, -8(r1) - lwz rdst, 4(r1) - b lbl3 -lbl2: fsub f13, rsrc, f13 - fctiwz f13, f13 - stfdu f13, -8(r1) - lwz rdst, 4(r1) - addis rdst, rdst, 0x8000 -lbl3: addi r1, r1, 8 - .const_data -lbl1: .long 0x41e00000, 0x00000000 # 2^31 in double precision - .text ->> -- [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 - of floats cannot express. Expands to: -<< - addis r2, 0, 0x4330 - stwu r2, -8(r1) - addis r2, rsrc, 0x8000 - stw r2, 4(r1) - addis r2, 0, ha16(lbl) - lfd f13, lo16(lbl)(r2) - lfd rdst, 0(r1) - addi r1, r1, 8 - fsub rdst, rdst, f13 - .const_data -lbl: .long 0x43300000, 0x80000000 - .text ->> - (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. -<< - addis r2, 0, 0x4330 - stwu r2, -8(r1) - stw rsrc, 4(r1) - addis r2, 0, ha16(lbl) - lfd f13, lo16(lbl)(r2) - lfd rdst, 0(r1) - addi r1, r1, 8 - fsub rdst, rdst, f13 - .const_data -lbl: .long 0x43300000, 0x00000000 - .text ->> -- [Pallocframe lo hi ofs]: 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 offset [ofs] - in this block, and sets [r1] to a pointer to the bottom of this - block. In the printed PowerPC assembly code, this allocation - is just a store-decrement of register [r1], assuming that [ofs = 0]: -<< - stwu r1, (lo - hi)(r1) ->> - This cannot be expressed in our memory model, which does not reflect - the fact that stack frames are adjacent and allocated/freed - following a stack discipline. -- [Pfreeframe ofs]: in the formal semantics, this pseudo-instruction - reads the word at offset [ofs] in the block pointed by [r1] (the - stack pointer), frees this block, and sets [r1] to the value of the - word at offset [ofs]. In the printed PowerPC assembly code, this - freeing is just a load of register [r1] relative to [r1] itself: -<< - lwz r1, ofs(r1) ->> - 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. -*) - -Definition code := list instruction. -Definition fundef := AST.fundef code. -Definition program := AST.program fundef unit. - -(** * Operational semantics *) - -(** The PowerPC has a great many registers, some general-purpose, some very - specific. We model only the following registers: *) - -Inductive preg: Set := - | IR: ireg -> preg (**r integer registers *) - | FR: freg -> preg (**r float registers *) - | PC: preg (**r program counter *) - | LR: preg (**r link register (return address) *) - | CTR: preg (**r count register, used for some branches *) - | CARRY: preg (**r carry bit of the status register *) - | CR0_0: preg (**r bit 0 of the condition register *) - | CR0_1: preg (**r bit 1 of the condition register *) - | CR0_2: preg (**r bit 2 of the condition register *) - | CR0_3: preg. (**r bit 3 of the condition register *) - -Coercion IR: ireg >-> preg. -Coercion FR: freg >-> preg. - -Lemma preg_eq: forall (x y: preg), {x=y} + {x<>y}. -Proof. decide equality. apply ireg_eq. apply freg_eq. Defined. - -Module PregEq. - Definition t := preg. - Definition eq := preg_eq. -End PregEq. - -Module Pregmap := EMap(PregEq). - -(** The semantics operates over a single mapping from registers - (type [preg]) to values. We maintain (but do not enforce) - the convention that integer registers are mapped to values of - type [Tint], float registers to values of type [Tfloat], - and boolean registers ([CARRY], [CR0_0], etc) to either - [Vzero] or [Vone]. *) - -Definition regset := Pregmap.t val. -Definition genv := Genv.t fundef. - -Notation "a # b" := (a b) (at level 1, only parsing). -Notation "a # b <- c" := (Pregmap.set b c a) (at level 1, b at next level). - -Section RELSEM. - -(** Looking up instructions in a code sequence by position. *) - -Fixpoint find_instr (pos: Z) (c: code) {struct c} : option instruction := - match c with - | nil => None - | i :: il => if zeq pos 0 then Some i else find_instr (pos - 1) il - end. - -(** Position corresponding to a label *) - -Definition is_label (lbl: label) (instr: instruction) : bool := - match instr with - | Plabel 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 = Plabel lbl else instr <> Plabel lbl. -Proof. - intros. destruct instr; simpl; try discriminate. - case (peq lbl l); intro; congruence. -Qed. - -Fixpoint label_pos (lbl: label) (pos: Z) (c: code) {struct c} : option Z := - match c with - | nil => None - | instr :: c' => - if is_label lbl instr then Some (pos + 1) else label_pos lbl (pos + 1) c' - end. - -(** Some PowerPC instructions treat register GPR0 as the integer literal 0 - when that register is used in argument position. *) - -Definition gpr_or_zero (rs: regset) (r: ireg) := - if ireg_eq r GPR0 then Vzero else rs#r. - -Variable ge: genv. - -Definition symbol_offset (id: ident) (ofs: int) : val := - match Genv.find_symbol ge id with - | Some b => Vptr b ofs - | None => Vundef - end. - -(** The four functions below axiomatize how the linker processes - symbolic references [symbol + offset] and splits their - actual values into two 16-bit halves. *) - -Parameter low_half: val -> val. -Parameter high_half: val -> val. - -(** The fundamental property of these operations is that, when applied - to the address of a symbol, their results can be recombined by - addition, rebuilding the original address. *) - -Axiom low_high_half: - forall id ofs, - Val.add (low_half (symbol_offset id ofs)) (high_half (symbol_offset id ofs)) - = symbol_offset id ofs. - -(** The other axioms we take is that the results of - the [low_half] and [high_half] functions are of type [Tint], - i.e. either integers, pointers or undefined values. *) - -Axiom low_half_type: - forall v, Val.has_type (low_half v) Tint. -Axiom high_half_type: - forall v, Val.has_type (high_half v) Tint. - -(** Armed with the [low_half] and [high_half] functions, - we can define the evaluation of a symbolic constant. - Note that for [const_high], integer constants - are shifted left by 16 bits, but not symbol addresses: - we assume (as in the [low_high_half] axioms above) - that the results of [high_half] are already shifted - (their 16 low bits are equal to 0). *) - -Definition const_low (c: constant) := - match c with - | Cint n => Vint n - | Csymbol_low id ofs => low_half (symbol_offset id ofs) - | Csymbol_high id ofs => Vundef - end. - -Definition const_high (c: constant) := - match c with - | Cint n => Vint (Int.shl n (Int.repr 16)) - | Csymbol_low id ofs => Vundef - | Csymbol_high id ofs => high_half (symbol_offset id ofs) - end. - -(** The semantics is purely small-step and defined as a function - from the current state (a register set + a memory state) - to either [OK rs' m'] where [rs'] and [m'] are the updated register - set and memory state after execution of the instruction at [rs#PC], - or [Error] if the processor is stuck. *) - -Inductive outcome: Set := - | OK: regset -> mem -> outcome - | Error: outcome. - -(** Manipulations over the [PC] register: continuing with the next - instruction ([nextinstr]) or branching to a label ([goto_label]). *) - -Definition nextinstr (rs: regset) := - rs#PC <- (Val.add rs#PC Vone). - -Definition goto_label (c: code) (lbl: label) (rs: regset) (m: mem) := - match label_pos lbl 0 c with - | None => Error - | Some pos => - match rs#PC with - | Vptr b ofs => OK (rs#PC <- (Vptr b (Int.repr pos))) m - | _ => Error - end - end. - -(** Auxiliaries for memory accesses, in two forms: one operand - (plus constant offset) or two operands. *) - -Definition load1 (chunk: memory_chunk) (rd: preg) - (cst: constant) (r1: ireg) (rs: regset) (m: mem) := - match Mem.loadv chunk m (Val.add (gpr_or_zero rs r1) (const_low cst)) with - | None => Error - | Some v => OK (nextinstr (rs#rd <- v)) m - end. - -Definition load2 (chunk: memory_chunk) (rd: preg) (r1 r2: ireg) - (rs: regset) (m: mem) := - match Mem.loadv chunk m (Val.add rs#r1 rs#r2) with - | None => Error - | Some v => OK (nextinstr (rs#rd <- v)) m - end. - -Definition store1 (chunk: memory_chunk) (r: preg) - (cst: constant) (r1: ireg) (rs: regset) (m: mem) := - match Mem.storev chunk m (Val.add (gpr_or_zero rs r1) (const_low cst)) (rs#r) with - | None => Error - | Some m' => OK (nextinstr rs) m' - end. - -Definition store2 (chunk: memory_chunk) (r: preg) (r1 r2: ireg) - (rs: regset) (m: mem) := - match Mem.storev chunk m (Val.add rs#r1 rs#r2) (rs#r) with - | None => Error - | Some m' => OK (nextinstr rs) m' - end. - -(** Operations over condition bits. *) - -Definition reg_of_crbit (bit: crbit) := - match bit with - | CRbit_0 => CR0_0 - | CRbit_1 => CR0_1 - | CRbit_2 => CR0_2 - | CRbit_3 => CR0_3 - end. - -Definition compare_sint (rs: regset) (v1 v2: val) := - rs#CR0_0 <- (Val.cmp Clt v1 v2) - #CR0_1 <- (Val.cmp Cgt v1 v2) - #CR0_2 <- (Val.cmp Ceq v1 v2) - #CR0_3 <- Vundef. - -Definition compare_uint (rs: regset) (v1 v2: val) := - rs#CR0_0 <- (Val.cmpu Clt v1 v2) - #CR0_1 <- (Val.cmpu Cgt v1 v2) - #CR0_2 <- (Val.cmpu Ceq v1 v2) - #CR0_3 <- Vundef. - -Definition compare_float (rs: regset) (v1 v2: val) := - rs#CR0_0 <- (Val.cmpf Clt v1 v2) - #CR0_1 <- (Val.cmpf Cgt v1 v2) - #CR0_2 <- (Val.cmpf Ceq v1 v2) - #CR0_3 <- Vundef. - -Definition val_cond_reg (rs: regset) := - Val.or (Val.shl rs#CR0_0 (Vint (Int.repr 31))) - (Val.or (Val.shl rs#CR0_1 (Vint (Int.repr 30))) - (Val.or (Val.shl rs#CR0_2 (Vint (Int.repr 29))) - (Val.shl rs#CR0_3 (Vint (Int.repr 28))))). - -(** Execution of a single instruction [i] in initial state - [rs] and [m]. Return updated state. For instructions - that correspond to actual PowerPC instructions, the cases are - straightforward transliterations of the informal descriptions - given in the PowerPC reference manuals. For pseudo-instructions, - refer to the informal descriptions given above. Note that - we set to [Vundef] the registers used as temporaries by the - expansions of the pseudo-instructions, so that the PPC code - we generate cannot use those registers to hold values that - must survive the execution of the pseudo-instruction. -*) - -Definition exec_instr (c: code) (i: instruction) (rs: regset) (m: mem) : outcome := - match i with - | Padd rd r1 r2 => - OK (nextinstr (rs#rd <- (Val.add rs#r1 rs#r2))) m - | Paddi rd r1 cst => - OK (nextinstr (rs#rd <- (Val.add (gpr_or_zero rs r1) (const_low cst)))) m - | Paddis rd r1 cst => - OK (nextinstr (rs#rd <- (Val.add (gpr_or_zero rs r1) (const_high cst)))) m - | Paddze rd r1 => - OK (nextinstr (rs#rd <- (Val.add rs#r1 rs#CARRY))) m - | Pallocblock => - match rs#GPR3 with - | Vint n => - let (m', b) := Mem.alloc m 0 (Int.signed n) in - OK (nextinstr (rs#GPR3 <- (Vptr b Int.zero) - #LR <- (Val.add rs#PC Vone))) m' - | _ => Error - end - | Pallocframe lo hi ofs => - let (m1, stk) := Mem.alloc m lo hi in - let sp := Vptr stk (Int.repr lo) in - match Mem.storev Mint32 m1 (Val.add sp (Vint ofs)) rs#GPR1 with - | None => Error - | Some m2 => OK (nextinstr (rs#GPR1 <- sp #GPR12 <- Vundef)) m2 - end - | Pand_ rd r1 r2 => - let v := Val.and rs#r1 rs#r2 in - OK (nextinstr (compare_sint (rs#rd <- v) v Vzero)) m - | Pandc rd r1 r2 => - OK (nextinstr (rs#rd <- (Val.and rs#r1 (Val.notint rs#r2)))) m - | Pandi_ rd r1 cst => - let v := Val.and rs#r1 (const_low cst) in - OK (nextinstr (compare_sint (rs#rd <- v) v Vzero)) m - | Pandis_ rd r1 cst => - let v := Val.and rs#r1 (const_high cst) in - OK (nextinstr (compare_sint (rs#rd <- v) v Vzero)) m - | Pb lbl => - goto_label c lbl rs m - | Pbctr => - OK (rs#PC <- (rs#CTR)) m - | Pbctrl => - OK (rs#LR <- (Val.add rs#PC Vone) #PC <- (rs#CTR)) m - | Pbf bit lbl => - match rs#(reg_of_crbit bit) with - | Vint n => if Int.eq n Int.zero then goto_label c lbl rs m else OK (nextinstr rs) m - | _ => Error - 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 => - match rs#(reg_of_crbit bit) with - | Vint n => if Int.eq n Int.zero then OK (nextinstr rs) m else goto_label c lbl rs m - | _ => Error - end - | Pcmplw r1 r2 => - OK (nextinstr (compare_uint rs rs#r1 rs#r2)) m - | Pcmplwi r1 cst => - OK (nextinstr (compare_uint rs rs#r1 (const_low cst))) m - | Pcmpw r1 r2 => - OK (nextinstr (compare_sint rs rs#r1 rs#r2)) m - | Pcmpwi r1 cst => - OK (nextinstr (compare_sint rs rs#r1 (const_low cst))) m - | Pcror bd b1 b2 => - OK (nextinstr (rs#(reg_of_crbit bd) <- (Val.or rs#(reg_of_crbit b1) rs#(reg_of_crbit b2)))) m - | Pdivw rd r1 r2 => - OK (nextinstr (rs#rd <- (Val.divs rs#r1 rs#r2))) m - | Pdivwu rd r1 r2 => - OK (nextinstr (rs#rd <- (Val.divu rs#r1 rs#r2))) m - | Peqv rd r1 r2 => - OK (nextinstr (rs#rd <- (Val.notint (Val.xor rs#r1 rs#r2)))) m - | Pextsb rd r1 => - OK (nextinstr (rs#rd <- (Val.sign_ext 8 rs#r1))) m - | Pextsh rd r1 => - OK (nextinstr (rs#rd <- (Val.sign_ext 16 rs#r1))) m - | Pfreeframe ofs => - match Mem.loadv Mint32 m (Val.add rs#GPR1 (Vint ofs)) with - | None => Error - | Some v => - match rs#GPR1 with - | Vptr stk ofs => OK (nextinstr (rs#GPR1 <- v)) (Mem.free m stk) - | _ => Error - end - end - | Pfabs rd r1 => - OK (nextinstr (rs#rd <- (Val.absf rs#r1))) m - | Pfadd rd r1 r2 => - OK (nextinstr (rs#rd <- (Val.addf rs#r1 rs#r2))) m - | Pfcmpu r1 r2 => - OK (nextinstr (compare_float rs rs#r1 rs#r2)) m - | Pfcti rd r1 => - OK (nextinstr (rs#rd <- (Val.intoffloat rs#r1) #FPR13 <- Vundef)) m - | Pfctiu rd r1 => - OK (nextinstr (rs#rd <- (Val.intuoffloat rs#r1) #FPR13 <- Vundef)) m - | Pfdiv rd r1 r2 => - OK (nextinstr (rs#rd <- (Val.divf rs#r1 rs#r2))) m - | Pfmadd rd r1 r2 r3 => - OK (nextinstr (rs#rd <- (Val.addf (Val.mulf rs#r1 rs#r2) rs#r3))) m - | Pfmr rd r1 => - OK (nextinstr (rs#rd <- (rs#r1))) m - | Pfmsub rd r1 r2 r3 => - OK (nextinstr (rs#rd <- (Val.subf (Val.mulf rs#r1 rs#r2) rs#r3))) m - | Pfmul rd r1 r2 => - OK (nextinstr (rs#rd <- (Val.mulf rs#r1 rs#r2))) m - | Pfneg rd r1 => - OK (nextinstr (rs#rd <- (Val.negf rs#r1))) m - | Pfrsp rd r1 => - OK (nextinstr (rs#rd <- (Val.singleoffloat rs#r1))) m - | Pfsub rd r1 r2 => - OK (nextinstr (rs#rd <- (Val.subf rs#r1 rs#r2))) m - | Pictf rd r1 => - OK (nextinstr (rs#rd <- (Val.floatofint rs#r1) #GPR12 <- Vundef #FPR13 <- Vundef)) m - | Piuctf rd r1 => - OK (nextinstr (rs#rd <- (Val.floatofintu rs#r1) #GPR12 <- Vundef #FPR13 <- Vundef)) m - | Plbz rd cst r1 => - load1 Mint8unsigned rd cst r1 rs m - | Plbzx rd r1 r2 => - load2 Mint8unsigned rd r1 r2 rs m - | Plfd rd cst r1 => - load1 Mfloat64 rd cst r1 rs m - | Plfdx rd r1 r2 => - load2 Mfloat64 rd r1 r2 rs m - | Plfs rd cst r1 => - load1 Mfloat32 rd cst r1 rs m - | Plfsx rd r1 r2 => - load2 Mfloat32 rd r1 r2 rs m - | Plha rd cst r1 => - load1 Mint16signed rd cst r1 rs m - | Plhax rd r1 r2 => - load2 Mint16signed rd r1 r2 rs m - | Plhz rd cst r1 => - load1 Mint16unsigned rd cst r1 rs m - | Plhzx rd r1 r2 => - load2 Mint16unsigned rd r1 r2 rs m - | Plfi rd f => - OK (nextinstr (rs#rd <- (Vfloat f) #GPR12 <- Vundef)) m - | Plwz rd cst r1 => - load1 Mint32 rd cst r1 rs m - | Plwzx rd r1 r2 => - load2 Mint32 rd r1 r2 rs m - | Pmfcrbit rd bit => - OK (nextinstr (rs#rd <- (rs#(reg_of_crbit bit)))) m - | Pmflr rd => - OK (nextinstr (rs#rd <- (rs#LR))) m - | Pmr rd r1 => - OK (nextinstr (rs#rd <- (rs#r1))) m - | Pmtctr r1 => - OK (nextinstr (rs#CTR <- (rs#r1))) m - | Pmtlr r1 => - OK (nextinstr (rs#LR <- (rs#r1))) m - | Pmulli rd r1 cst => - OK (nextinstr (rs#rd <- (Val.mul rs#r1 (const_low cst)))) m - | Pmullw rd r1 r2 => - OK (nextinstr (rs#rd <- (Val.mul rs#r1 rs#r2))) m - | Pnand rd r1 r2 => - OK (nextinstr (rs#rd <- (Val.notint (Val.and rs#r1 rs#r2)))) m - | Pnor rd r1 r2 => - OK (nextinstr (rs#rd <- (Val.notint (Val.or rs#r1 rs#r2)))) m - | Por rd r1 r2 => - OK (nextinstr (rs#rd <- (Val.or rs#r1 rs#r2))) m - | Porc rd r1 r2 => - OK (nextinstr (rs#rd <- (Val.or rs#r1 (Val.notint rs#r2)))) m - | Pori rd r1 cst => - OK (nextinstr (rs#rd <- (Val.or rs#r1 (const_low cst)))) m - | Poris rd r1 cst => - OK (nextinstr (rs#rd <- (Val.or rs#r1 (const_high cst)))) m - | Prlwinm rd r1 amount mask => - OK (nextinstr (rs#rd <- (Val.rolm rs#r1 amount mask))) m - | Pslw rd r1 r2 => - OK (nextinstr (rs#rd <- (Val.shl rs#r1 rs#r2))) m - | Psraw rd r1 r2 => - OK (nextinstr (rs#rd <- (Val.shr rs#r1 rs#r2) #CARRY <- (Val.shr_carry rs#r1 rs#r2))) m - | Psrawi rd r1 n => - OK (nextinstr (rs#rd <- (Val.shr rs#r1 (Vint n)) #CARRY <- (Val.shr_carry rs#r1 (Vint n)))) m - | Psrw rd r1 r2 => - OK (nextinstr (rs#rd <- (Val.shru rs#r1 rs#r2))) m - | Pstb rd cst r1 => - store1 Mint8unsigned rd cst r1 rs m - | Pstbx rd r1 r2 => - store2 Mint8unsigned rd r1 r2 rs m - | Pstfd rd cst r1 => - store1 Mfloat64 rd cst r1 rs m - | Pstfdx rd r1 r2 => - store2 Mfloat64 rd r1 r2 rs m - | Pstfs rd cst r1 => - store1 Mfloat32 rd cst r1 rs m - | Pstfsx rd r1 r2 => - store2 Mfloat32 rd r1 r2 rs m - | Psth rd cst r1 => - store1 Mint16unsigned rd cst r1 rs m - | Psthx rd r1 r2 => - store2 Mint16unsigned rd r1 r2 rs m - | Pstw rd cst r1 => - store1 Mint32 rd cst r1 rs m - | Pstwx rd r1 r2 => - store2 Mint32 rd r1 r2 rs m - | Psubfc rd r1 r2 => - OK (nextinstr (rs#rd <- (Val.sub rs#r2 rs#r1) #CARRY <- Vundef)) m - | Psubfic rd r1 cst => - OK (nextinstr (rs#rd <- (Val.sub (const_low cst) rs#r1) #CARRY <- Vundef)) m - | Pxor rd r1 r2 => - OK (nextinstr (rs#rd <- (Val.xor rs#r1 rs#r2))) m - | Pxori rd r1 cst => - 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 - | Plabel lbl => - OK (nextinstr rs) m - end. - -(** Calling conventions for external functions. These are compatible with - the calling conventions in module [Conventions], except that - we use PPC registers instead of locations. *) - -Inductive extcall_args (rs: regset) (m: mem): - list typ -> list ireg -> list freg -> Z -> list val -> Prop := - | extcall_args_nil: forall irl frl ofs, - 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 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 -> - extcall_args rs m tyl nil frl (ofs + 4) vl -> - 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 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 irl nil (ofs + 8) vl -> - extcall_args rs m (Tfloat :: tyl) irl nil ofs (v1 :: vl). - -Definition extcall_arguments - (rs: regset) (m: mem) (sg: signature) (args: list val) : Prop := - extcall_args rs m - sg.(sig_args) - (GPR3 :: GPR4 :: GPR5 :: GPR6 :: GPR7 :: GPR8 :: GPR9 :: GPR10 :: nil) - (FPR1 :: FPR2 :: FPR3 :: FPR4 :: FPR5 :: FPR6 :: FPR7 :: FPR8 :: FPR9 :: FPR10 :: nil) - 56 args. - -Definition loc_external_result (s: signature) : preg := - match s.(sig_res) with - | None => GPR3 - | Some Tint => GPR3 - | Some Tfloat => FPR1 - end. - -(** Execution of the instruction at [rs#PC]. *) - -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' -> - 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 -> - Genv.find_funct_ptr ge b = Some (External ef) -> - event_match ef args t res -> - extcall_arguments rs m ef.(ef_sig) args -> - rs' = (rs#(loc_external_result ef.(ef_sig)) <- res - #PC <- (rs LR)) -> - step (State rs m) t (State rs' m). - -End RELSEM. - -(** Execution of whole programs. *) - -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 deleted file mode 100644 index faedcb1..0000000 --- a/backend/PPCgen.v +++ /dev/null @@ -1,548 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** Translation from Mach to PPC. *) - -Require Import Coqlib. -Require Import Maps. -Require Import Errors. -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. - -(** Translation of the LTL/Linear/Mach view of machine registers - to the PPC view. PPC has two different types for registers - (integer and float) while LTL et al have only one. The - [ireg_of] and [freg_of] are therefore partial in principle. - To keep things simpler, we make them return nonsensical - results when applied to a LTL register of the wrong type. - The proof in [PPCgenproof] will show that this never happens. - - Note that no LTL register maps to [GPR12] nor [FPR13]. - These two registers are reserved as temporaries, to be used - by the generated PPC code. *) - -Definition ireg_of (r: mreg) : ireg := - match r with - | R3 => GPR3 | R4 => GPR4 | R5 => GPR5 | R6 => GPR6 - | R7 => GPR7 | R8 => GPR8 | R9 => GPR9 | R10 => GPR10 - | R13 => GPR13 | R14 => GPR14 | R15 => GPR15 | R16 => GPR16 - | R17 => GPR17 | R18 => GPR18 | R19 => GPR19 | R20 => GPR20 - | R21 => GPR21 | R22 => GPR22 | R23 => GPR23 | R24 => GPR24 - | R25 => GPR25 | R26 => GPR26 | R27 => GPR27 | R28 => GPR28 - | R29 => GPR29 | R30 => GPR30 | R31 => GPR31 - | IT1 => GPR11 | IT2 => GPR0 - | _ => GPR0 (* should not happen *) - end. - -Definition freg_of (r: mreg) : freg := - match r with - | F1 => FPR1 | F2 => FPR2 | F3 => FPR3 | F4 => FPR4 - | F5 => FPR5 | F6 => FPR6 | F7 => FPR7 | F8 => FPR8 - | F9 => FPR9 | F10 => FPR10 | F14 => FPR14 | F15 => FPR15 - | F16 => FPR16 | F17 => FPR17 | F18 => FPR18 | F19 => FPR19 - | F20 => FPR20 | F21 => FPR21 | F22 => FPR22 | F23 => FPR23 - | F24 => FPR24 | F25 => FPR25 | F26 => FPR26 | F27 => FPR27 - | F28 => FPR28 | F29 => FPR29 | F30 => FPR30 | F31 => FPR31 - | FT1 => FPR0 | FT2 => FPR11 | FT3 => FPR12 - | _ => FPR0 (* should not happen *) - end. - -(** Decomposition of integer constants. As noted in file [PPC], - immediate arguments to PowerPC instructions must fit into 16 bits, - and are interpreted after zero extension, sign extension, or - left shift by 16 bits, depending on the instruction. Integer - constants that do not fit must be synthesized using two - processor instructions. The following functions decompose - arbitrary 32-bit integers into two 16-bit halves (high and low - halves). They satisfy the following properties: -- [low_u n] is an unsigned 16-bit integer; -- [low_s n] is a signed 16-bit integer; -- [(high_u n) << 16 | low_u n] equals [n]; -- [(high_s n) << 16 + low_s n] equals [n]. -*) - -Definition low_u (n: int) := Int.and n (Int.repr 65535). -Definition high_u (n: int) := Int.shru n (Int.repr 16). -Definition low_s (n: int) := Int.sign_ext 16 n. -Definition high_s (n: int) := Int.shru (Int.sub n (low_s n)) (Int.repr 16). - -(** Smart constructors for arithmetic operations involving - a 32-bit integer constant. Depending on whether the - constant fits in 16 bits or not, one or several instructions - are generated as required to perform the operation - and prepended to the given instruction sequence [k]. *) - -Definition loadimm (r: ireg) (n: int) (k: code) := - if Int.eq (high_s n) Int.zero then - Paddi r GPR0 (Cint n) :: k - else if Int.eq (low_s n) Int.zero then - Paddis r GPR0 (Cint (high_s n)) :: k - else - Paddis r GPR0 (Cint (high_u n)) :: - Pori r r (Cint (low_u n)) :: k. - -Definition addimm_1 (r1 r2: ireg) (n: int) (k: code) := - if Int.eq (high_s n) Int.zero then - Paddi r1 r2 (Cint n) :: k - else if Int.eq (low_s n) Int.zero then - Paddis r1 r2 (Cint (high_s n)) :: k - else - Paddis r1 r2 (Cint (high_s n)) :: - Paddi r1 r1 (Cint (low_s n)) :: k. - -Definition addimm_2 (r1 r2: ireg) (n: int) (k: code) := - loadimm GPR12 n (Padd r1 r2 GPR12 :: k). - -Definition addimm (r1 r2: ireg) (n: int) (k: code) := - if ireg_eq r1 GPR0 then - addimm_2 r1 r2 n k - else if ireg_eq r2 GPR0 then - addimm_2 r1 r2 n k - else - addimm_1 r1 r2 n k. - -Definition andimm (r1 r2: ireg) (n: int) (k: code) := - if Int.eq (high_u n) Int.zero then - Pandi_ r1 r2 (Cint n) :: k - else if Int.eq (low_u n) Int.zero then - Pandis_ r1 r2 (Cint (high_u n)) :: k - else - loadimm GPR12 n (Pand_ r1 r2 GPR12 :: k). - -Definition orimm (r1 r2: ireg) (n: int) (k: code) := - if Int.eq (high_u n) Int.zero then - Pori r1 r2 (Cint n) :: k - else if Int.eq (low_u n) Int.zero then - Poris r1 r2 (Cint (high_u n)) :: k - else - Poris r1 r2 (Cint (high_u n)) :: - Pori r1 r1 (Cint (low_u n)) :: k. - -Definition xorimm (r1 r2: ireg) (n: int) (k: code) := - if Int.eq (high_u n) Int.zero then - Pxori r1 r2 (Cint n) :: k - else if Int.eq (low_u n) Int.zero then - Pxoris r1 r2 (Cint (high_u n)) :: k - else - Pxoris r1 r2 (Cint (high_u n)) :: - Pxori r1 r1 (Cint (low_u n)) :: k. - -(** Smart constructors for indexed loads and stores, - where the address is the contents of a register plus - an integer literal. *) - -Definition loadind_aux (base: ireg) (ofs: int) (ty: typ) (dst: mreg) := - match ty with - | Tint => Plwz (ireg_of dst) (Cint ofs) base - | Tfloat => Plfd (freg_of dst) (Cint ofs) base - end. - -Definition loadind (base: ireg) (ofs: int) (ty: typ) (dst: mreg) (k: code) := - if Int.eq (high_s ofs) Int.zero then - loadind_aux base ofs ty dst :: k - else - Paddis GPR12 base (Cint (high_s ofs)) :: - loadind_aux GPR12 (low_s ofs) ty dst :: k. - -Definition storeind_aux (src: mreg) (base: ireg) (ofs: int) (ty: typ) := - match ty with - | Tint => Pstw (ireg_of src) (Cint ofs) base - | Tfloat => Pstfd (freg_of src) (Cint ofs) base - end. - -Definition storeind (src: mreg) (base: ireg) (ofs: int) (ty: typ) (k: code) := - if Int.eq (high_s ofs) Int.zero then - storeind_aux src base ofs ty :: k - else - Paddis GPR12 base (Cint (high_s ofs)) :: - storeind_aux src GPR12 (low_s ofs) ty :: k. - -(** Constructor for a floating-point comparison. The PowerPC has - a single [fcmpu] instruction to compare floats, which sets - bits 0, 1 and 2 of the condition register to reflect ``less'', - ``greater'' and ``equal'' conditions, respectively. - The ``less or equal'' and ``greater or equal'' conditions must be - synthesized by a [cror] instruction that computes the logical ``or'' - of the corresponding two conditions. *) - -Definition floatcomp (cmp: comparison) (r1 r2: freg) (k: code) := - Pfcmpu r1 r2 :: - match cmp with - | Cle => Pcror CRbit_3 CRbit_2 CRbit_0 :: k - | Cge => Pcror CRbit_3 CRbit_2 CRbit_1 :: k - | _ => k - end. - -(** Translation of a condition. Prepends to [k] the instructions - that evaluate the condition and leave its boolean result in one of - the bits of the condition register. The bit in question is - determined by the [crbit_for_cond] function. *) - -Definition transl_cond - (cond: condition) (args: list mreg) (k: code) := - match cond, args with - | Ccomp c, a1 :: a2 :: nil => - Pcmpw (ireg_of a1) (ireg_of a2) :: k - | Ccompu c, a1 :: a2 :: nil => - Pcmplw (ireg_of a1) (ireg_of a2) :: k - | Ccompimm c n, a1 :: nil => - if Int.eq (high_s n) Int.zero then - Pcmpwi (ireg_of a1) (Cint n) :: k - else - loadimm GPR12 n (Pcmpw (ireg_of a1) GPR12 :: k) - | Ccompuimm c n, a1 :: nil => - if Int.eq (high_u n) Int.zero then - Pcmplwi (ireg_of a1) (Cint n) :: k - else - loadimm GPR12 n (Pcmplw (ireg_of a1) GPR12 :: k) - | Ccompf cmp, a1 :: a2 :: nil => - floatcomp cmp (freg_of a1) (freg_of a2) k - | Cnotcompf cmp, a1 :: a2 :: nil => - floatcomp cmp (freg_of a1) (freg_of a2) k - | Cmaskzero n, a1 :: nil => - andimm GPR12 (ireg_of a1) n k - | Cmasknotzero n, a1 :: nil => - andimm GPR12 (ireg_of a1) n k - | _, _ => - k (**r never happens for well-typed code *) - end. - -(* CRbit_0 = Less - CRbit_1 = Greater - CRbit_2 = Equal - CRbit_3 = Other *) - -Definition crbit_for_icmp (cmp: comparison) := - match cmp with - | Ceq => (CRbit_2, true) - | Cne => (CRbit_2, false) - | Clt => (CRbit_0, true) - | Cle => (CRbit_1, false) - | Cgt => (CRbit_1, true) - | Cge => (CRbit_0, false) - end. - -Definition crbit_for_fcmp (cmp: comparison) := - match cmp with - | Ceq => (CRbit_2, true) - | Cne => (CRbit_2, false) - | Clt => (CRbit_0, true) - | Cle => (CRbit_3, true) - | Cgt => (CRbit_1, true) - | Cge => (CRbit_3, true) - end. - -Definition crbit_for_cond (cond: condition) := - match cond with - | Ccomp cmp => crbit_for_icmp cmp - | Ccompu cmp => crbit_for_icmp cmp - | Ccompimm cmp n => crbit_for_icmp cmp - | Ccompuimm cmp n => crbit_for_icmp cmp - | Ccompf cmp => crbit_for_fcmp cmp - | Cnotcompf cmp => let p := crbit_for_fcmp cmp in (fst p, negb (snd p)) - | Cmaskzero n => (CRbit_2, true) - | Cmasknotzero n => (CRbit_2, false) - end. - -(** Translation of the arithmetic operation [r <- op(args)]. - The corresponding instructions are prepended to [k]. *) - -Definition transl_op - (op: operation) (args: list mreg) (r: mreg) (k: code) := - match op, args with - | Omove, a1 :: nil => - match mreg_type a1 with - | Tint => Pmr (ireg_of r) (ireg_of a1) :: k - | Tfloat => Pfmr (freg_of r) (freg_of a1) :: k - end - | Ointconst n, nil => - loadimm (ireg_of r) n k - | Ofloatconst f, nil => - Plfi (freg_of r) f :: k - | Oaddrsymbol s ofs, nil => - Paddis GPR12 GPR0 (Csymbol_high s ofs) :: - Paddi (ireg_of r) GPR12 (Csymbol_low s ofs) :: k - | Oaddrstack n, nil => - addimm (ireg_of r) GPR1 n k - | Ocast8signed, a1 :: nil => - Pextsb (ireg_of r) (ireg_of a1) :: k - | Ocast8unsigned, a1 :: nil => - Prlwinm (ireg_of r) (ireg_of a1) Int.zero (Int.repr 255) :: k - | Ocast16signed, a1 :: nil => - Pextsh (ireg_of r) (ireg_of a1) :: k - | Ocast16unsigned, a1 :: nil => - Prlwinm (ireg_of r) (ireg_of a1) Int.zero (Int.repr 65535) :: k - | Oadd, a1 :: a2 :: nil => - Padd (ireg_of r) (ireg_of a1) (ireg_of a2) :: k - | Oaddimm n, a1 :: nil => - addimm (ireg_of r) (ireg_of a1) n k - | Osub, a1 :: a2 :: nil => - Psubfc (ireg_of r) (ireg_of a2) (ireg_of a1) :: k - | Osubimm n, a1 :: nil => - if Int.eq (high_s n) Int.zero then - Psubfic (ireg_of r) (ireg_of a1) (Cint n) :: k - else - loadimm GPR12 n (Psubfc (ireg_of r) (ireg_of a1) GPR12 :: k) - | Omul, a1 :: a2 :: nil => - Pmullw (ireg_of r) (ireg_of a1) (ireg_of a2) :: k - | Omulimm n, a1 :: nil => - if Int.eq (high_s n) Int.zero then - Pmulli (ireg_of r) (ireg_of a1) (Cint n) :: k - else - loadimm GPR12 n (Pmullw (ireg_of r) (ireg_of a1) GPR12 :: k) - | Odiv, a1 :: a2 :: nil => - Pdivw (ireg_of r) (ireg_of a1) (ireg_of a2) :: k - | Odivu, a1 :: a2 :: nil => - Pdivwu (ireg_of r) (ireg_of a1) (ireg_of a2) :: k - | Oand, a1 :: a2 :: nil => - Pand_ (ireg_of r) (ireg_of a1) (ireg_of a2) :: k - | Oandimm n, a1 :: nil => - andimm (ireg_of r) (ireg_of a1) n k - | Oor, a1 :: a2 :: nil => - Por (ireg_of r) (ireg_of a1) (ireg_of a2) :: k - | Oorimm n, a1 :: nil => - orimm (ireg_of r) (ireg_of a1) n k - | Oxor, a1 :: a2 :: nil => - Pxor (ireg_of r) (ireg_of a1) (ireg_of a2) :: k - | Oxorimm n, a1 :: nil => - xorimm (ireg_of r) (ireg_of a1) n k - | Onand, a1 :: a2 :: nil => - Pnand (ireg_of r) (ireg_of a1) (ireg_of a2) :: k - | Onor, a1 :: a2 :: nil => - Pnor (ireg_of r) (ireg_of a1) (ireg_of a2) :: k - | Onxor, a1 :: a2 :: nil => - Peqv (ireg_of r) (ireg_of a1) (ireg_of a2) :: k - | Oshl, a1 :: a2 :: nil => - Pslw (ireg_of r) (ireg_of a1) (ireg_of a2) :: k - | Oshr, a1 :: a2 :: nil => - Psraw (ireg_of r) (ireg_of a1) (ireg_of a2) :: k - | Oshrimm n, a1 :: nil => - Psrawi (ireg_of r) (ireg_of a1) n :: k - | Oshrximm n, a1 :: nil => - Psrawi (ireg_of r) (ireg_of a1) n :: - Paddze (ireg_of r) (ireg_of r) :: k - | Oshru, a1 :: a2 :: nil => - Psrw (ireg_of r) (ireg_of a1) (ireg_of a2) :: k - | Orolm amount mask, a1 :: nil => - Prlwinm (ireg_of r) (ireg_of a1) amount mask :: k - | Onegf, a1 :: nil => - Pfneg (freg_of r) (freg_of a1) :: k - | Oabsf, a1 :: nil => - Pfabs (freg_of r) (freg_of a1) :: k - | Oaddf, a1 :: a2 :: nil => - Pfadd (freg_of r) (freg_of a1) (freg_of a2) :: k - | Osubf, a1 :: a2 :: nil => - Pfsub (freg_of r) (freg_of a1) (freg_of a2) :: k - | Omulf, a1 :: a2 :: nil => - Pfmul (freg_of r) (freg_of a1) (freg_of a2) :: k - | Odivf, a1 :: a2 :: nil => - Pfdiv (freg_of r) (freg_of a1) (freg_of a2) :: k - | Omuladdf, a1 :: a2 :: a3 :: nil => - Pfmadd (freg_of r) (freg_of a1) (freg_of a2) (freg_of a3) :: k - | Omulsubf, a1 :: a2 :: a3 :: nil => - Pfmsub (freg_of r) (freg_of a1) (freg_of a2) (freg_of a3) :: k - | Osingleoffloat, a1 :: nil => - Pfrsp (freg_of r) (freg_of a1) :: k - | Ointoffloat, a1 :: nil => - Pfcti (ireg_of r) (freg_of a1) :: k - | Ointuoffloat, a1 :: nil => - Pfctiu (ireg_of r) (freg_of a1) :: k - | Ofloatofint, a1 :: nil => - Pictf (freg_of r) (ireg_of a1) :: k - | Ofloatofintu, a1 :: nil => - Piuctf (freg_of r) (ireg_of a1) :: k - | Ocmp cmp, _ => - let p := crbit_for_cond cmp in - transl_cond cmp args - (Pmfcrbit (ireg_of r) (fst p) :: - if snd p - then k - else Pxori (ireg_of r) (ireg_of r) (Cint Int.one) :: k) - | _, _ => - k (**r never happens for well-typed code *) - end. - -(** Common code to translate [Mload] and [Mstore] instructions. *) - -Definition transl_load_store - (mk1: constant -> ireg -> instruction) - (mk2: ireg -> ireg -> instruction) - (addr: addressing) (args: list mreg) (k: code) := - match addr, args with - | Aindexed ofs, a1 :: nil => - if ireg_eq (ireg_of a1) GPR0 then - Pmr GPR12 (ireg_of a1) :: - Paddis GPR12 GPR12 (Cint (high_s ofs)) :: - mk1 (Cint (low_s ofs)) GPR12 :: k - else if Int.eq (high_s ofs) Int.zero then - mk1 (Cint ofs) (ireg_of a1) :: k - else - Paddis GPR12 (ireg_of a1) (Cint (high_s ofs)) :: - mk1 (Cint (low_s ofs)) GPR12 :: k - | Aindexed2, a1 :: a2 :: nil => - mk2 (ireg_of a1) (ireg_of a2) :: k - | Aglobal symb ofs, nil => - Paddis GPR12 GPR0 (Csymbol_high symb ofs) :: - mk1 (Csymbol_low symb ofs) GPR12 :: k - | Abased symb ofs, a1 :: nil => - if ireg_eq (ireg_of a1) GPR0 then - Pmr GPR12 (ireg_of a1) :: - Paddis GPR12 GPR12 (Csymbol_high symb ofs) :: - mk1 (Csymbol_low symb ofs) GPR12 :: k - else - Paddis GPR12 (ireg_of a1) (Csymbol_high symb ofs) :: - mk1 (Csymbol_low symb ofs) GPR12 :: k - | Ainstack ofs, nil => - if Int.eq (high_s ofs) Int.zero then - mk1 (Cint ofs) GPR1 :: k - else - Paddis GPR12 GPR1 (Cint (high_s ofs)) :: - mk1 (Cint (low_s ofs)) GPR12 :: k - | _, _ => - (* should not happen *) k - end. - -(** Translation of a Mach instruction. *) - -Definition transl_instr (f: Mach.function) (i: Mach.instruction) (k: code) := - match i with - | Mgetstack ofs ty dst => - loadind GPR1 ofs ty dst k - | Msetstack src ofs ty => - storeind src GPR1 ofs ty k - | Mgetparam ofs ty dst => - Plwz GPR12 (Cint f.(fn_link_ofs)) GPR1 :: loadind GPR12 ofs ty dst k - | Mop op args res => - transl_op op args res k - | Mload chunk addr args dst => - match chunk with - | Mint8signed => - transl_load_store - (Plbz (ireg_of dst)) (Plbzx (ireg_of dst)) addr args - (Pextsb (ireg_of dst) (ireg_of dst) :: k) - | Mint8unsigned => - transl_load_store - (Plbz (ireg_of dst)) (Plbzx (ireg_of dst)) addr args k - | Mint16signed => - transl_load_store - (Plha (ireg_of dst)) (Plhax (ireg_of dst)) addr args k - | Mint16unsigned => - transl_load_store - (Plhz (ireg_of dst)) (Plhzx (ireg_of dst)) addr args k - | Mint32 => - transl_load_store - (Plwz (ireg_of dst)) (Plwzx (ireg_of dst)) addr args k - | Mfloat32 => - transl_load_store - (Plfs (freg_of dst)) (Plfsx (freg_of dst)) addr args k - | Mfloat64 => - transl_load_store - (Plfd (freg_of dst)) (Plfdx (freg_of dst)) addr args k - end - | Mstore chunk addr args src => - match chunk with - | Mint8signed => - transl_load_store - (Pstb (ireg_of src)) (Pstbx (ireg_of src)) addr args k - | Mint8unsigned => - transl_load_store - (Pstb (ireg_of src)) (Pstbx (ireg_of src)) addr args k - | Mint16signed => - transl_load_store - (Psth (ireg_of src)) (Psthx (ireg_of src)) addr args k - | Mint16unsigned => - transl_load_store - (Psth (ireg_of src)) (Psthx (ireg_of src)) addr args k - | Mint32 => - transl_load_store - (Pstw (ireg_of src)) (Pstwx (ireg_of src)) addr args k - | Mfloat32 => - transl_load_store - (Pstfs (freg_of src)) (Pstfsx (freg_of src)) addr args k - | Mfloat64 => - transl_load_store - (Pstfd (freg_of src)) (Pstfdx (freg_of src)) addr args k - end - | Mcall sig (inl r) => - Pmtctr (ireg_of r) :: Pbctrl :: k - | Mcall sig (inr symb) => - Pbl symb :: k - | Mtailcall sig (inl r) => - Pmtctr (ireg_of r) :: - Plwz GPR12 (Cint f.(fn_retaddr_ofs)) GPR1 :: - Pmtlr GPR12 :: - Pfreeframe f.(fn_link_ofs) :: - Pbctr :: k - | Mtailcall sig (inr symb) => - Plwz GPR12 (Cint f.(fn_retaddr_ofs)) GPR1 :: - Pmtlr GPR12 :: - Pfreeframe f.(fn_link_ofs) :: - Pbs symb :: k - | Malloc => - Pallocblock :: k - | Mlabel lbl => - Plabel lbl :: k - | Mgoto lbl => - Pb lbl :: k - | Mcond cond args lbl => - let p := crbit_for_cond cond in - transl_cond cond args - (if (snd p) then Pbt (fst p) lbl :: k else Pbf (fst p) lbl :: k) - | Mreturn => - Plwz GPR12 (Cint f.(fn_retaddr_ofs)) GPR1 :: - Pmtlr GPR12 :: - Pfreeframe f.(fn_link_ofs) :: - Pblr :: k - end. - -Definition transl_code (f: Mach.function) (il: list Mach.instruction) := - List.fold_right (transl_instr f) nil il. - -(** Translation of a whole function. Note that we must check - that the generated code contains less than [2^32] instructions, - otherwise the offset part of the [PC] code pointer could wrap - around, leading to incorrect executions. *) - -Definition transl_function (f: Mach.function) := - Pallocframe (- f.(fn_framesize)) f.(fn_stacksize) f.(fn_link_ofs) :: - Pmflr GPR12 :: - Pstw GPR12 (Cint f.(fn_retaddr_ofs)) GPR1 :: - transl_code f f.(fn_code). - -Fixpoint code_size (c: code) : Z := - match c with - | nil => 0 - | instr :: c' => code_size c' + 1 - end. - -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 Errors.Error (msg "code size exceeded") - else Errors.OK c. - -Definition transf_fundef (f: Mach.fundef) : res PPC.fundef := - transf_partial_fundef transf_function f. - -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 deleted file mode 100644 index 6db8b47..0000000 --- a/backend/PPCgenproof.v +++ /dev/null @@ -1,1393 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** Correctness proof for PPC generation: main proof. *) - -Require Import Coqlib. -Require Import Maps. -Require Import Errors. -Require Import AST. -Require Import Integers. -Require Import Floats. -Require Import Values. -Require Import 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 = Errors.OK tprog. - -Let ge := Genv.globalenv prog. -Let tge := Genv.globalenv tprog. - -Lemma symbols_preserved: - forall id, Genv.find_symbol tge id = Genv.find_symbol ge id. -Proof. - intros. unfold ge, tge. - apply Genv.find_symbol_transf_partial with transf_fundef. - exact TRANSF. -Qed. - -Lemma functions_translated: - forall b f, - Genv.find_funct_ptr ge b = Some f -> - exists tf, Genv.find_funct_ptr tge b = Some tf /\ transf_fundef f = Errors.OK tf. -Proof - (Genv.find_funct_ptr_transf_partial transf_fundef TRANSF). - -Lemma functions_transl: - forall f b, - Genv.find_funct_ptr ge b = Some (Internal f) -> - Genv.find_funct_ptr tge b = Some (Internal (transl_function f)). -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))); simpl; intro. - congruence. intro. inv B0. auto. -Qed. - -Lemma functions_transl_no_overflow: - forall b f, - Genv.find_funct_ptr ge b = Some (Internal f) -> - code_size (transl_function f) <= Int.max_unsigned. -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))); simpl; intro. - congruence. intro; omega. -Qed. - -(** * Properties of control flow *) - -Lemma find_instr_in: - forall c pos i, - find_instr pos c = Some i -> In i c. -Proof. - induction c; simpl. intros; discriminate. - intros until i. case (zeq pos 0); intros. - left; congruence. right; eauto. -Qed. - -Lemma find_instr_tail: - forall c1 i c2 pos, - code_tail pos c1 (i :: c2) -> - find_instr pos c1 = Some i. -Proof. - 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: - forall fn, code_size fn >= 0. -Proof. - induction fn; simpl; omega. -Qed. - -Remark code_tail_bounds: - forall fn ofs i c, - code_tail ofs fn (i :: c) -> 0 <= ofs < code_size fn. -Proof. - 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. -Proof. - 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. -Proof. - 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. -Qed. - -(** [transl_code_at_pc pc fn c] holds if the code pointer [pc] points - within the PPC code generated by translating Mach function [fn], - and [c] is the tail of the generated code at the position corresponding - to the code pointer [pc]. *) - -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 f 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 - (predicate [exec_steps]) under adequate [transl_code_at_pc] hypotheses. *) - -Lemma exec_straight_steps_1: - forall fn c rs m c' rs' m', - exec_straight tge fn c rs m c' rs' m' -> - code_size fn <= Int.max_unsigned -> - forall b ofs, - rs#PC = Vptr b ofs -> - Genv.find_funct_ptr tge b = Some (Internal fn) -> - code_tail (Int.unsigned ofs) fn c -> - plus step tge (State rs m) E0 (State rs' m'). -Proof. - 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. - apply code_tail_next_int with i; auto. - traceEq. -Qed. - -Lemma exec_straight_steps_2: - forall fn c rs m c' rs' m', - exec_straight tge fn c rs m c' rs' m' -> - code_size fn <= Int.max_unsigned -> - forall b ofs, - rs#PC = Vptr b ofs -> - Genv.find_funct_ptr tge b = Some (Internal fn) -> - code_tail (Int.unsigned ofs) fn c -> - exists ofs', - rs'#PC = Vptr b ofs' - /\ code_tail (Int.unsigned ofs') fn c'. -Proof. - induction 1; intros. - 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_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 f 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 f c) rs m (transl_code f c') rs' m' -> - transl_code_at_pc (rs' PC) fb f c'. -Proof. - intros. inversion H. subst. - generalize (functions_transl_no_overflow _ _ H2). intro. - generalize (functions_transl _ _ H2). intro. - generalize (exec_straight_steps_2 _ _ _ _ _ _ _ - 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. *) - -Fixpoint find_label (lbl: label) (c: code) {struct c} : option code := - match c with - | nil => None - | instr :: c' => - if is_label lbl instr then Some c' else find_label lbl c' - end. - -Lemma label_pos_code_tail: - forall lbl c pos c', - find_label lbl c = Some c' -> - exists pos', - label_pos lbl pos c = Some pos' - /\ code_tail (pos' - pos) c c' - /\ pos < pos' <= pos + code_size c. -Proof. - induction c. - simpl; intros. discriminate. - simpl; intros until c'. - case (is_label lbl a). - intro EQ; injection EQ; intro; subst c'. - exists (pos + 1). split. auto. split. - 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. - 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 - preserves labels, in the sense that the following diagram commutes: -<< - translation - Mach code ------------------------ PPC instr sequence - | | - | Mach.find_label lbl find_label lbl | - | | - v v - Mach code tail ------------------- PPC instr seq tail - translation ->> - The proof demands many boring lemmas showing that PPC constructor - functions do not introduce new labels. -*) - -Section TRANSL_LABEL. - -Variable lbl: label. - -Remark loadimm_label: - forall r n k, find_label lbl (loadimm r n k) = find_label lbl k. -Proof. - intros. unfold loadimm. - case (Int.eq (high_s n) Int.zero). reflexivity. - case (Int.eq (low_s n) Int.zero). reflexivity. - reflexivity. -Qed. -Hint Rewrite loadimm_label: labels. - -Remark addimm_1_label: - forall r1 r2 n k, find_label lbl (addimm_1 r1 r2 n k) = find_label lbl k. -Proof. - intros; unfold addimm_1. - case (Int.eq (high_s n) Int.zero). reflexivity. - case (Int.eq (low_s n) Int.zero). reflexivity. reflexivity. -Qed. -Remark addimm_2_label: - forall r1 r2 n k, find_label lbl (addimm_2 r1 r2 n k) = find_label lbl k. -Proof. - intros; unfold addimm_2. autorewrite with labels. reflexivity. -Qed. -Remark addimm_label: - forall r1 r2 n k, find_label lbl (addimm r1 r2 n k) = find_label lbl k. -Proof. - intros; unfold addimm. - case (ireg_eq r1 GPR0); intro. apply addimm_2_label. - case (ireg_eq r2 GPR0); intro. apply addimm_2_label. - apply addimm_1_label. -Qed. -Hint Rewrite addimm_label: labels. - -Remark andimm_label: - forall r1 r2 n k, find_label lbl (andimm r1 r2 n k) = find_label lbl k. -Proof. - intros; unfold andimm. - case (Int.eq (high_u n) Int.zero). reflexivity. - case (Int.eq (low_u n) Int.zero). reflexivity. - autorewrite with labels. reflexivity. -Qed. -Hint Rewrite andimm_label: labels. - -Remark orimm_label: - forall r1 r2 n k, find_label lbl (orimm r1 r2 n k) = find_label lbl k. -Proof. - intros; unfold orimm. - case (Int.eq (high_u n) Int.zero). reflexivity. - case (Int.eq (low_u n) Int.zero). reflexivity. reflexivity. -Qed. -Hint Rewrite orimm_label: labels. - -Remark xorimm_label: - forall r1 r2 n k, find_label lbl (xorimm r1 r2 n k) = find_label lbl k. -Proof. - intros; unfold xorimm. - case (Int.eq (high_u n) Int.zero). reflexivity. - case (Int.eq (low_u n) Int.zero). reflexivity. reflexivity. -Qed. -Hint Rewrite xorimm_label: labels. - -Remark loadind_aux_label: - forall base ofs ty dst k, find_label lbl (loadind_aux base ofs ty dst :: k) = find_label lbl k. -Proof. - intros; unfold loadind_aux. - case ty; reflexivity. -Qed. -Remark loadind_label: - forall base ofs ty dst k, find_label lbl (loadind base ofs ty dst k) = find_label lbl k. -Proof. - intros; unfold loadind. - case (Int.eq (high_s ofs) Int.zero). apply loadind_aux_label. - transitivity (find_label lbl (loadind_aux GPR12 (low_s ofs) ty dst :: k)). - reflexivity. apply loadind_aux_label. -Qed. -Hint Rewrite loadind_label: labels. -Remark storeind_aux_label: - forall base ofs ty dst k, find_label lbl (storeind_aux base ofs ty dst :: k) = find_label lbl k. -Proof. - intros; unfold storeind_aux. - case dst; reflexivity. -Qed. -Remark storeind_label: - forall base ofs ty src k, find_label lbl (storeind base src ofs ty k) = find_label lbl k. -Proof. - intros; unfold storeind. - case (Int.eq (high_s ofs) Int.zero). apply storeind_aux_label. - transitivity (find_label lbl (storeind_aux base GPR12 (low_s ofs) ty :: k)). - reflexivity. apply storeind_aux_label. -Qed. -Hint Rewrite storeind_label: labels. -Remark floatcomp_label: - forall cmp r1 r2 k, find_label lbl (floatcomp cmp r1 r2 k) = find_label lbl k. -Proof. - intros; unfold floatcomp. destruct cmp; reflexivity. -Qed. - -Remark transl_cond_label: - forall cond args k, find_label lbl (transl_cond cond args k) = find_label lbl k. -Proof. - intros; unfold transl_cond. - destruct cond; (destruct args; - [try reflexivity | destruct args; - [try reflexivity | destruct args; try reflexivity]]). - case (Int.eq (high_s i) Int.zero). reflexivity. - autorewrite with labels; reflexivity. - case (Int.eq (high_u i) Int.zero). reflexivity. - autorewrite with labels; reflexivity. - apply floatcomp_label. apply floatcomp_label. - apply andimm_label. apply andimm_label. -Qed. -Hint Rewrite transl_cond_label: labels. -Remark transl_op_label: - forall op args r k, find_label lbl (transl_op op args r k) = find_label lbl k. -Proof. - intros; unfold transl_op; - 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 (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. - case (snd (crbit_for_cond c)); reflexivity. - case (snd (crbit_for_cond c)); reflexivity. - case (snd (crbit_for_cond c)); reflexivity. - case (snd (crbit_for_cond c)); reflexivity. -Qed. -Hint Rewrite transl_op_label: labels. - -Remark transl_load_store_label: - forall (mk1: constant -> ireg -> instruction) (mk2: ireg -> ireg -> instruction) - addr args k, - (forall c r, is_label lbl (mk1 c r) = false) -> - (forall r1 r2, is_label lbl (mk2 r1 r2) = false) -> - find_label lbl (transl_load_store mk1 mk2 addr args k) = find_label lbl k. -Proof. - intros; unfold transl_load_store. - destruct addr; destruct args; try (destruct args); try (destruct args); - try reflexivity. - case (ireg_eq (ireg_of m) GPR0); intro. - simpl. rewrite H. auto. - case (Int.eq (high_s i) Int.zero). simpl; rewrite H; auto. - simpl; rewrite H; auto. - simpl; rewrite H0; auto. - simpl; rewrite H; auto. - case (ireg_eq (ireg_of m) GPR0); intro; simpl; rewrite H; auto. - case (Int.eq (high_s i) Int.zero); simpl; rewrite H; auto. -Qed. -Hint Rewrite transl_load_store_label: labels. - -Lemma transl_instr_label: - forall f i k, - find_label lbl (transl_instr f i k) = - if Mach.is_label lbl i then Some k else find_label lbl k. -Proof. - intros. generalize (Mach.is_label_correct lbl i). - case (Mach.is_label lbl i); intro. - subst i. simpl. rewrite peq_true. auto. - destruct i; simpl; autorewrite with labels; try reflexivity. - 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. - -Lemma transl_code_label: - forall f c, - find_label lbl (transl_code f c) = - option_map (transl_code f) (Mach.find_label lbl c). -Proof. - induction c; simpl; intros. - auto. rewrite transl_instr_label. - case (Mach.is_label lbl a). reflexivity. - auto. -Qed. - -Lemma transl_find_label: - forall f, - find_label lbl (transl_function f) = - option_map (transl_code f) (Mach.find_label lbl f.(fn_code)). -Proof. - intros. unfold transl_function. simpl. apply transl_code_label. -Qed. - -End TRANSL_LABEL. - -(** A valid branch in a piece of Mach code translates to a valid ``go to'' - transition in the generated PPC code. *) - -Lemma find_label_goto_label: - forall f lbl rs m c' b ofs, - Genv.find_funct_ptr ge b = Some (Internal f) -> - rs PC = Vptr b ofs -> - 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) b f c' - /\ forall r, r <> PC -> rs'#r = rs#r. -Proof. - intros. - generalize (transl_find_label lbl f). - rewrite H1; simpl. intro. - generalize (label_pos_code_tail lbl (transl_function f) 0 - (transl_code f c') H2). - 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. - 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. - -(** * Memory properties *) - -(** The PowerPC has no instruction for ``load 8-bit signed integer''. - 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.sign_ext 8) (Mem.loadv Mint8unsigned m a). -Proof. - intros. unfold Mem.loadv. destruct a; try reflexivity. - unfold load. rewrite (in_bounds_equiv Mint8signed Mint8unsigned). - destruct (in_bounds m Mint8unsigned b (Int.signed i)); auto. - simpl. - destruct (getN 0 (Int.signed i) (contents (blocks m b))); auto. - simpl. rewrite Int.sign_ext_zero_ext. auto. compute; auto. - auto. -Qed. - -(** Similarly, we show that signed 8- and 16-bit stores can be performed - like unsigned stores. *) - -Lemma storev_8_signed_unsigned: - forall m a v, - Mem.storev Mint8signed m a v = Mem.storev Mint8unsigned m a v. -Proof. - intros. unfold storev. destruct a; auto. - unfold store. rewrite (in_bounds_equiv Mint8signed Mint8unsigned). - auto. auto. -Qed. - -Lemma storev_16_signed_unsigned: - forall m a v, - Mem.storev Mint16signed m a v = Mem.storev Mint16unsigned m a v. -Proof. - intros. unfold storev. destruct a; auto. - unfold store. rewrite (in_bounds_equiv Mint16signed Mint16unsigned). - auto. auto. -Qed. - -(** * Proof of semantic preservation *) - -(** Semantic preservation is proved using simulation diagrams - of the following form. -<< - st1 --------------- st2 - | | - t| *|t - | | - v v - st1'--------------- st2' ->> - 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. -*) - -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 f c1) rs1 m1 (transl_code f 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 (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; inv MS. - left; eapply exec_straight_steps; eauto with coqlib. - exists (nextinstr rs); split. - simpl. apply exec_straight_one. reflexivity. reflexivity. - apply agree_nextinstr; auto. -Qed. - -Lemma exec_Mgetstack_prop: - 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; 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 f c) rs m v H H1 NOTE). - intros [rs2 [EX [RES OTH]]]. - 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. -Qed. - -Lemma exec_Msetstack_prop: - 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; 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 rs) in H; auto. - assert (NOTE: GPR1 <> GPR0). congruence. - generalize (storeind_correct tge (transl_function f) GPR1 ofs ty - src (transl_code f c) rs m m' H H1 NOTE). - intros [rs2 [EX OTH]]. - 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 (s : list stackframe) (fb : block) (f: Mach.function) (sp parent : val) - (ofs : int) (ty : typ) (dst : mreg) (c : list Mach.instruction) - (ms : Mach.regset) (m : mem) (v : val), - Genv.find_funct_ptr ge fb = Some (Internal f) -> - load_stack m sp Tint f.(fn_link_ofs) = 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; inv MS. - assert (f0 = f) by congruence. subst f0. - set (rs2 := nextinstr (rs#GPR12 <- parent)). - assert (EX1: exec_straight tge (transl_function f) - (transl_code f (Mgetparam ofs ty dst :: c)) rs m - (loadind GPR12 ofs ty dst (transl_code f 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 rs); auto. - unfold load_stack in H0. simpl chunk_of_type in H0. - rewrite H0. reflexivity. reflexivity. - generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). - intro WTI. inversion WTI. - unfold load_stack in H1. change parent with rs2#GPR12 in H1. - assert (NOTE: GPR12 <> GPR0). congruence. - generalize (loadind_correct tge (transl_function f) GPR12 ofs ty - dst (transl_code f c) rs2 m v H1 H3 NOTE). - intros [rs3 [EX2 [RES OTH]]]. - 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. -Qed. - -Lemma exec_Mop_prop: - 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; inv MS. - generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). - 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 (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; 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. - left; eapply exec_straight_steps; eauto with coqlib; - destruct chunk; simpl; simpl in H6; - (* all cases but Mint8signed *) - try (eapply transl_load_correct; eauto; - intros; simpl; unfold preg_of; rewrite H6; auto). - (* Mint8signed *) - generalize (loadv_8_signed_unsigned m a). - rewrite H0. - caseEq (loadv Mint8unsigned m a); - [idtac | simpl;intros;discriminate]. - intros v' LOAD' EQ. simpl in EQ. injection EQ. intro EQ1. clear EQ. - assert (X1: forall (cst : constant) (r1 : ireg) (rs1 : regset), - exec_instr tge (transl_function f) (Plbz (ireg_of dst) cst r1) rs1 m = - load1 tge Mint8unsigned (preg_of dst) cst r1 rs1 m). - intros. unfold preg_of; rewrite H6. reflexivity. - assert (X2: forall (r1 r2 : ireg) (rs1 : regset), - exec_instr tge (transl_function f) (Plbzx (ireg_of dst) r1 r2) rs1 m = - load2 Mint8unsigned (preg_of dst) r1 r2 rs1 m). - intros. unfold preg_of; rewrite H6. reflexivity. - generalize (transl_load_correct tge (transl_function f) - (Plbz (ireg_of dst)) (Plbzx (ireg_of dst)) - Mint8unsigned addr args - (Pextsb (ireg_of dst) (ireg_of dst) :: transl_code f c) - ms sp rs m dst a v' - X1 X2 AG H3 H7 LOAD'). - intros [rs2 [EX1 AG1]]. - exists (nextinstr (rs2#(ireg_of dst) <- v)). - split. eapply exec_straight_trans. eexact EX1. - apply exec_straight_one. simpl. - rewrite <- (ireg_val _ _ _ dst AG1);auto. rewrite Regmap.gss. - rewrite EQ1. reflexivity. reflexivity. - eauto with ppcgen. -Qed. - -Lemma exec_Mstore_prop: - forall (s : list stackframe) (fb : block) (sp : val) - (chunk : memory_chunk) (addr : addressing) (args : list mreg) - (src : mreg) (c : list Mach.instruction) (ms : mreg -> val) - (m m' : mem) (a : val), - eval_addressing ge sp addr ms ## args = Some a -> - storev chunk m a (ms src) = Some m' -> - exec_instr_prop (Machconcr.State s fb sp (Mstore chunk addr args src :: c) ms m) E0 - (Machconcr.State s fb sp c ms m'). -Proof. - intros; red; intros; inv MS. - generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). - intro WTI; inversion WTI. - rewrite <- (eval_addressing_preserved symbols_preserved) in H. - left; eapply exec_straight_steps; eauto with coqlib. - destruct chunk; simpl; simpl in H6; - 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. - -Lemma exec_Mcall_prop: - 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; inv MS. - assert (f0 = f) by congruence. subst f0. - generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). - intro WTI. inversion WTI. - inv AT. - assert (NOOV: code_size (transl_function f) <= Int.max_unsigned). - eapply functions_transl_no_overflow; eauto. - 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 (rs#CTR <- (ms m0))). - set (rs3 := rs2 #LR <- (Val.add rs2#PC Vone) #PC <- (ms m0)). - 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. - 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 *) - generalize (code_tail_next_int _ _ _ _ NOOV H7). intro CT1. - 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. - 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: Mach.function) (f' : block), - find_function_ptr ge ros ms = Some f' -> - Genv.find_funct_ptr ge fb = Some (Internal f) -> - load_stack m (Vptr stk soff) Tint f.(fn_link_ofs) = Some (parent_sp s) -> - load_stack m (Vptr stk soff) Tint f.(fn_retaddr_ofs) = Some (parent_ra s) -> - 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. - assert (f0 = f) by congruence. subst f0. - 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 H9. - (* Indirect call *) - set (rs2 := nextinstr (rs#CTR <- (ms m0))). - set (rs3 := nextinstr (rs2#GPR12 <- (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 f (Mtailcall sig (inl ident m0) :: c)) rs m - (Pbctr :: transl_code f c) rs5 (free m stk)). - simpl. apply exec_straight_step with rs2 m. - simpl. rewrite <- (ireg_val _ _ _ _ AG H6). 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 H2. simpl in H2. rewrite H2. - 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 H1; simpl in H1. - simpl. rewrite H1. 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 <- H7; 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 H12. - 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#GPR12 <- (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 f (Mtailcall sig (inr mreg i) :: c)) rs m - (Pbs i :: transl_code f 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 H2. simpl in H2. rewrite H2. - 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 H1; simpl in H1. - simpl. rewrite H1. 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 <- H7; 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 H12. - rewrite Pregmap.gso; auto with ppcgen. - unfold rs5; auto with ppcgen. -Qed. - -Lemma exec_Malloc_prop: - 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 -> - 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; inv MS. - left; eapply exec_straight_steps; eauto with coqlib. - simpl. eapply transl_alloc_correct; eauto. -Qed. - -Lemma exec_Mgoto_prop: - 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; 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]]]. - 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 (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; inv MS. assert (f0 = f) by congruence. subst f0. - generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). - intro WTI. inv WTI. - pose (k1 := - if snd (crbit_for_cond cond) - then Pbt (fst (crbit_for_cond cond)) lbl :: transl_code f c - else Pbf (fst (crbit_for_cond cond)) lbl :: transl_code f c). - generalize (transl_cond_correct tge (transl_function f) - cond args k1 ms sp rs m true H3 AG H). - simpl. intros [rs2 [EX [RES AG2]]]. - 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 _ _ _ FIND PC2 H1). - intros [rs3 [GOTO [AT3 INV3]]]. - 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. - econstructor; eauto. - eapply find_instr_tail. unfold k1 in CT2; rewrite ISSET in CT2. eauto. - simpl. rewrite RES. simpl. auto. - econstructor; eauto. - eapply find_instr_tail. unfold k1 in CT2; rewrite ISSET in CT2. eauto. - simpl. rewrite RES. simpl. auto. - traceEq. - econstructor; eauto. - eapply Mach.find_label_incl; eauto. - apply agree_exten_2 with rs2; auto. -Qed. - -Lemma exec_Mcond_false_prop: - 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; inv MS. - generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). - intro WTI. inversion WTI. - pose (k1 := - if snd (crbit_for_cond cond) - then Pbt (fst (crbit_for_cond cond)) lbl :: transl_code f c - else Pbf (fst (crbit_for_cond cond)) lbl :: transl_code f c). - generalize (transl_cond_correct tge (transl_function f) - cond args k1 ms sp rs m false H1 AG H). - simpl. intros [rs2 [EX [RES AG2]]]. - 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. - reflexivity. - unfold k1; rewrite ISSET; apply exec_straight_one. - simpl. rewrite RES. reflexivity. - reflexivity. - auto with ppcgen. -Qed. - -Lemma exec_Mreturn_prop: - forall (s : list stackframe) (fb stk : block) (soff : int) - (c : list Mach.instruction) (ms : Mach.regset) (m : mem) (f: Mach.function), - Genv.find_funct_ptr ge fb = Some (Internal f) -> - load_stack m (Vptr stk soff) Tint f.(fn_link_ofs) = Some (parent_sp s) -> - load_stack m (Vptr stk soff) Tint f.(fn_retaddr_ofs) = Some (parent_ra s) -> - exec_instr_prop (Machconcr.State s fb (Vptr stk soff) (Mreturn :: c) ms m) E0 - (Returnstate s ms (free m stk)). -Proof. - intros; red; intros; inv MS. - assert (f0 = f) by congruence. subst f0. - set (rs2 := nextinstr (rs#GPR12 <- (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 f (Mreturn :: c)) rs m - (Pblr :: transl_code f 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 H1. simpl in H1. - rewrite <- (sp_val _ _ _ AG). simpl. rewrite H1. - reflexivity. discriminate. - unfold rs3. change (parent_ra s) with rs2#GPR12. reflexivity. - simpl. change (rs3 GPR1) with (rs GPR1). rewrite <- (sp_val _ _ _ AG). - simpl. - unfold load_stack in H0. simpl in H0. - rewrite H0. 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 <- H3. simpl. eauto. - apply functions_transl; eauto. - generalize (functions_transl_no_overflow _ _ H4); intro NOOV. - simpl in H5. 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. - -Hypothesis wt_prog: wt_program prog. - -Lemma exec_function_internal_prop: - forall (s : list stackframe) (fb : block) (ms : Mach.regset) - (m : mem) (f : function) (m1 m2 m3 : mem) (stk : block), - Genv.find_funct_ptr ge fb = Some (Internal f) -> - alloc m (- fn_framesize f) (fn_stacksize f) = (m1, stk) -> - let sp := Vptr stk (Int.repr (- fn_framesize f)) in - store_stack m1 sp Tint f.(fn_link_ofs) (parent_sp s) = Some m2 -> - store_stack m2 sp Tint f.(fn_retaddr_ofs) (parent_ra s) = Some m3 -> - exec_instr_prop (Machconcr.Callstate s fb ms m) E0 - (Machconcr.State s fb sp (fn_code f) ms m3). -Proof. - 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 #GPR12 <- Vundef)). - set (rs3 := nextinstr (rs2#GPR12 <- (parent_ra s))). - set (rs4 := nextinstr rs3). - (* Execution of function prologue *) - assert (EXEC_PROLOGUE: - exec_straight tge (transl_function f) - (transl_function f) rs m - (transl_code f (fn_code f)) rs4 m3). - unfold transl_function at 2. - apply exec_straight_three with rs2 m2 rs3 m2. - unfold exec_instr. rewrite H0. fold sp. - unfold store_stack in H1. simpl chunk_of_type in H1. - rewrite <- (sp_val _ _ _ AG). rewrite H1. reflexivity. - simpl. change (rs2 LR) with (rs LR). rewrite ATLR. reflexivity. - simpl. unfold store1. rewrite gpr_or_zero_not_zero. - unfold const_low. change (rs3 GPR1) with sp. change (rs3 GPR12) 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. - 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. - repeat (rewrite Pregmap.gso). elim AG; auto. - auto with ppcgen. auto with ppcgen. auto with ppcgen. - assert (AG4: agree ms sp rs4). - unfold rs4, rs3; auto with ppcgen. - left; exists (State rs4 m3); split. - (* execution *) - eapply exec_straight_steps_1; eauto. - change (Int.unsigned Int.zero) with 0. constructor. - (* match states *) - econstructor; eauto with coqlib. -Qed. - -Lemma exec_function_external_prop: - forall (s : list stackframe) (fb : block) (ms : Mach.regset) - (m : mem) (t0 : trace) (ms' : RegEq.t -> val) - (ef : external_function) (args : list val) (res : val), - 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; 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_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; inv MS. inv STACKS. simpl in *. - right. split. omega. split. auto. - econstructor; eauto. rewrite ATPC; auto. -Qed. - -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 - exec_Mgetparam_prop - exec_Mop_prop - 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_Mreturn_prop - exec_function_internal_prop - exec_function_external_prop - exec_return_prop). - -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 (beh: program_behavior), - Machconcr.exec_program prog beh -> PPC.exec_program tprog beh. -Proof. - 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 deleted file mode 100644 index dd142c5..0000000 --- a/backend/PPCgenproof1.v +++ /dev/null @@ -1,1686 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** Correctness proof for PPC generation: auxiliary results. *) - -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 Machconcr. -Require Import Machtyping. -Require Import PPC. -Require Import PPCgen. -Require Conventions. - -(** * Properties of low half/high half decomposition *) - -Lemma high_half_zero: - forall v, Val.add (high_half v) Vzero = high_half v. -Proof. - intros. generalize (high_half_type v). - rewrite Val.add_commut. - case (high_half v); simpl; intros; try contradiction. - auto. - rewrite Int.add_commut; rewrite Int.add_zero; auto. - rewrite Int.add_zero; auto. -Qed. - -Lemma low_high_u: - forall n, Int.or (Int.shl (high_u n) (Int.repr 16)) (low_u n) = n. -Proof. - intros. unfold high_u, low_u. - rewrite Int.shl_rolm. rewrite Int.shru_rolm. - rewrite Int.rolm_rolm. - change (Int.modu (Int.add (Int.sub (Int.repr (Z_of_nat wordsize)) (Int.repr 16)) - (Int.repr 16)) - (Int.repr (Z_of_nat wordsize))) - with (Int.zero). - rewrite Int.rolm_zero. rewrite <- Int.and_or_distrib. - exact (Int.and_mone n). - reflexivity. reflexivity. -Qed. - -Lemma low_high_u_xor: - forall n, Int.xor (Int.shl (high_u n) (Int.repr 16)) (low_u n) = n. -Proof. - intros. unfold high_u, low_u. - rewrite Int.shl_rolm. rewrite Int.shru_rolm. - rewrite Int.rolm_rolm. - change (Int.modu (Int.add (Int.sub (Int.repr (Z_of_nat wordsize)) (Int.repr 16)) - (Int.repr 16)) - (Int.repr (Z_of_nat wordsize))) - with (Int.zero). - rewrite Int.rolm_zero. rewrite <- Int.and_xor_distrib. - exact (Int.and_mone n). - reflexivity. reflexivity. -Qed. - -Lemma low_high_s: - forall n, Int.add (Int.shl (high_s n) (Int.repr 16)) (low_s n) = n. -Proof. - intros. rewrite Int.shl_mul_two_p. - unfold high_s. - rewrite <- (Int.divu_pow2 (Int.sub n (low_s n)) (Int.repr 65536) (Int.repr 16)). - change (two_p (Int.unsigned (Int.repr 16))) with 65536. - - assert (forall x y, y > 0 -> (x - x mod y) mod y = 0). - intros. apply Zmod_unique with (x / y). - generalize (Z_div_mod_eq x y H). intro. rewrite Zmult_comm. omega. - omega. - - assert (Int.modu (Int.sub n (low_s n)) (Int.repr 65536) = Int.zero). - unfold Int.modu, Int.zero. decEq. - change (Int.unsigned (Int.repr 65536)) with 65536. - unfold Int.sub. - assert (forall a b, Int.eqm a b -> b mod 65536 = 0 -> a mod 65536 = 0). - intros a b [k EQ] H1. rewrite EQ. - change modulus with (65536 * 65536). - rewrite Zmult_assoc. rewrite Zplus_comm. rewrite Z_mod_plus. auto. - omega. - eapply H0. apply Int.eqm_sym. apply Int.eqm_unsigned_repr. - unfold low_s. unfold Int.sign_ext. - change (two_p 16) with 65536. change (two_p (16-1)) with 32768. - set (N := Int.unsigned n). - case (zlt (N mod 65536) 32768); intro. - apply H0 with (N - N mod 65536). auto with ints. - apply H. omega. - apply H0 with (N - (N mod 65536 - 65536)). auto with ints. - replace (N - (N mod 65536 - 65536)) - with ((N - N mod 65536) + 1 * 65536). - rewrite Z_mod_plus. apply H. omega. omega. ring. - - assert (Int.repr 65536 <> Int.zero). compute. congruence. - generalize (Int.modu_divu_Euclid (Int.sub n (low_s n)) (Int.repr 65536) H1). - rewrite H0. rewrite Int.add_zero. intro. rewrite <- H2. - rewrite Int.sub_add_opp. rewrite Int.add_assoc. - replace (Int.add (Int.neg (low_s n)) (low_s n)) with Int.zero. - apply Int.add_zero. symmetry. rewrite Int.add_commut. - rewrite <- Int.sub_add_opp. apply Int.sub_idem. - - reflexivity. -Qed. - -(** * Correspondence between Mach registers and PPC registers *) - -Hint Extern 2 (_ <> _) => discriminate: ppcgen. - -(** Mapping from Mach registers to PPC registers. *) - -Definition preg_of (r: mreg) := - match mreg_type r with - | Tint => IR (ireg_of r) - | Tfloat => FR (freg_of r) - end. - -Lemma preg_of_injective: - forall r1 r2, preg_of r1 = preg_of r2 -> r1 = r2. -Proof. - destruct r1; destruct r2; simpl; intros; reflexivity || discriminate. -Qed. - -(** Characterization of PPC registers that correspond to Mach registers. *) - -Definition is_data_reg (r: preg) : Prop := - match r with - | IR GPR12 => False - | FR FPR13 => False - | PC => False | LR => False | CTR => False - | CR0_0 => False | CR0_1 => False | CR0_2 => False | CR0_3 => False - | CARRY => False - | _ => True - end. - -Lemma ireg_of_is_data_reg: - forall (r: mreg), is_data_reg (ireg_of r). -Proof. - destruct r; exact I. -Qed. - -Lemma freg_of_is_data_reg: - forall (r: mreg), is_data_reg (ireg_of r). -Proof. - destruct r; exact I. -Qed. - -Lemma preg_of_is_data_reg: - forall (r: mreg), is_data_reg (preg_of r). -Proof. - destruct r; exact I. -Qed. - -Lemma ireg_of_not_GPR1: - forall r, ireg_of r <> GPR1. -Proof. - intro. case r; discriminate. -Qed. -Lemma ireg_of_not_GPR12: - forall r, ireg_of r <> GPR12. -Proof. - intro. case r; discriminate. -Qed. -Lemma freg_of_not_FPR13: - forall r, freg_of r <> FPR13. -Proof. - intro. case r; discriminate. -Qed. -Hint Resolve ireg_of_not_GPR1 ireg_of_not_GPR12 freg_of_not_FPR13: ppcgen. - -Lemma preg_of_not: - forall r1 r2, ~(is_data_reg r2) -> preg_of r1 <> r2. -Proof. - intros; red; intro. subst r2. elim H. apply preg_of_is_data_reg. -Qed. -Hint Resolve preg_of_not: ppcgen. - -Lemma preg_of_not_GPR1: - forall r, preg_of r <> GPR1. -Proof. - intro. case r; discriminate. -Qed. -Hint Resolve preg_of_not_GPR1: ppcgen. - -(** Agreement between Mach register sets and PPC register sets. *) - -Definition agree (ms: Mach.regset) (sp: val) (rs: PPC.regset) := - rs#GPR1 = sp /\ forall r: mreg, ms r = rs#(preg_of r). - -Lemma preg_val: - forall ms sp rs r, - agree ms sp rs -> ms r = rs#(preg_of r). -Proof. - intros. elim H. auto. -Qed. - -Lemma ireg_val: - forall ms sp rs r, - agree ms sp rs -> - mreg_type r = Tint -> - ms r = rs#(ireg_of r). -Proof. - intros. elim H; intros. - generalize (H2 r). unfold preg_of. rewrite H0. auto. -Qed. - -Lemma freg_val: - forall ms sp rs r, - agree ms sp rs -> - mreg_type r = Tfloat -> - ms r = rs#(freg_of r). -Proof. - intros. elim H; intros. - generalize (H2 r). unfold preg_of. rewrite H0. auto. -Qed. - -Lemma sp_val: - forall ms sp rs, - agree ms sp rs -> - sp = rs#GPR1. -Proof. - intros. elim H; auto. -Qed. - -Lemma agree_exten_1: - forall ms sp rs rs', - agree ms sp rs -> - (forall r, is_data_reg r -> rs'#r = rs#r) -> - agree ms sp rs'. -Proof. - unfold agree; intros. elim H; intros. - split. rewrite H0. auto. exact I. - intros. rewrite H0. auto. apply preg_of_is_data_reg. -Qed. - -Lemma agree_exten_2: - forall ms sp rs rs', - agree ms sp rs -> - (forall r, - r <> IR GPR12 -> r <> FR FPR13 -> - r <> PC -> r <> LR -> r <> CTR -> - r <> CR0_0 -> r <> CR0_1 -> r <> CR0_2 -> r <> CR0_3 -> - r <> CARRY -> - rs'#r = rs#r) -> - agree ms sp rs'. -Proof. - intros. apply agree_exten_1 with rs. auto. - intros. apply H0; (red; intro; subst r; elim H1). -Qed. - -(** Preservation of register agreement under various assignments. *) - -Lemma agree_set_mreg: - forall ms sp rs r v, - agree ms sp rs -> - agree (Regmap.set r v ms) sp (rs#(preg_of r) <- v). -Proof. - unfold agree; intros. elim H; intros; clear H. - split. rewrite Pregmap.gso. auto. apply sym_not_eq. apply preg_of_not_GPR1. - intros. unfold Regmap.set. case (RegEq.eq r0 r); intro. - subst r0. rewrite Pregmap.gss. auto. - rewrite Pregmap.gso. auto. red; intro. - elim n. apply preg_of_injective; auto. -Qed. -Hint Resolve agree_set_mreg: ppcgen. - -Lemma agree_set_mireg: - forall ms sp rs r v, - agree ms sp (rs#(preg_of r) <- v) -> - mreg_type r = Tint -> - agree ms sp (rs#(ireg_of r) <- v). -Proof. - intros. unfold preg_of in H. rewrite H0 in H. auto. -Qed. -Hint Resolve agree_set_mireg: ppcgen. - -Lemma agree_set_mfreg: - forall ms sp rs r v, - agree ms sp (rs#(preg_of r) <- v) -> - mreg_type r = Tfloat -> - agree ms sp (rs#(freg_of r) <- v). -Proof. - intros. unfold preg_of in H. rewrite H0 in H. auto. -Qed. -Hint Resolve agree_set_mfreg: ppcgen. - -Lemma agree_set_other: - forall ms sp rs r v, - agree ms sp rs -> - ~(is_data_reg r) -> - agree ms sp (rs#r <- v). -Proof. - intros. apply agree_exten_1 with rs. - auto. intros. apply Pregmap.gso. red; intro; subst r0; contradiction. -Qed. -Hint Resolve agree_set_other: ppcgen. - -Lemma agree_nextinstr: - forall ms sp rs, - agree ms sp rs -> agree ms sp (nextinstr rs). -Proof. - intros. unfold nextinstr. apply agree_set_other. auto. auto. -Qed. -Hint Resolve agree_nextinstr: ppcgen. - -Lemma agree_set_mireg_twice: - forall ms sp rs r v v', - agree ms sp rs -> - mreg_type r = Tint -> - agree (Regmap.set r v ms) sp (rs #(ireg_of r) <- v' #(ireg_of r) <- v). -Proof. - intros. replace (IR (ireg_of r)) with (preg_of r). elim H; intros. - split. repeat (rewrite Pregmap.gso; auto with ppcgen). - intros. case (mreg_eq r r0); intro. - subst r0. rewrite Regmap.gss. rewrite Pregmap.gss. auto. - assert (preg_of r <> preg_of r0). - red; intro. elim n. apply preg_of_injective. auto. - rewrite Regmap.gso; auto. - repeat (rewrite Pregmap.gso; auto). - unfold preg_of. rewrite H0. auto. -Qed. -Hint Resolve agree_set_mireg_twice: ppcgen. - -Lemma agree_set_twice_mireg: - forall ms sp rs r v v', - agree (Regmap.set r v' ms) sp rs -> - mreg_type r = Tint -> - agree (Regmap.set r v ms) sp (rs#(ireg_of r) <- v). -Proof. - intros. elim H; intros. - split. rewrite Pregmap.gso. auto. - generalize (ireg_of_not_GPR1 r); congruence. - intros. generalize (H2 r0). - case (mreg_eq r0 r); intro. - subst r0. repeat rewrite Regmap.gss. unfold preg_of; rewrite H0. - rewrite Pregmap.gss. auto. - repeat rewrite Regmap.gso; auto. - rewrite Pregmap.gso. auto. - replace (IR (ireg_of r)) with (preg_of r). - red; intros. elim n. apply preg_of_injective; auto. - unfold preg_of. rewrite H0. auto. -Qed. -Hint Resolve agree_set_twice_mireg: ppcgen. - -Lemma agree_set_commut: - forall ms sp rs r1 r2 v1 v2, - r1 <> r2 -> - agree ms sp ((rs#r2 <- v2)#r1 <- v1) -> - agree ms sp ((rs#r1 <- v1)#r2 <- v2). -Proof. - intros. apply agree_exten_1 with ((rs#r2 <- v2)#r1 <- v1). auto. - intros. - case (preg_eq r r1); intro. - subst r1. rewrite Pregmap.gss. rewrite Pregmap.gso. rewrite Pregmap.gss. - auto. auto. - case (preg_eq r r2); intro. - subst r2. rewrite Pregmap.gss. rewrite Pregmap.gso. rewrite Pregmap.gss. - auto. auto. - repeat (rewrite Pregmap.gso; auto). -Qed. -Hint Resolve agree_set_commut: ppcgen. - -Lemma agree_nextinstr_commut: - forall ms sp rs r v, - agree ms sp (rs#r <- v) -> - r <> PC -> - agree ms sp ((nextinstr rs)#r <- v). -Proof. - intros. unfold nextinstr. apply agree_set_commut. auto. - apply agree_set_other. auto. auto. -Qed. -Hint Resolve agree_nextinstr_commut: ppcgen. - -Lemma agree_set_mireg_exten: - forall ms sp rs r v (rs': regset), - agree ms sp rs -> - mreg_type r = Tint -> - rs'#(ireg_of r) = v -> - (forall r', - r' <> IR GPR12 -> r' <> FR FPR13 -> - r' <> PC -> r' <> LR -> r' <> CTR -> - r' <> CR0_0 -> r' <> CR0_1 -> r' <> CR0_2 -> r' <> CR0_3 -> - r' <> CARRY -> - r' <> IR (ireg_of r) -> rs'#r' = rs#r') -> - agree (Regmap.set r v ms) sp rs'. -Proof. - intros. apply agree_exten_2 with (rs#(ireg_of r) <- v). - auto with ppcgen. - intros. unfold Pregmap.set. case (PregEq.eq r0 (ireg_of r)); intro. - subst r0. auto. apply H2; auto. -Qed. - -(** Useful properties of the PC and GPR0 registers. *) - -Lemma nextinstr_inv: - forall r rs, r <> PC -> (nextinstr rs)#r = rs#r. -Proof. - intros. unfold nextinstr. apply Pregmap.gso. auto. -Qed. -Hint Resolve nextinstr_inv: ppcgen. - -Lemma nextinstr_set_preg: - forall rs m v, - (nextinstr (rs#(preg_of m) <- v))#PC = Val.add rs#PC Vone. -Proof. - intros. unfold nextinstr. rewrite Pregmap.gss. - rewrite Pregmap.gso. auto. apply sym_not_eq. auto with ppcgen. -Qed. -Hint Resolve nextinstr_set_preg: ppcgen. - -Lemma gpr_or_zero_not_zero: - forall rs r, r <> GPR0 -> gpr_or_zero rs r = rs#r. -Proof. - intros. unfold gpr_or_zero. case (ireg_eq r GPR0); tauto. -Qed. -Lemma gpr_or_zero_zero: - forall rs, gpr_or_zero rs GPR0 = Vzero. -Proof. - intros. reflexivity. -Qed. -Hint Resolve gpr_or_zero_not_zero gpr_or_zero_zero: ppcgen. - -(** Connection between Mach and PPC calling conventions for external - functions. *) - -Lemma loc_external_result_match: - forall sg, - PPC.loc_external_result sg = preg_of (Conventions.loc_result sg). -Proof. - intros. destruct sg as [sargs sres]. - destruct sres. destruct t; reflexivity. reflexivity. -Qed. - -Lemma extcall_args_match: - forall ms m sp rs, - agree ms sp rs -> - forall tyl iregl fregl ofs args, - (forall r, In r iregl -> mreg_type r = Tint) -> - (forall r, In r fregl -> mreg_type r = Tfloat) -> - 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) (Stacking.fe_ofs_arg + 4 * ofs) args. -Proof. - induction tyl; intros. - inversion H2; constructor. - destruct a. - (* integer case *) - destruct iregl as [ | ir1 irl]. - (* stack *) - inversion H2; subst; clear H2. inversion H8; subst; clear H8. - constructor. replace (rs GPR1) with sp. assumption. - eapply sp_val; eauto. - change (@nil ireg) with (ireg_of ## nil). - replace (Stacking.fe_ofs_arg + 4 * ofs + 4) with (Stacking.fe_ofs_arg + 4 * (ofs + 1)) by omega. - apply IHtyl; auto. - (* register *) - inversion H2; subst; clear H2. inversion H8; subst; clear H8. - simpl map. econstructor. eapply ireg_val; eauto. - apply H0; simpl; auto. - replace (4 * ofs + 4) with (4 * (ofs + 1)) by omega. - apply IHtyl; auto. - intros; apply H0; simpl; auto. - (* float case *) - destruct fregl as [ | fr1 frl]. - (* stack *) - inversion H2; subst; clear H2. inversion H8; subst; clear H8. - constructor. replace (rs GPR1) with sp. assumption. - eapply sp_val; eauto. - change (@nil freg) with (freg_of ## nil). - replace (Stacking.fe_ofs_arg + 4 * ofs + 8) with (Stacking.fe_ofs_arg + 4 * (ofs + 2)) by omega. - apply IHtyl; auto. - (* register *) - inversion H2; subst; clear H2. inversion H8; subst; clear H8. - simpl map. econstructor. eapply freg_val; eauto. - apply H1; simpl; auto. - rewrite list_map_drop2. - apply IHtyl; auto. - intros; apply H0. apply list_drop2_incl. auto. - intros; apply H1; simpl; auto. -Qed. - -Ltac ElimOrEq := - match goal with - | |- (?x = ?y) \/ _ -> _ => - let H := fresh in - (intro H; elim H; clear H; - [intro H; rewrite <- H; clear H | ElimOrEq]) - | |- False -> _ => - let H := fresh in (intro H; contradiction) - end. - -Lemma extcall_arguments_match: - forall ms m sp rs sg args, - agree ms sp rs -> - Machconcr.extcall_arguments ms m sp sg args -> - PPC.extcall_arguments rs m sg args. -Proof. - 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) - (Stacking.fe_ofs_arg + 4 * 8) args). - eapply extcall_args_match; eauto. - intro; simpl; ElimOrEq; reflexivity. - intro; simpl; ElimOrEq; reflexivity. -Qed. - -(** * Execution of straight-line code *) - -Section STRAIGHTLINE. - -Variable ge: genv. -Variable fn: code. - -(** Straight-line code is composed of PPC instructions that execute - in sequence (no branches, no function calls and returns). - The following inductive predicate relates the machine states - before and after executing a straight-line sequence of instructions. - Instructions are taken from the first list instead of being fetched - from memory. *) - -Inductive exec_straight: code -> regset -> mem -> - code -> regset -> mem -> Prop := - | 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 -> - rs2#PC = Val.add rs1#PC Vone -> - exec_straight c rs2 m2 c' rs3 m3 -> - exec_straight (i :: c) rs1 m1 c' rs3 m3. - -Lemma exec_straight_trans: - forall c1 rs1 m1 c2 rs2 m2 c3 rs3 m3, - exec_straight c1 rs1 m1 c2 rs2 m2 -> - exec_straight c2 rs2 m2 c3 rs3 m3 -> - exec_straight c1 rs1 m1 c3 rs3 m3. -Proof. - induction 1; intros. - apply exec_straight_step with rs2 m2; auto. - apply exec_straight_step with rs2 m2; auto. -Qed. - -Lemma exec_straight_two: - forall i1 i2 c rs1 m1 rs2 m2 rs3 m3, - exec_instr ge fn i1 rs1 m1 = OK rs2 m2 -> - exec_instr ge fn i2 rs2 m2 = OK rs3 m3 -> - rs2#PC = Val.add rs1#PC Vone -> - rs3#PC = Val.add rs2#PC Vone -> - exec_straight (i1 :: i2 :: c) rs1 m1 c rs3 m3. -Proof. - intros. apply exec_straight_step with rs2 m2; auto. - apply exec_straight_one; auto. -Qed. - -Lemma exec_straight_three: - forall i1 i2 i3 c rs1 m1 rs2 m2 rs3 m3 rs4 m4, - exec_instr ge fn i1 rs1 m1 = OK rs2 m2 -> - exec_instr ge fn i2 rs2 m2 = OK rs3 m3 -> - exec_instr ge fn i3 rs3 m3 = OK rs4 m4 -> - rs2#PC = Val.add rs1#PC Vone -> - rs3#PC = Val.add rs2#PC Vone -> - rs4#PC = Val.add rs3#PC Vone -> - exec_straight (i1 :: i2 :: i3 :: c) rs1 m1 c rs4 m4. -Proof. - intros. apply exec_straight_step with rs2 m2; auto. - eapply exec_straight_two; eauto. -Qed. - -(** * Correctness of PowerPC constructor functions *) - -(** Properties of comparisons. *) - -Lemma compare_float_spec: - forall rs v1 v2, - let rs1 := nextinstr (compare_float rs v1 v2) in - rs1#CR0_0 = Val.cmpf Clt v1 v2 - /\ rs1#CR0_1 = Val.cmpf Cgt v1 v2 - /\ rs1#CR0_2 = Val.cmpf Ceq v1 v2 - /\ forall r', r' <> PC -> r' <> CR0_0 -> r' <> CR0_1 -> - r' <> CR0_2 -> r' <> CR0_3 -> rs1#r' = rs#r'. -Proof. - intros. unfold rs1. - split. reflexivity. - split. reflexivity. - split. reflexivity. - intros. rewrite nextinstr_inv; auto. - unfold compare_float. repeat (rewrite Pregmap.gso; auto). -Qed. - -Lemma compare_sint_spec: - forall rs v1 v2, - let rs1 := nextinstr (compare_sint rs v1 v2) in - rs1#CR0_0 = Val.cmp Clt v1 v2 - /\ rs1#CR0_1 = Val.cmp Cgt v1 v2 - /\ rs1#CR0_2 = Val.cmp Ceq v1 v2 - /\ forall r', r' <> PC -> r' <> CR0_0 -> r' <> CR0_1 -> - r' <> CR0_2 -> r' <> CR0_3 -> rs1#r' = rs#r'. -Proof. - intros. unfold rs1. - split. reflexivity. - split. reflexivity. - split. reflexivity. - intros. rewrite nextinstr_inv; auto. - unfold compare_sint. repeat (rewrite Pregmap.gso; auto). -Qed. - -Lemma compare_uint_spec: - forall rs v1 v2, - let rs1 := nextinstr (compare_uint rs v1 v2) in - rs1#CR0_0 = Val.cmpu Clt v1 v2 - /\ rs1#CR0_1 = Val.cmpu Cgt v1 v2 - /\ rs1#CR0_2 = Val.cmpu Ceq v1 v2 - /\ forall r', r' <> PC -> r' <> CR0_0 -> r' <> CR0_1 -> - r' <> CR0_2 -> r' <> CR0_3 -> rs1#r' = rs#r'. -Proof. - intros. unfold rs1. - split. reflexivity. - split. reflexivity. - split. reflexivity. - intros. rewrite nextinstr_inv; auto. - unfold compare_uint. repeat (rewrite Pregmap.gso; auto). -Qed. - -(** Loading a constant. *) - -Lemma loadimm_correct: - forall r n k rs m, - exists rs', - exec_straight (loadimm r n k) rs m k rs' m - /\ rs'#r = Vint n - /\ forall r': preg, r' <> r -> r' <> PC -> rs'#r' = rs#r'. -Proof. - intros. unfold loadimm. - case (Int.eq (high_s n) Int.zero). - (* addi *) - exists (nextinstr (rs#r <- (Vint n))). - split. apply exec_straight_one. - simpl. rewrite Int.add_commut. rewrite Int.add_zero. reflexivity. - reflexivity. - split. rewrite nextinstr_inv; auto with ppcgen. - apply Pregmap.gss. - intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto. - (* addis *) - generalize (Int.eq_spec (low_s n) Int.zero); case (Int.eq (low_s n) Int.zero); intro. - exists (nextinstr (rs#r <- (Vint n))). - split. apply exec_straight_one. - simpl. rewrite Int.add_commut. - rewrite <- H. rewrite low_high_s. reflexivity. - reflexivity. - split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. - intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto. - (* addis + ori *) - pose (rs1 := nextinstr (rs#r <- (Vint (Int.shl (high_u n) (Int.repr 16))))). - exists (nextinstr (rs1#r <- (Vint n))). - split. eapply exec_straight_two. - simpl. rewrite Int.add_commut. rewrite Int.add_zero. reflexivity. - simpl. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss. - unfold Val.or. rewrite low_high_u. reflexivity. - reflexivity. reflexivity. - split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. - intros. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. - unfold rs1. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. -Qed. - -(** Add integer immediate. *) - -Lemma addimm_1_correct: - forall r1 r2 n k rs m, - r1 <> GPR0 -> - r2 <> GPR0 -> - exists rs', - exec_straight (addimm_1 r1 r2 n k) rs m k rs' m - /\ rs'#r1 = Val.add rs#r2 (Vint n) - /\ forall r': preg, r' <> r1 -> r' <> PC -> rs'#r' = rs#r'. -Proof. - intros. unfold addimm_1. - (* addi *) - case (Int.eq (high_s n) Int.zero). - exists (nextinstr (rs#r1 <- (Val.add rs#r2 (Vint n)))). - split. apply exec_straight_one. - simpl. rewrite gpr_or_zero_not_zero; auto. - reflexivity. - split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. - intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto. - (* addis *) - generalize (Int.eq_spec (low_s n) Int.zero); case (Int.eq (low_s n) Int.zero); intro. - exists (nextinstr (rs#r1 <- (Val.add rs#r2 (Vint n)))). - split. apply exec_straight_one. - simpl. rewrite gpr_or_zero_not_zero; auto. - generalize (low_high_s n). rewrite H1. rewrite Int.add_zero. intro. - rewrite H2. auto. - reflexivity. - split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. - intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto. - (* addis + addi *) - pose (rs1 := nextinstr (rs#r1 <- (Val.add rs#r2 (Vint (Int.shl (high_s n) (Int.repr 16)))))). - exists (nextinstr (rs1#r1 <- (Val.add rs#r2 (Vint n)))). - split. apply exec_straight_two with rs1 m. - simpl. rewrite gpr_or_zero_not_zero; auto. - simpl. rewrite gpr_or_zero_not_zero; auto. - unfold rs1 at 1. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss. - rewrite Val.add_assoc. simpl. rewrite low_high_s. auto. - reflexivity. reflexivity. - split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. - intros. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. - unfold rs1. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto. -Qed. - -Lemma addimm_2_correct: - forall r1 r2 n k rs m, - r2 <> GPR12 -> - exists rs', - exec_straight (addimm_2 r1 r2 n k) rs m k rs' m - /\ rs'#r1 = Val.add rs#r2 (Vint n) - /\ forall r': preg, r' <> r1 -> r' <> GPR12 -> r' <> PC -> rs'#r' = rs#r'. -Proof. - intros. unfold addimm_2. - generalize (loadimm_correct GPR12 n (Padd r1 r2 GPR12 :: k) rs m). - intros [rs1 [EX [RES OTHER]]]. - exists (nextinstr (rs1#r1 <- (Val.add rs#r2 (Vint n)))). - split. eapply exec_straight_trans. eexact EX. - apply exec_straight_one. simpl. rewrite RES. rewrite OTHER. - auto. congruence. discriminate. - reflexivity. - split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. - intros. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. -Qed. - -Lemma addimm_correct: - forall r1 r2 n k rs m, - r2 <> GPR12 -> - exists rs', - exec_straight (addimm r1 r2 n k) rs m k rs' m - /\ rs'#r1 = Val.add rs#r2 (Vint n) - /\ forall r': preg, r' <> r1 -> r' <> GPR12 -> r' <> PC -> rs'#r' = rs#r'. -Proof. - intros. unfold addimm. - case (ireg_eq r1 GPR0); intro. - apply addimm_2_correct; auto. - case (ireg_eq r2 GPR0); intro. - apply addimm_2_correct; auto. - generalize (addimm_1_correct r1 r2 n k rs m n0 n1). - intros [rs' [EX [RES OTH]]]. exists rs'. intuition. -Qed. - -(** And integer immediate. *) - -Lemma andimm_correct: - forall r1 r2 n k (rs : regset) m, - r2 <> GPR12 -> - let v := Val.and rs#r2 (Vint n) in - exists rs', - exec_straight (andimm r1 r2 n k) rs m k rs' m - /\ rs'#r1 = v - /\ rs'#CR0_2 = Val.cmp Ceq v Vzero - /\ forall r': preg, - r' <> r1 -> r' <> GPR12 -> r' <> PC -> - r' <> CR0_0 -> r' <> CR0_1 -> r' <> CR0_2 -> r' <> CR0_3 -> - rs'#r' = rs#r'. -Proof. - intros. unfold andimm. - case (Int.eq (high_u n) Int.zero). - (* andi *) - exists (nextinstr (compare_sint (rs#r1 <- v) v Vzero)). - generalize (compare_sint_spec (rs#r1 <- v) v Vzero). - intros [A [B [C D]]]. - split. apply exec_straight_one. reflexivity. reflexivity. - split. rewrite D; try discriminate. apply Pregmap.gss. - split. auto. - intros. rewrite D; auto. apply Pregmap.gso; auto. - (* andis *) - generalize (Int.eq_spec (low_u n) Int.zero); - case (Int.eq (low_u n) Int.zero); intro. - exists (nextinstr (compare_sint (rs#r1 <- v) v Vzero)). - generalize (compare_sint_spec (rs#r1 <- v) v Vzero). - intros [A [B [C D]]]. - split. apply exec_straight_one. simpl. - generalize (low_high_u n). rewrite H0. rewrite Int.or_zero. - intro. rewrite H1. reflexivity. reflexivity. - split. rewrite D; try discriminate. apply Pregmap.gss. - split. auto. - intros. rewrite D; auto. apply Pregmap.gso; auto. - (* loadimm + and *) - generalize (loadimm_correct GPR12 n (Pand_ r1 r2 GPR12 :: k) rs m). - intros [rs1 [EX1 [RES1 OTHER1]]]. - exists (nextinstr (compare_sint (rs1#r1 <- v) v Vzero)). - generalize (compare_sint_spec (rs1#r1 <- v) v Vzero). - intros [A [B [C D]]]. - split. eapply exec_straight_trans. eexact EX1. - apply exec_straight_one. simpl. rewrite RES1. - rewrite (OTHER1 r2). reflexivity. congruence. congruence. - reflexivity. - split. rewrite D; try discriminate. apply Pregmap.gss. - split. auto. - intros. rewrite D; auto. rewrite Pregmap.gso; auto. -Qed. - -(** Or integer immediate. *) - -Lemma orimm_correct: - forall r1 (r2: ireg) n k (rs : regset) m, - let v := Val.or rs#r2 (Vint n) in - exists rs', - exec_straight (orimm r1 r2 n k) rs m k rs' m - /\ rs'#r1 = v - /\ forall r': preg, r' <> r1 -> r' <> PC -> rs'#r' = rs#r'. -Proof. - intros. unfold orimm. - case (Int.eq (high_u n) Int.zero). - (* ori *) - exists (nextinstr (rs#r1 <- v)). - split. apply exec_straight_one. reflexivity. reflexivity. - split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. - intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto. - (* oris *) - generalize (Int.eq_spec (low_u n) Int.zero); - case (Int.eq (low_u n) Int.zero); intro. - exists (nextinstr (rs#r1 <- v)). - split. apply exec_straight_one. simpl. - generalize (low_high_u n). rewrite H. rewrite Int.or_zero. - intro. rewrite H0. reflexivity. reflexivity. - split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. - intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto. - (* oris + ori *) - pose (rs1 := nextinstr (rs#r1 <- (Val.or rs#r2 (Vint (Int.shl (high_u n) (Int.repr 16)))))). - exists (nextinstr (rs1#r1 <- v)). - split. apply exec_straight_two with rs1 m. - reflexivity. simpl. unfold rs1 at 1. - rewrite nextinstr_inv; auto with ppcgen. - rewrite Pregmap.gss. rewrite Val.or_assoc. simpl. - rewrite low_high_u. reflexivity. reflexivity. reflexivity. - split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. - intros. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. - unfold rs1. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. -Qed. - -(** Xor integer immediate. *) - -Lemma xorimm_correct: - forall r1 (r2: ireg) n k (rs : regset) m, - let v := Val.xor rs#r2 (Vint n) in - exists rs', - exec_straight (xorimm r1 r2 n k) rs m k rs' m - /\ rs'#r1 = v - /\ forall r': preg, r' <> r1 -> r' <> PC -> rs'#r' = rs#r'. -Proof. - intros. unfold xorimm. - case (Int.eq (high_u n) Int.zero). - (* xori *) - exists (nextinstr (rs#r1 <- v)). - split. apply exec_straight_one. reflexivity. reflexivity. - split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. - intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto. - (* xoris *) - generalize (Int.eq_spec (low_u n) Int.zero); - case (Int.eq (low_u n) Int.zero); intro. - exists (nextinstr (rs#r1 <- v)). - split. apply exec_straight_one. simpl. - generalize (low_high_u_xor n). rewrite H. rewrite Int.xor_zero. - intro. rewrite H0. reflexivity. reflexivity. - split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. - intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto. - (* xoris + xori *) - pose (rs1 := nextinstr (rs#r1 <- (Val.xor rs#r2 (Vint (Int.shl (high_u n) (Int.repr 16)))))). - exists (nextinstr (rs1#r1 <- v)). - split. apply exec_straight_two with rs1 m. - reflexivity. simpl. unfold rs1 at 1. - rewrite nextinstr_inv; try discriminate. - rewrite Pregmap.gss. rewrite Val.xor_assoc. simpl. - rewrite low_high_u_xor. reflexivity. reflexivity. reflexivity. - split. rewrite nextinstr_inv; auto with ppcgen. - apply Pregmap.gss. - intros. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. - unfold rs1. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. -Qed. - -(** Indexed memory loads. *) - -Lemma loadind_aux_correct: - forall (base: ireg) ofs ty dst (rs: regset) m v, - Mem.loadv (chunk_of_type ty) m (Val.add rs#base (Vint ofs)) = Some v -> - mreg_type dst = ty -> - base <> GPR0 -> - exec_instr ge fn (loadind_aux base ofs ty dst) rs m = - OK (nextinstr (rs#(preg_of dst) <- v)) m. -Proof. - intros. unfold loadind_aux. unfold preg_of. rewrite H0. destruct ty. - simpl. unfold load1. rewrite gpr_or_zero_not_zero; auto. - unfold const_low. simpl in H. rewrite H. auto. - simpl. unfold load1. rewrite gpr_or_zero_not_zero; auto. - unfold const_low. simpl in H. rewrite H. auto. -Qed. - -Lemma loadind_correct: - forall (base: ireg) ofs ty dst k (rs: regset) m v, - Mem.loadv (chunk_of_type ty) m (Val.add rs#base (Vint ofs)) = Some v -> - mreg_type dst = ty -> - base <> GPR0 -> - exists rs', - exec_straight (loadind base ofs ty dst k) rs m k rs' m - /\ rs'#(preg_of dst) = v - /\ forall r, r <> PC -> r <> GPR12 -> r <> preg_of dst -> rs'#r = rs#r. -Proof. - intros. unfold loadind. - assert (preg_of dst <> PC). - unfold preg_of. case (mreg_type dst); discriminate. - (* short offset *) - case (Int.eq (high_s ofs) Int.zero). - exists (nextinstr (rs#(preg_of dst) <- v)). - split. apply exec_straight_one. apply loadind_aux_correct; auto. - unfold nextinstr. rewrite Pregmap.gss. rewrite Pregmap.gso. auto. auto. - split. rewrite nextinstr_inv; auto. apply Pregmap.gss. - intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto. - (* long offset *) - pose (rs1 := nextinstr (rs#GPR12 <- (Val.add rs#base (Vint (Int.shl (high_s ofs) (Int.repr 16)))))). - exists (nextinstr (rs1#(preg_of dst) <- v)). - split. apply exec_straight_two with rs1 m. - simpl. rewrite gpr_or_zero_not_zero; auto. - apply loadind_aux_correct. - unfold rs1. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss. - rewrite Val.add_assoc. simpl. rewrite low_high_s. assumption. - auto. discriminate. reflexivity. - unfold nextinstr. rewrite Pregmap.gss. rewrite Pregmap.gso. auto. auto. - split. rewrite nextinstr_inv; auto. apply Pregmap.gss. - intros. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. - unfold rs1. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. -Qed. - -(** Indexed memory stores. *) - -Lemma storeind_aux_correct: - forall (base: ireg) ofs ty src (rs: regset) m m', - Mem.storev (chunk_of_type ty) m (Val.add rs#base (Vint ofs)) (rs#(preg_of src)) = Some m' -> - mreg_type src = ty -> - base <> GPR0 -> - exec_instr ge fn (storeind_aux src base ofs ty) rs m = - OK (nextinstr rs) m'. -Proof. - intros. unfold storeind_aux. unfold preg_of in H. rewrite H0 in H. destruct ty. - simpl. unfold store1. rewrite gpr_or_zero_not_zero; auto. - unfold const_low. simpl in H. rewrite H. auto. - simpl. unfold store1. rewrite gpr_or_zero_not_zero; auto. - unfold const_low. simpl in H. rewrite H. auto. -Qed. - -Lemma storeind_correct: - forall (base: ireg) ofs ty src k (rs: regset) m m', - Mem.storev (chunk_of_type ty) m (Val.add rs#base (Vint ofs)) (rs#(preg_of src)) = Some m' -> - mreg_type src = ty -> - base <> GPR0 -> - exists rs', - exec_straight (storeind src base ofs ty k) rs m k rs' m' - /\ forall r, r <> PC -> r <> GPR12 -> rs'#r = rs#r. -Proof. - intros. unfold storeind. - (* short offset *) - case (Int.eq (high_s ofs) Int.zero). - exists (nextinstr rs). - split. apply exec_straight_one. apply storeind_aux_correct; auto. - reflexivity. - intros. rewrite nextinstr_inv; auto. - (* long offset *) - pose (rs1 := nextinstr (rs#GPR12 <- (Val.add rs#base (Vint (Int.shl (high_s ofs) (Int.repr 16)))))). - exists (nextinstr rs1). - split. apply exec_straight_two with rs1 m. - simpl. rewrite gpr_or_zero_not_zero; auto. - apply storeind_aux_correct; auto with ppcgen. - unfold rs1. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss. - rewrite nextinstr_inv; auto with ppcgen. - rewrite Pregmap.gso; auto with ppcgen. - rewrite Val.add_assoc. simpl. rewrite low_high_s. assumption. - reflexivity. reflexivity. - intros. rewrite nextinstr_inv; auto. - unfold rs1. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. -Qed. - -(** Float comparisons. *) - -Lemma floatcomp_correct: - forall cmp (r1 r2: freg) k rs m, - exists rs', - exec_straight (floatcomp cmp r1 r2 k) rs m k rs' m - /\ rs'#(reg_of_crbit (fst (crbit_for_fcmp cmp))) = - (if snd (crbit_for_fcmp cmp) - then Val.cmpf cmp rs#r1 rs#r2 - else Val.notbool (Val.cmpf cmp rs#r1 rs#r2)) - /\ forall r', - r' <> PC -> r' <> CR0_0 -> r' <> CR0_1 -> - r' <> CR0_2 -> r' <> CR0_3 -> rs'#r' = rs#r'. -Proof. - intros. - generalize (compare_float_spec rs rs#r1 rs#r2). - intros [A [B [C D]]]. - set (rs1 := nextinstr (compare_float rs rs#r1 rs#r2)) in *. - assert ((cmp = Ceq \/ cmp = Cne \/ cmp = Clt \/ cmp = Cgt) - \/ (cmp = Cle \/ cmp = Cge)). - case cmp; tauto. - unfold floatcomp. elim H; intro; clear H. - exists rs1. - split. generalize H0; intros [EQ|[EQ|[EQ|EQ]]]; subst cmp; - apply exec_straight_one; reflexivity. - split. - generalize H0; intros [EQ|[EQ|[EQ|EQ]]]; subst cmp; simpl; auto. - rewrite Val.negate_cmpf_eq. auto. - auto. - (* two instrs *) - exists (nextinstr (rs1#CR0_3 <- (Val.cmpf cmp rs#r1 rs#r2))). - split. elim H0; intro; subst cmp. - apply exec_straight_two with rs1 m. - reflexivity. simpl. - rewrite C; rewrite A. rewrite Val.or_commut. rewrite <- Val.cmpf_le. - reflexivity. reflexivity. reflexivity. - apply exec_straight_two with rs1 m. - reflexivity. simpl. - rewrite C; rewrite B. rewrite Val.or_commut. rewrite <- Val.cmpf_ge. - reflexivity. reflexivity. reflexivity. - split. elim H0; intro; subst cmp; simpl. - reflexivity. - reflexivity. - intros. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. -Qed. - -Ltac TypeInv := - match goal with - | H: (List.map ?f ?x = nil) |- _ => - destruct x; [clear H | simpl in H; discriminate] - | H: (List.map ?f ?x = ?hd :: ?tl) |- _ => - destruct x; simpl in H; - [ discriminate | - injection H; clear H; let T := fresh "T" in ( - intros H T; TypeInv) ] - | _ => idtac - end. - -(** Translation of conditions. *) - -Lemma transl_cond_correct_aux: - forall cond args k ms sp rs m, - map mreg_type args = type_of_condition cond -> - agree ms sp rs -> - exists rs', - exec_straight (transl_cond cond args k) rs m k rs' m - /\ rs'#(reg_of_crbit (fst (crbit_for_cond cond))) = - (if snd (crbit_for_cond cond) - then eval_condition_total cond (map ms args) - else Val.notbool (eval_condition_total cond (map ms args))) - /\ agree ms sp rs'. -Proof. - intros. destruct cond; simpl in H; TypeInv. - (* Ccomp *) - simpl. - generalize (compare_sint_spec rs ms#m0 ms#m1). - intros [A [B [C D]]]. - exists (nextinstr (compare_sint rs ms#m0 ms#m1)). - split. apply exec_straight_one. simpl. - repeat (rewrite <- (ireg_val ms sp rs); auto). - reflexivity. - split. - case c; simpl; auto; rewrite <- Val.negate_cmp; simpl; auto. - apply agree_exten_2 with rs; auto. - (* Ccompu *) - simpl. - generalize (compare_uint_spec rs ms#m0 ms#m1). - intros [A [B [C D]]]. - exists (nextinstr (compare_uint rs ms#m0 ms#m1)). - split. apply exec_straight_one. simpl. - repeat (rewrite <- (ireg_val ms sp rs); auto). - reflexivity. - split. - case c; simpl; auto; rewrite <- Val.negate_cmpu; simpl; auto. - apply agree_exten_2 with rs; auto. - (* Ccompimm *) - simpl. - case (Int.eq (high_s i) Int.zero). - generalize (compare_sint_spec rs ms#m0 (Vint i)). - intros [A [B [C D]]]. - exists (nextinstr (compare_sint rs ms#m0 (Vint i))). - split. apply exec_straight_one. simpl. - repeat (rewrite <- (ireg_val ms sp rs); auto). - reflexivity. - split. - case c; simpl; auto; rewrite <- Val.negate_cmp; simpl; auto. - apply agree_exten_2 with rs; auto. - generalize (loadimm_correct GPR12 i (Pcmpw (ireg_of m0) GPR12 :: k) rs m). - intros [rs1 [EX1 [RES1 OTH1]]]. - assert (agree ms sp rs1). apply agree_exten_2 with rs; auto. - generalize (compare_sint_spec rs1 ms#m0 (Vint i)). - intros [A [B [C D]]]. - exists (nextinstr (compare_sint rs1 ms#m0 (Vint i))). - split. eapply exec_straight_trans. eexact EX1. - apply exec_straight_one. simpl. - repeat (rewrite <- (ireg_val ms sp rs1); auto). rewrite RES1. - reflexivity. reflexivity. - split. - case c; simpl; auto; rewrite <- Val.negate_cmp; simpl; auto. - apply agree_exten_2 with rs1; auto. - (* Ccompuimm *) - simpl. - case (Int.eq (high_u i) Int.zero). - generalize (compare_uint_spec rs ms#m0 (Vint i)). - intros [A [B [C D]]]. - exists (nextinstr (compare_uint rs ms#m0 (Vint i))). - split. apply exec_straight_one. simpl. - repeat (rewrite <- (ireg_val ms sp rs); auto). - reflexivity. - split. - case c; simpl; auto; rewrite <- Val.negate_cmpu; simpl; auto. - apply agree_exten_2 with rs; auto. - generalize (loadimm_correct GPR12 i (Pcmplw (ireg_of m0) GPR12 :: k) rs m). - intros [rs1 [EX1 [RES1 OTH1]]]. - assert (agree ms sp rs1). apply agree_exten_2 with rs; auto. - generalize (compare_uint_spec rs1 ms#m0 (Vint i)). - intros [A [B [C D]]]. - exists (nextinstr (compare_uint rs1 ms#m0 (Vint i))). - split. eapply exec_straight_trans. eexact EX1. - apply exec_straight_one. simpl. - repeat (rewrite <- (ireg_val ms sp rs1); auto). rewrite RES1. - reflexivity. reflexivity. - split. - case c; simpl; auto; rewrite <- Val.negate_cmpu; simpl; auto. - apply agree_exten_2 with rs1; auto. - (* Ccompf *) - simpl. - generalize (floatcomp_correct c (freg_of m0) (freg_of m1) k rs m). - intros [rs' [EX [RES OTH]]]. - exists rs'. split. auto. - split. rewrite RES. repeat (rewrite <- (freg_val ms sp rs); auto). - apply agree_exten_2 with rs; auto. - (* Cnotcompf *) - simpl. - generalize (floatcomp_correct c (freg_of m0) (freg_of m1) k rs m). - intros [rs' [EX [RES OTH]]]. - exists rs'. split. auto. - split. rewrite RES. repeat (rewrite <- (freg_val ms sp rs); auto). - assert (forall v1 v2, Val.notbool (Val.notbool (Val.cmpf c v1 v2)) = Val.cmpf c v1 v2). - intros v1 v2; unfold Val.cmpf; destruct v1; destruct v2; auto. - apply Val.notbool_idem2. - rewrite H. - generalize RES. case (snd (crbit_for_fcmp c)); simpl; auto. - apply agree_exten_2 with rs; auto. - (* Cmaskzero *) - simpl. - generalize (andimm_correct GPR12 (ireg_of m0) i k rs m (ireg_of_not_GPR12 m0)). - intros [rs' [A [B [C D]]]]. - exists rs'. split. assumption. - split. rewrite C. rewrite <- (ireg_val ms sp rs); auto. - apply agree_exten_2 with rs; auto. - (* Cmasknotzero *) - simpl. - generalize (andimm_correct GPR12 (ireg_of m0) i k rs m (ireg_of_not_GPR12 m0)). - intros [rs' [A [B [C D]]]]. - exists rs'. split. assumption. - split. rewrite C. rewrite <- (ireg_val ms sp rs); auto. - rewrite Val.notbool_idem3. reflexivity. - apply agree_exten_2 with rs; auto. -Qed. - -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) 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))) = - (if snd (crbit_for_cond cond) - then Val.of_bool b - else Val.notbool (Val.of_bool b)) - /\ agree ms sp rs'. -Proof. - intros. rewrite <- (eval_condition_weaken _ _ _ H1). - apply transl_cond_correct_aux; auto. -Qed. - -(** Translation of arithmetic operations. *) - -Ltac TranslOpSimpl := - match goal with - | |- exists rs' : regset, - exec_straight ?c ?rs ?m ?k rs' ?m /\ - agree (Regmap.set ?res ?v ?ms) ?sp rs' => - (exists (nextinstr (rs#(ireg_of res) <- v)); - split; - [ apply exec_straight_one; - [ repeat (rewrite (ireg_val ms sp rs); auto); reflexivity - | reflexivity ] - | auto with ppcgen ]) - || - (exists (nextinstr (rs#(freg_of res) <- v)); - split; - [ apply exec_straight_one; - [ repeat (rewrite (freg_val ms sp rs); auto); reflexivity - | reflexivity ] - | auto with ppcgen ]) - end. - -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) 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. - inversion H. - (* Omove *) - simpl. exists (nextinstr (rs#(preg_of res) <- (ms r1))). - split. caseEq (mreg_type r1); intro. - apply exec_straight_one. simpl. rewrite (ireg_val ms sp rs); auto. - simpl. unfold preg_of. rewrite <- H2. rewrite H5. reflexivity. - auto with ppcgen. - apply exec_straight_one. simpl. rewrite (freg_val ms sp rs); auto. - simpl. unfold preg_of. rewrite <- H2. rewrite H5. reflexivity. - auto with ppcgen. - auto with ppcgen. - (* Other instructions *) - clear H1; clear H2; clear H4. - destruct op; simpl in H5; injection H5; clear H5; intros; - TypeInv; simpl; try (TranslOpSimpl). - (* Omove again *) - congruence. - (* Ointconst *) - generalize (loadimm_correct (ireg_of res) i k rs m). - intros [rs' [A [B C]]]. - exists rs'. split. auto. - apply agree_set_mireg_exten with rs; auto. - (* Ofloatconst *) - exists (nextinstr (rs#(freg_of res) <- (Vfloat f) #GPR12 <- Vundef)). - split. apply exec_straight_one. reflexivity. reflexivity. - auto with ppcgen. - (* Oaddrsymbol *) - change (find_symbol_offset ge i i0) with (symbol_offset ge i i0). - set (v := symbol_offset ge i i0). - pose (rs1 := nextinstr (rs#GPR12 <- (high_half v))). - exists (nextinstr (rs1#(ireg_of res) <- v)). - split. apply exec_straight_two with rs1 m. - unfold exec_instr. rewrite gpr_or_zero_zero. - unfold const_high. rewrite Val.add_commut. - rewrite high_half_zero. reflexivity. - simpl. rewrite gpr_or_zero_not_zero. 2: congruence. - unfold rs1 at 1. rewrite nextinstr_inv; auto with ppcgen. - rewrite Pregmap.gss. - fold v. rewrite Val.add_commut. unfold v. rewrite low_high_half. - reflexivity. reflexivity. reflexivity. - unfold rs1. apply agree_nextinstr. apply agree_set_mireg; auto. - apply agree_set_mreg. apply agree_nextinstr. - apply agree_set_other. auto. simpl. tauto. - (* Oaddrstack *) - assert (GPR1 <> GPR12). discriminate. - generalize (addimm_correct (ireg_of res) GPR1 i k rs m H2). - intros [rs' [EX [RES OTH]]]. - exists rs'. split. auto. - apply agree_set_mireg_exten with rs; auto. - rewrite (sp_val ms sp rs). auto. auto. - (* 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. - replace (Val.zero_ext 8 (ms m0)) - with (Val.rolm (ms m0) Int.zero (Int.repr 255)). - auto with ppcgen. - unfold Val.rolm, Val.zero_ext. destruct (ms m0); auto. - rewrite Int.rolm_zero. rewrite Int.zero_ext_and. auto. compute; auto. - (* Ocast16unsigned *) - exists (nextinstr (rs#(ireg_of res) <- (Val.rolm (ms m0) Int.zero (Int.repr 65535)))). - split. apply exec_straight_one. repeat (rewrite (ireg_val ms sp rs)); auto. reflexivity. - replace (Val.zero_ext 16 (ms m0)) - with (Val.rolm (ms m0) Int.zero (Int.repr 65535)). - auto with ppcgen. - unfold Val.rolm, Val.zero_ext. destruct (ms m0); auto. - rewrite Int.rolm_zero. rewrite Int.zero_ext_and. auto. compute; auto. - (* Oaddimm *) - generalize (addimm_correct (ireg_of res) (ireg_of m0) i k rs m - (ireg_of_not_GPR12 m0)). - intros [rs' [A [B C]]]. - exists rs'. split. auto. - apply agree_set_mireg_exten with rs; auto. - rewrite (ireg_val ms sp rs); auto. - (* Osub *) - exists (nextinstr (rs#(ireg_of res) <- (Val.sub (ms m0) (ms m1)) #CARRY <- Vundef)). - split. apply exec_straight_one. repeat (rewrite (ireg_val ms sp rs); auto). - simpl. reflexivity. auto with ppcgen. - (* Osubimm *) - case (Int.eq (high_s i) Int.zero). - exists (nextinstr (rs#(ireg_of res) <- (Val.sub (Vint i) (ms m0)) #CARRY <- Vundef)). - split. apply exec_straight_one. rewrite (ireg_val ms sp rs); auto. - reflexivity. simpl. auto with ppcgen. - generalize (loadimm_correct GPR12 i (Psubfc (ireg_of res) (ireg_of m0) GPR12 :: k) rs m). - intros [rs1 [EX [RES OTH]]]. - assert (agree ms sp rs1). apply agree_exten_2 with rs; auto. - exists (nextinstr (rs1#(ireg_of res) <- (Val.sub (Vint i) (ms m0)) #CARRY <- Vundef)). - split. eapply exec_straight_trans. eexact EX. - apply exec_straight_one. repeat (rewrite (ireg_val ms sp rs); auto). - simpl. rewrite RES. rewrite OTH. reflexivity. - generalize (ireg_of_not_GPR12 m0); congruence. - discriminate. - reflexivity. simpl; auto with ppcgen. - (* Omulimm *) - case (Int.eq (high_s i) Int.zero). - exists (nextinstr (rs#(ireg_of res) <- (Val.mul (ms m0) (Vint i)))). - split. apply exec_straight_one. rewrite (ireg_val ms sp rs); auto. - reflexivity. auto with ppcgen. - generalize (loadimm_correct GPR12 i (Pmullw (ireg_of res) (ireg_of m0) GPR12 :: k) rs m). - intros [rs1 [EX [RES OTH]]]. - assert (agree ms sp rs1). apply agree_exten_2 with rs; auto. - exists (nextinstr (rs1#(ireg_of res) <- (Val.mul (ms m0) (Vint i)))). - split. eapply exec_straight_trans. eexact EX. - apply exec_straight_one. repeat (rewrite (ireg_val ms sp rs); auto). - simpl. rewrite RES. rewrite OTH. reflexivity. - generalize (ireg_of_not_GPR12 m0); congruence. - discriminate. - reflexivity. simpl; auto with ppcgen. - (* Oand *) - pose (v := Val.and (ms m0) (ms m1)). - pose (rs1 := rs#(ireg_of res) <- v). - generalize (compare_sint_spec rs1 v Vzero). - intros [A [B [C D]]]. - exists (nextinstr (compare_sint rs1 v Vzero)). - split. apply exec_straight_one. - unfold rs1, v. repeat (rewrite (ireg_val ms sp rs); auto). - reflexivity. - apply agree_exten_2 with rs1. unfold rs1, v; auto with ppcgen. - auto. - (* Oandimm *) - generalize (andimm_correct (ireg_of res) (ireg_of m0) i k rs m - (ireg_of_not_GPR12 m0)). - intros [rs' [A [B [C D]]]]. - exists rs'. split. auto. apply agree_set_mireg_exten with rs; auto. - rewrite (ireg_val ms sp rs); auto. - (* Oorimm *) - generalize (orimm_correct (ireg_of res) (ireg_of m0) i k rs m). - intros [rs' [A [B C]]]. - exists rs'. split. auto. apply agree_set_mireg_exten with rs; auto. - rewrite (ireg_val ms sp rs); auto. - (* Oxorimm *) - generalize (xorimm_correct (ireg_of res) (ireg_of m0) i k rs m). - intros [rs' [A [B C]]]. - exists rs'. split. auto. apply agree_set_mireg_exten with rs; auto. - rewrite (ireg_val ms sp rs); auto. - (* Oshr *) - exists (nextinstr (rs#(ireg_of res) <- (Val.shr (ms m0) (ms m1)) #CARRY <- (Val.shr_carry (ms m0) (ms m1)))). - split. apply exec_straight_one. repeat (rewrite (ireg_val ms sp rs); auto). - reflexivity. auto with ppcgen. - (* Oshrimm *) - exists (nextinstr (rs#(ireg_of res) <- (Val.shr (ms m0) (Vint i)) #CARRY <- (Val.shr_carry (ms m0) (Vint i)))). - split. apply exec_straight_one. repeat (rewrite (ireg_val ms sp rs); auto). - reflexivity. auto with ppcgen. - (* Oxhrximm *) - pose (rs1 := nextinstr (rs#(ireg_of res) <- (Val.shr (ms m0) (Vint i)) #CARRY <- (Val.shr_carry (ms m0) (Vint i)))). - exists (nextinstr (rs1#(ireg_of res) <- (Val.shrx (ms m0) (Vint i)))). - split. apply exec_straight_two with rs1 m. - unfold rs1; rewrite (ireg_val ms sp rs); auto. - simpl; unfold rs1; repeat rewrite <- (ireg_val ms sp rs); auto. - repeat (rewrite nextinstr_inv; try discriminate). - repeat rewrite Pregmap.gss. decEq. decEq. - apply (f_equal3 (@Pregmap.set val)); auto. - rewrite Pregmap.gso. rewrite Pregmap.gss. apply Val.shrx_carry. - discriminate. reflexivity. reflexivity. - apply agree_exten_2 with (rs#(ireg_of res) <- (Val.shrx (ms m0) (Vint i))). - auto with ppcgen. - intros. rewrite nextinstr_inv; auto. - case (preg_eq (ireg_of res) r); intro. - subst r. repeat rewrite Pregmap.gss. auto. - repeat rewrite Pregmap.gso; auto. - unfold rs1. rewrite nextinstr_inv; auto. - repeat rewrite Pregmap.gso; auto. - (* Ointoffloat *) - exists (nextinstr (rs#(ireg_of res) <- (Val.intoffloat (ms m0)) #FPR13 <- Vundef)). - split. apply exec_straight_one. - repeat (rewrite (freg_val ms sp rs); auto). - reflexivity. auto with ppcgen. - (* Ointuoffloat *) - exists (nextinstr (rs#(ireg_of res) <- (Val.intuoffloat (ms m0)) #FPR13 <- Vundef)). - split. apply exec_straight_one. - repeat (rewrite (freg_val ms sp rs); auto). - reflexivity. auto with ppcgen. - (* Ofloatofint *) - exists (nextinstr (rs#(freg_of res) <- (Val.floatofint (ms m0)) #GPR12 <- Vundef #FPR13 <- Vundef)). - split. apply exec_straight_one. - repeat (rewrite (ireg_val ms sp rs); auto). - reflexivity. auto 10 with ppcgen. - (* Ofloatofintu *) - exists (nextinstr (rs#(freg_of res) <- (Val.floatofintu (ms m0)) #GPR12 <- Vundef #FPR13 <- Vundef)). - split. apply exec_straight_one. - repeat (rewrite (ireg_val ms sp rs); auto). - reflexivity. auto 10 with ppcgen. - (* Ocmp *) - set (bit := fst (crbit_for_cond c)). - set (isset := snd (crbit_for_cond c)). - set (k1 := - Pmfcrbit (ireg_of res) bit :: - (if isset - then k - else Pxori (ireg_of res) (ireg_of res) (Cint Int.one) :: k)). - generalize (transl_cond_correct_aux c args k1 ms sp rs m H2 H0). - fold bit; fold isset. - intros [rs1 [EX1 [RES1 AG1]]]. - set (rs2 := nextinstr (rs1#(ireg_of res) <- (rs1#(reg_of_crbit bit)))). - destruct isset. - exists rs2. - split. apply exec_straight_trans with k1 rs1 m. assumption. - unfold k1. apply exec_straight_one. - reflexivity. reflexivity. - unfold rs2. rewrite RES1. auto with ppcgen. - exists (nextinstr (rs2#(ireg_of res) <- (eval_condition_total c ms##args))). - split. apply exec_straight_trans with k1 rs1 m. assumption. - unfold k1. apply exec_straight_two with rs2 m. - reflexivity. simpl. - replace (Val.xor (rs2 (ireg_of res)) (Vint Int.one)) - with (eval_condition_total c ms##args). - reflexivity. - unfold rs2. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss. - rewrite RES1. apply Val.notbool_xor. apply eval_condition_total_is_bool. - reflexivity. reflexivity. - unfold rs2. auto with ppcgen. -Qed. - -Lemma transl_load_store_correct: - forall (mk1: constant -> ireg -> instruction) (mk2: ireg -> ireg -> instruction) - addr args k ms sp rs m ms' m', - (forall cst (r1: ireg) (rs1: regset) k, - eval_addressing_total ge sp addr (map ms args) = Val.add rs1#r1 (const_low ge cst) -> - agree ms sp rs1 -> - r1 <> GPR0 -> - exists rs', - exec_straight (mk1 cst r1 :: k) rs1 m k rs' m' /\ - agree ms' sp rs') -> - (forall (r1 r2: ireg) (rs1: regset) k, - eval_addressing_total ge sp addr (map ms args) = Val.add rs1#r1 rs1#r2 -> - agree ms sp rs1 -> - exists rs', - exec_straight (mk2 r1 r2 :: k) rs1 m k rs' m' /\ - agree ms' sp rs') -> - agree ms sp rs -> - map mreg_type args = type_of_addressing addr -> - exists rs', - exec_straight (transl_load_store mk1 mk2 addr args k) rs m - k rs' m' - /\ agree ms' sp rs'. -Proof. - intros. destruct addr; simpl in H2; TypeInv; simpl. - (* Aindexed *) - case (ireg_eq (ireg_of t) GPR0); intro. - (* Aindexed from GPR0 *) - set (rs1 := nextinstr (rs#GPR12 <- (ms t))). - set (rs2 := nextinstr (rs1#GPR12 <- (Val.add (ms t) (Vint (Int.shl (high_s i) (Int.repr 16)))))). - assert (ADDR: eval_addressing_total ge sp (Aindexed i) ms##(t :: nil) = - Val.add rs2#GPR12 (const_low ge (Cint (low_s i)))). - simpl. unfold rs2. rewrite nextinstr_inv. rewrite Pregmap.gss. - rewrite Val.add_assoc. simpl. rewrite low_high_s. auto. - discriminate. - assert (AG: agree ms sp rs2). unfold rs2, rs1; auto 6 with ppcgen. - assert (NOT0: GPR12 <> GPR0). discriminate. - generalize (H _ _ _ k ADDR AG NOT0). - intros [rs' [EX' AG']]. - exists rs'. split. - apply exec_straight_trans with (mk1 (Cint (low_s i)) GPR12 :: k) rs2 m. - apply exec_straight_two with rs1 m. - unfold rs1. rewrite (ireg_val ms sp rs); auto. - unfold rs2. replace (ms t) with (rs1#GPR12). auto. - unfold rs1. rewrite nextinstr_inv. apply Pregmap.gss. discriminate. - reflexivity. reflexivity. - assumption. assumption. - (* Aindexed short *) - case (Int.eq (high_s i) Int.zero). - assert (ADDR: eval_addressing_total ge sp (Aindexed i) ms##(t :: nil) = - Val.add rs#(ireg_of t) (const_low ge (Cint i))). - simpl. rewrite (ireg_val ms sp rs); auto. - generalize (H _ _ _ k ADDR H1 n). intros [rs' [EX' AG']]. - exists rs'. split. auto. auto. - (* Aindexed long *) - set (rs1 := nextinstr (rs#GPR12 <- (Val.add (ms t) (Vint (Int.shl (high_s i) (Int.repr 16)))))). - assert (ADDR: eval_addressing_total ge sp (Aindexed i) ms##(t :: nil) = - Val.add rs1#GPR12 (const_low ge (Cint (low_s i)))). - simpl. unfold rs1. rewrite nextinstr_inv. rewrite Pregmap.gss. - rewrite Val.add_assoc. simpl. rewrite low_high_s. auto. - discriminate. - assert (AG: agree ms sp rs1). unfold rs1; auto with ppcgen. - assert (NOT0: GPR12 <> GPR0). discriminate. - generalize (H _ _ _ k ADDR AG NOT0). intros [rs' [EX' AG']]. - exists rs'. split. apply exec_straight_step with rs1 m. - simpl. rewrite gpr_or_zero_not_zero; auto. - rewrite <- (ireg_val ms sp rs); auto. reflexivity. - assumption. assumption. - (* Aindexed2 *) - apply H0. - simpl. repeat (rewrite (ireg_val ms sp rs); auto). auto. - (* Aglobal *) - set (rs1 := nextinstr (rs#GPR12 <- (const_high ge (Csymbol_high i i0)))). - assert (ADDR: eval_addressing_total ge sp (Aglobal i i0) ms##nil = - Val.add rs1#GPR12 (const_low ge (Csymbol_low i i0))). - simpl. unfold rs1. rewrite nextinstr_inv. rewrite Pregmap.gss. - unfold const_high, const_low. - set (v := symbol_offset ge i i0). - symmetry. rewrite Val.add_commut. unfold v. apply low_high_half. - discriminate. - assert (AG: agree ms sp rs1). unfold rs1; auto with ppcgen. - assert (NOT0: GPR12 <> GPR0). discriminate. - generalize (H _ _ _ k ADDR AG NOT0). intros [rs' [EX' AG']]. - exists rs'. split. apply exec_straight_step with rs1 m. - unfold exec_instr. rewrite gpr_or_zero_zero. - rewrite Val.add_commut. unfold const_high. - rewrite high_half_zero. - reflexivity. reflexivity. - assumption. assumption. - (* Abased *) - assert (COMMON: - forall (rs1: regset) r, - r <> GPR0 -> - ms t = rs1#r -> - agree ms sp rs1 -> - exists rs', - exec_straight - (Paddis GPR12 r (Csymbol_high i i0) - :: mk1 (Csymbol_low i i0) GPR12 :: k) rs1 m k rs' m' - /\ agree ms' sp rs'). - intros. - set (rs2 := nextinstr (rs1#GPR12 <- (Val.add (ms t) (const_high ge (Csymbol_high i i0))))). - assert (ADDR: eval_addressing_total ge sp (Abased i i0) ms##(t::nil) = - Val.add rs2#GPR12 (const_low ge (Csymbol_low i i0))). - simpl. unfold rs2. rewrite nextinstr_inv. rewrite Pregmap.gss. - unfold const_high. - set (v := symbol_offset ge i i0). - rewrite Val.add_assoc. - rewrite (Val.add_commut (high_half v)). - unfold v. rewrite low_high_half. apply Val.add_commut. - discriminate. - assert (AG: agree ms sp rs2). unfold rs2; auto with ppcgen. - assert (NOT0: GPR12 <> GPR0). discriminate. - generalize (H _ _ _ k ADDR AG NOT0). intros [rs' [EX' AG']]. - exists rs'. split. apply exec_straight_step with rs2 m. - unfold exec_instr. rewrite gpr_or_zero_not_zero; auto. - rewrite <- H3. reflexivity. reflexivity. - assumption. assumption. - case (ireg_eq (ireg_of t) GPR0); intro. - set (rs1 := nextinstr (rs#GPR12 <- (ms t))). - assert (R1: GPR12 <> GPR0). discriminate. - assert (R2: ms t = rs1 GPR12). - unfold rs1. rewrite nextinstr_inv. rewrite Pregmap.gss; auto. - discriminate. - assert (R3: agree ms sp rs1). unfold rs1; auto with ppcgen. - generalize (COMMON rs1 GPR12 R1 R2 R3). intros [rs' [EX' AG']]. - exists rs'. split. - apply exec_straight_step with rs1 m. - unfold rs1. rewrite (ireg_val ms sp rs); auto. reflexivity. - assumption. assumption. - apply COMMON; auto. eapply ireg_val; eauto. - (* Ainstack *) - case (Int.eq (high_s i) Int.zero). - apply H. simpl. rewrite (sp_val ms sp rs); auto. auto. - discriminate. - set (rs1 := nextinstr (rs#GPR12 <- (Val.add sp (Vint (Int.shl (high_s i) (Int.repr 16)))))). - assert (ADDR: eval_addressing_total ge sp (Ainstack i) ms##nil = - Val.add rs1#GPR12 (const_low ge (Cint (low_s i)))). - simpl. unfold rs1. rewrite nextinstr_inv. rewrite Pregmap.gss. - rewrite Val.add_assoc. decEq. simpl. rewrite low_high_s. auto. - discriminate. - assert (AG: agree ms sp rs1). unfold rs1; auto with ppcgen. - assert (NOT0: GPR12 <> GPR0). discriminate. - generalize (H _ _ _ k ADDR AG NOT0). intros [rs' [EX' AG']]. - exists rs'. split. apply exec_straight_step with rs1 m. - simpl. rewrite gpr_or_zero_not_zero. - unfold rs1. rewrite (sp_val ms sp rs). reflexivity. - auto. discriminate. reflexivity. assumption. assumption. -Qed. - -(** Translation of memory loads. *) - -Lemma transl_load_correct: - forall (mk1: constant -> ireg -> instruction) (mk2: ireg -> ireg -> instruction) - chunk addr args k ms sp rs m dst a v, - (forall cst (r1: ireg) (rs1: regset), - exec_instr ge fn (mk1 cst r1) rs1 m = - load1 ge chunk (preg_of dst) cst r1 rs1 m) -> - (forall (r1 r2: ireg) (rs1: regset), - exec_instr ge fn (mk2 r1 r2) rs1 m = - load2 chunk (preg_of dst) r1 r2 rs1 m) -> - agree ms sp rs -> - map mreg_type args = type_of_addressing addr -> - eval_addressing ge sp addr (map ms args) = Some a -> - Mem.loadv chunk m a = Some v -> - exists rs', - exec_straight (transl_load_store mk1 mk2 addr args k) rs m - k rs' m - /\ agree (Regmap.set dst v ms) sp rs'. -Proof. - intros. apply transl_load_store_correct with ms. - intros. exists (nextinstr (rs1#(preg_of dst) <- v)). - split. apply exec_straight_one. rewrite H. - unfold load1. rewrite gpr_or_zero_not_zero; auto. - rewrite <- (eval_addressing_weaken _ _ _ _ H3) in H4. - rewrite H5 in H4. rewrite H4. auto. - auto with ppcgen. auto with ppcgen. - intros. exists (nextinstr (rs1#(preg_of dst) <- v)). - split. apply exec_straight_one. rewrite H0. - unfold load2. - rewrite <- (eval_addressing_weaken _ _ _ _ H3) in H4. - rewrite H5 in H4. rewrite H4. auto. - auto with ppcgen. auto with ppcgen. - auto. auto. -Qed. - -(** Translation of memory stores. *) - -Lemma transl_store_correct: - forall (mk1: constant -> ireg -> instruction) (mk2: ireg -> ireg -> instruction) - chunk addr args k ms sp rs m src a m', - (forall cst (r1: ireg) (rs1: regset), - exec_instr ge fn (mk1 cst r1) rs1 m = - store1 ge chunk (preg_of src) cst r1 rs1 m) -> - (forall (r1 r2: ireg) (rs1: regset), - exec_instr ge fn (mk2 r1 r2) rs1 m = - store2 chunk (preg_of src) r1 r2 rs1 m) -> - agree ms sp rs -> - map mreg_type args = type_of_addressing addr -> - eval_addressing ge sp addr (map ms args) = Some a -> - Mem.storev chunk m a (ms src) = Some m' -> - exists rs', - exec_straight (transl_load_store mk1 mk2 addr args k) rs m - k rs' m' - /\ agree ms sp rs'. -Proof. - intros. apply transl_load_store_correct with ms. - intros. exists (nextinstr rs1). - split. apply exec_straight_one. rewrite H. - unfold store1. rewrite gpr_or_zero_not_zero; auto. - rewrite <- (eval_addressing_weaken _ _ _ _ H3) in H4. - rewrite H5 in H4. elim H6; intros. rewrite H9 in H4. - rewrite H4. auto. - auto with ppcgen. auto with ppcgen. - intros. exists (nextinstr rs1). - split. apply exec_straight_one. rewrite H0. - unfold store2. - rewrite <- (eval_addressing_weaken _ _ _ _ H3) in H4. - rewrite H5 in H4. elim H6; intros. rewrite H8 in H4. - rewrite H4. auto. - auto with ppcgen. auto with ppcgen. - auto. auto. -Qed. - -(** Translation of allocations *) - -Lemma transl_alloc_correct: - forall ms sp rs sz m m' blk k, - agree ms sp rs -> - ms Conventions.loc_alloc_argument = Vint sz -> - Mem.alloc m 0 (Int.signed sz) = (m', blk) -> - let ms' := Regmap.set Conventions.loc_alloc_result (Vptr blk Int.zero) ms in - exists rs', - exec_straight (Pallocblock :: k) rs m k rs' m' - /\ agree ms' sp rs'. -Proof. - intros. - pose (rs' := nextinstr (rs#GPR3 <- (Vptr blk Int.zero) #LR <- (Val.add rs#PC Vone))). - exists rs'; split. - apply exec_straight_one. unfold exec_instr. - generalize (preg_val _ _ _ Conventions.loc_alloc_argument H). - unfold preg_of; intro. simpl in H2. rewrite <- H2. rewrite H0. - rewrite H1. reflexivity. - reflexivity. - unfold ms', rs'. apply agree_nextinstr. apply agree_set_other. - change (IR GPR3) with (preg_of Conventions.loc_alloc_result). - apply agree_set_mreg. auto. - simpl. tauto. -Qed. - -End STRAIGHTLINE. - diff --git a/backend/PPCgenretaddr.v b/backend/PPCgenretaddr.v deleted file mode 100644 index eab8599..0000000 --- a/backend/PPCgenretaddr.v +++ /dev/null @@ -1,188 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** 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 f 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 f i k, is_tail k (transl_instr f 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 f c1 c2, is_tail c1 c2 -> is_tail (transl_code f c1) (transl_code f 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 f 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/RTLgenaux.ml b/backend/RTLgenaux.ml new file mode 100644 index 0000000..4c1fc05 --- /dev/null +++ b/backend/RTLgenaux.ml @@ -0,0 +1,72 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +open Camlcoq +open 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 + | [] -> [] + | 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 minval maxval = + match hi - lo with + | 0 -> + CTaction default + | 1 -> + let (key, act) = sw.(lo) in + if Integers.Int.sub maxval minval = Integers.Int.zero + then CTaction act + else CTifeq(key, act, CTaction default) + | 2 -> + let (key1, act1) = sw.(lo) + and (key2, act2) = sw.(lo+1) in + CTifeq(key1, act1, + if Integers.Int.sub maxval minval = Integers.Int.one + then CTaction act2 + else CTifeq(key2, act2, CTaction default)) + | 3 -> + let (key1, act1) = sw.(lo) + and (key2, act2) = sw.(lo+1) + and (key3, act3) = sw.(lo+2) in + CTifeq(key1, act1, + CTifeq(key2, act2, + if Integers.Int.sub maxval minval = coqint_of_camlint 2l + then CTaction act3 + else CTifeq(key3, act3, CTaction default))) + | _ -> + let mid = (lo + hi) / 2 in + let (pivot, _) = sw.(mid) in + CTiflt(pivot, + build lo mid minval (Integers.Int.sub pivot Integers.Int.one), + build mid hi pivot maxval) + in build 0 (Array.length sw) Integers.Int.zero Integers.Int.max_unsigned diff --git a/backend/RTLtypingaux.ml b/backend/RTLtypingaux.ml new file mode 100644 index 0000000..ff704eb --- /dev/null +++ b/backend/RTLtypingaux.ml @@ -0,0 +1,156 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(* Type inference for RTL *) + +open Datatypes +open CList +open Camlcoq +open Maps +open AST +open Op +open Registers +open RTL + +exception Type_error of string + +let env = ref (PTree.empty : typ PTree.t) + +let set_type r ty = + match PTree.get r !env with + | None -> env := PTree.set r ty !env + | Some ty' -> if ty <> ty' then raise (Type_error "type mismatch") + +let rec set_types rl tyl = + match rl, tyl with + | [], [] -> () + | r1 :: rs, ty1 :: tys -> set_type r1 ty1; set_types rs tys + | _, _ -> raise (Type_error "arity mismatch") + +(* First pass: process constraints of the form typeof(r) = ty *) + +let type_instr retty (Coq_pair(pc, i)) = + match i with + | Inop(_) -> + () + | Iop(Omove, _, _, _) -> + () + | Iop(op, args, res, _) -> + let (Coq_pair(targs, tres)) = type_of_operation op in + set_types args targs; set_type res tres + | Iload(chunk, addr, args, dst, _) -> + set_types args (type_of_addressing addr); + set_type dst (type_of_chunk chunk) + | Istore(chunk, addr, args, src, _) -> + set_types args (type_of_addressing addr); + set_type src (type_of_chunk chunk) + | Icall(sg, ros, args, res, _) -> + begin try + begin match ros with + | Coq_inl r -> set_type r Tint + | Coq_inr _ -> () + end; + set_types args sg.sig_args; + set_type res (match sg.sig_res with None -> Tint | Some ty -> ty) + 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 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, _, _) -> + set_types args (type_of_condition cond) + | Ireturn(optres) -> + begin match optres, retty with + | None, None -> () + | Some r, Some ty -> set_type r ty + | _, _ -> raise (Type_error "type mismatch in Ireturn") + end + +let type_pass1 retty instrs = + List.iter (type_instr retty) instrs + +(* Second pass: extract move constraints typeof(r1) = typeof(r2) + and solve them iteratively *) + +let rec extract_moves = function + | [] -> [] + | Coq_pair(pc, i) :: rem -> + match i with + | Iop(Omove, [r1], r2, _) -> + (r1, r2) :: extract_moves rem + | Iop(Omove, _, _, _) -> + raise (Type_error "wrong Omove") + | _ -> + extract_moves rem + +let changed = ref false + +let rec solve_moves = function + | [] -> [] + | (r1, r2) :: rem -> + match (PTree.get r1 !env, PTree.get r2 !env) with + | Some ty1, Some ty2 -> + if ty1 = ty2 + then (changed := true; solve_moves rem) + else raise (Type_error "type mismatch in Omove") + | Some ty1, None -> + env := PTree.set r2 ty1 !env; changed := true; solve_moves rem + | None, Some ty2 -> + env := PTree.set r1 ty2 !env; changed := true; solve_moves rem + | None, None -> + (r1, r2) :: solve_moves rem + +let rec iter_solve_moves mvs = + changed := false; + let mvs' = solve_moves mvs in + if !changed then iter_solve_moves mvs' + +let type_pass2 instrs = + iter_solve_moves (extract_moves instrs) + +let typeof e r = + match PTree.get r e with Some ty -> ty | None -> Tint + +let infer_type_environment f instrs = + try + env := PTree.empty; + set_types f.fn_params f.fn_sig.sig_args; + type_pass1 f.fn_sig.sig_res instrs; + type_pass2 instrs; + let e = !env in + env := PTree.empty; + Some(typeof e) + with Type_error msg -> + Printf.eprintf "Error during RTL type inference: %s\n" msg; + None diff --git a/backend/Reloadproof.v b/backend/Reloadproof.v index 3a96d3a..5a3acd3 100644 --- a/backend/Reloadproof.v +++ b/backend/Reloadproof.v @@ -1017,7 +1017,7 @@ Proof. intros [ls2 [A [B C]]]. assert (exists ta, eval_addressing tge sp addr (reglist ls2 (regs_for args)) = Some ta /\ Val.lessdef a ta). - apply eval_addressing_lessdef with (map rs args); auto. + apply eval_addressing_lessdef with (map rs args). rewrite B. eapply agree_locs; eauto. rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. destruct H1 as [ta [P Q]]. @@ -1047,7 +1047,7 @@ Proof. simpl in B. assert (exists ta, eval_addressing tge sp addr (reglist ls2 rargs) = Some ta /\ Val.lessdef a ta). - apply eval_addressing_lessdef with (map rs args); auto. + apply eval_addressing_lessdef with (map rs args). rewrite D. eapply agree_locs; eauto. rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. destruct H1 as [ta [P Q]]. @@ -1072,7 +1072,7 @@ Proof. apply locs_acceptable_disj_temporaries; auto. assert (exists ta, eval_addressing tge sp addr (reglist ls2 (regs_for args)) = Some ta /\ Val.lessdef a ta). - apply eval_addressing_lessdef with (map rs args); auto. + apply eval_addressing_lessdef with (map rs args). rewrite B. eapply agree_locs; eauto. rewrite <- H. apply eval_addressing_preserved. exact symbols_preserved. destruct H1 as [ta [P Q]]. diff --git a/backend/Selection.v b/backend/Selection.v deleted file mode 100644 index 1de6ae3..0000000 --- a/backend/Selection.v +++ /dev/null @@ -1,1196 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** 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) - | 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 - 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 *) - -Parameter use_fused_mul : unit -> bool. - -(* -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) := - if use_fused_mul tt then - match addf_match e1 e2 with - | addf_case1 t1 t2 t3 => - Eop Omuladdf (t1:::t2:::t3:::Enil) - | addf_case2 t1 t2 t3 => - Eop Omuladdf (t2:::t3:::t1:::Enil) - | addf_default e1 e2 => - Eop Oaddf (e1:::e2:::Enil) - end - else Eop Oaddf (e1:::e2:::Enil). - -(* -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) := - if use_fused_mul tt then - 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 - else Eop Osubf (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 *) - -Inductive comp_cases: forall (e1: expr) (e2: expr), Set := - | comp_case1: - forall n1 t2, - comp_cases (Eop (Ointconst n1) Enil) (t2) - | comp_case2: - forall t1 n2, - comp_cases (t1) (Eop (Ointconst n2) Enil) - | comp_default: - forall (e1: expr) (e2: expr), - comp_cases e1 e2. - -Definition comp_match (e1: expr) (e2: expr) := - match e1 as z1, e2 as z2 return comp_cases z1 z2 with - | Eop (Ointconst n1) Enil, t2 => - comp_case1 n1 t2 - | t1, Eop (Ointconst n2) Enil => - comp_case2 t1 n2 - | e1, e2 => - comp_default e1 e2 - end. - -Definition comp (c: comparison) (e1: expr) (e2: expr) := - match comp_match e1 e2 with - | comp_case1 n1 t2 => - Eop (Ocmp (Ccompimm (swap_comparison c) n1)) (t2 ::: Enil) - | comp_case2 t1 n2 => - Eop (Ocmp (Ccompimm c n2)) (t1 ::: Enil) - | comp_default e1 e2 => - Eop (Ocmp (Ccomp c)) (e1 ::: e2 ::: Enil) - end. - -Definition compu (c: comparison) (e1: expr) (e2: expr) := - match comp_match e1 e2 with - | comp_case1 n1 t2 => - Eop (Ocmp (Ccompuimm (swap_comparison c) n1)) (t2 ::: Enil) - | comp_case2 t1 n2 => - Eop (Ocmp (Ccompuimm c n2)) (t1 ::: Enil) - | comp_default e1 e2 => - Eop (Ocmp (Ccompu c)) (e1 ::: e2 ::: Enil) - end. - -Definition compf (c: comparison) (e1: expr) (e2: expr) := - Eop (Ocmp (Ccompf c)) (e1 ::: e2 ::: Enil). - -(** ** Conditional expressions *) - -Fixpoint negate_condexpr (e: condexpr): condexpr := - match e with - | CEtrue => CEfalse - | CEfalse => CEtrue - | CEcond c el => CEcond (negate_condition c) el - | CEcondition e1 e2 e3 => - CEcondition e1 (negate_condexpr e2) (negate_condexpr e3) - end. - - -Definition is_compare_neq_zero (c: condition) : bool := - match c with - | Ccompimm Cne n => Int.eq n Int.zero - | Ccompuimm Cne n => Int.eq n Int.zero - | _ => false - end. - -Definition is_compare_eq_zero (c: condition) : bool := - match c with - | Ccompimm Ceq n => Int.eq n Int.zero - | Ccompuimm Ceq n => Int.eq n Int.zero - | _ => false - end. - -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) (e1 ::: Enil) => - if is_compare_neq_zero c then - condexpr_of_expr e1 - else if is_compare_eq_zero c then - negate_condexpr (condexpr_of_expr e1) - else - CEcond c (e1 ::: Enil) - | Eop (Ocmp c) el => - CEcond c el - | Econdition ce e1 e2 => - CEcondition ce (condexpr_of_expr e1) (condexpr_of_expr e2) - | _ => - 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) => Sstore 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.Ointuoffloat => Eop Ointuoffloat (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 => comp c arg1 arg2 - | Cminor.Ocmpu c => compu c arg1 arg2 - | Cminor.Ocmpf c => compf c arg1 arg2 - 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.Econdition cond ifso ifnot => - Econdition (condexpr_of_expr (sel_expr cond)) - (sel_expr ifso) (sel_expr ifnot) - end. - -Fixpoint sel_exprlist (al: list Cminor.expr) : exprlist := - match al with - | nil => Enil - | 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.Sassign id e => Sassign id (sel_expr e) - | Cminor.Sstore chunk addr rhs => store chunk (sel_expr addr) (sel_expr rhs) - | Cminor.Scall optid sg fn args => - Scall optid sg (sel_expr fn) (sel_exprlist args) - | Cminor.Stailcall sg fn args => - Stailcall sg (sel_expr fn) (sel_exprlist args) - | Cminor.Salloc id b => Salloc id (sel_expr b) - | 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.Slabel lbl body => Slabel lbl (sel_stmt body) - | Cminor.Sgoto lbl => Sgoto lbl - 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 deleted file mode 100644 index 6d62979..0000000 --- a/backend/Selectionproof.v +++ /dev/null @@ -1,1398 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** 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 Smallstep. -Require Import Cminor. -Require Import Op. -Require Import CminorSel. -Require Import Selection. - -Open Local Scope selection_scope. - -Section CMCONSTR. - -Variable ge: genv. -Variable sp: val. -Variable e: env. -Variable m: mem. - -(** * 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. - -Hint Resolve eval_Evar eval_Eop eval_Eload eval_Econdition - eval_Elet eval_Eletvar - eval_CEtrue eval_CEfalse eval_CEcond - eval_CEcondition eval_Enil eval_Econs: evalexpr. - -Lemma eval_lift_expr: - forall w le a v, - eval_expr ge sp e m le a v -> - forall p le', insert_lenv le p w le' -> - eval_expr ge sp e m le' (lift_expr p a) v. -Proof. - intro w. - apply (eval_expr_ind3 ge sp e m - (fun le a v => - forall p le', insert_lenv le p w le' -> - eval_expr ge sp e m le' (lift_expr p a) v) - (fun le a v => - forall p le', insert_lenv le p w le' -> - eval_condexpr ge sp e m le' (lift_condexpr p a) v) - (fun le al vl => - forall p le', insert_lenv le p w le' -> - eval_exprlist ge sp e m le' (lift_exprlist p al) 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. - - 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 le a v w, - eval_expr ge sp e m le a v -> - eval_expr ge sp e m (w::le) (lift a) 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. - -Ltac InvEval1 := - match goal with - | [ H: (eval_expr _ _ _ _ _ (Eop _ Enil) _) |- _ ] => - inv H; InvEval1 - | [ H: (eval_expr _ _ _ _ _ (Eop _ (_ ::: Enil)) _) |- _ ] => - inv H; InvEval1 - | [ H: (eval_expr _ _ _ _ _ (Eop _ (_ ::: _ ::: Enil)) _) |- _ ] => - inv H; InvEval1 - | [ H: (eval_exprlist _ _ _ _ _ Enil _) |- _ ] => - inv H; InvEval1 - | [ H: (eval_exprlist _ _ _ _ _ (_ ::: _) _) |- _ ] => - inv H; InvEval1 - | _ => - idtac - end. - -Ltac InvEval2 := - match goal with - | [ H: (eval_operation _ _ _ nil _ = Some _) |- _ ] => - simpl in H; inv H - | [ H: (eval_operation _ _ _ (_ :: nil) _ = Some _) |- _ ] => - simpl in H; FuncInv - | [ H: (eval_operation _ _ _ (_ :: _ :: nil) _ = Some _) |- _ ] => - simpl in H; FuncInv - | [ H: (eval_operation _ _ _ (_ :: _ :: _ :: nil) _ = Some _) |- _ ] => - simpl in H; FuncInv - | _ => - idtac - end. - -Ltac InvEval := InvEval1; InvEval2; InvEval2. - -(** * 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. -*) - -Theorem eval_notint: - forall le a x, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le (notint a) (Vint (Int.not x)). -Proof. - unfold notint; intros until x; case (notint_match a); intros; InvEval. - EvalOp. simpl. congruence. - EvalOp. simpl. congruence. - 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. - simpl. rewrite Int.or_idem. auto. -Qed. - -Lemma eval_notbool_base: - forall le a v b, - eval_expr ge sp e m le a v -> - Val.bool_of_val v b -> - eval_expr ge sp e m le (notbool_base a) (Val.of_bool (negb b)). -Proof. - TrivialOp notbool_base. simpl. - inv 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 le a v b, - eval_expr ge sp e m le a v -> - Val.bool_of_val v b -> - eval_expr ge sp e m le (notbool a) (Val.of_bool (negb b)). -Proof. - induction a; simpl; intros; try (eapply eval_notbool_base; eauto). - destruct o; try (eapply eval_notbool_base; eauto). - - destruct e0. InvEval. - inv H0. rewrite Int.eq_false; auto. - simpl; eauto with evalexpr. - rewrite Int.eq_true; simpl; eauto with evalexpr. - eapply eval_notbool_base; eauto. - - inv H. eapply eval_Eop; eauto. - simpl. assert (eval_condition c vl m = Some b). - generalize H6. simpl. - case (eval_condition c vl m); intros. - destruct b0; inv H1; inversion H0; auto; congruence. - congruence. - rewrite (Op.eval_negate_condition _ _ _ H). - destruct b; reflexivity. - - inv H. eapply eval_Econdition; eauto. - destruct v1; eauto. -Qed. - -Theorem eval_addimm: - forall le n a x, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le (addimm n a) (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; EvalOp; simpl. - rewrite Int.add_commut. auto. - destruct (Genv.find_symbol ge s); discriminate. - destruct sp; simpl in H1; discriminate. - subst x. rewrite Int.add_assoc. decEq; decEq; decEq. apply Int.add_commut. -Qed. - -Theorem eval_addimm_ptr: - forall le n a b ofs, - eval_expr ge sp e m le a (Vptr b ofs) -> - eval_expr ge sp e m le (addimm n a) (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; EvalOp; simpl. - destruct (Genv.find_symbol ge s). - rewrite Int.add_commut. congruence. - discriminate. - destruct sp; simpl in H1; try discriminate. - inv H1. simpl. decEq. decEq. - rewrite Int.add_assoc. decEq. apply Int.add_commut. - subst. rewrite (Int.add_commut n m0). rewrite Int.add_assoc. auto. -Qed. - -Theorem eval_add: - forall le a b x y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - eval_expr ge sp e m le (add a b) (Vint (Int.add x y)). -Proof. - intros until y. - unfold add; case (add_match a b); intros; InvEval. - rewrite Int.add_commut. apply eval_addimm. auto. - replace (Int.add x y) with (Int.add (Int.add i0 i) (Int.add n1 n2)). - apply eval_addimm. EvalOp. - subst x; subst y. - repeat rewrite Int.add_assoc. decEq. apply Int.add_permut. - 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. - apply eval_addimm. auto. - 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 le a b p x y, - eval_expr ge sp e m le a (Vptr p x) -> - eval_expr ge sp e m le b (Vint y) -> - eval_expr ge sp e m le (add a b) (Vptr p (Int.add x y)). -Proof. - intros until y. unfold add; case (add_match a b); intros; InvEval. - replace (Int.add x y) 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. apply Int.add_permut. - 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. - apply eval_addimm_ptr. auto. - 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 le a b x p y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vptr p y) -> - eval_expr ge sp e m le (add a b) (Vptr p (Int.add y x)). -Proof. - intros until y. unfold add; case (add_match a b); intros; InvEval. - apply eval_addimm_ptr. auto. - replace (Int.add y x) 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. - rewrite (Int.add_commut n1 n2). apply Int.add_permut. - 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. - 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 le a b x y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - eval_expr ge sp e m le (sub a b) (Vint (Int.sub x y)). -Proof. - intros until y. - unfold sub; case (sub_match a b); intros; InvEval. - rewrite Int.sub_add_opp. - apply eval_addimm. assumption. - replace (Int.sub x y) with (Int.add (Int.sub i0 i) (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. - 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. - 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 le a b p x y, - eval_expr ge sp e m le a (Vptr p x) -> - eval_expr ge sp e m le b (Vint y) -> - eval_expr ge sp e m le (sub a b) (Vptr p (Int.sub x y)). -Proof. - intros until y. - unfold sub; case (sub_match a b); intros; InvEval. - rewrite Int.sub_add_opp. - apply eval_addimm_ptr. assumption. - subst b0. replace (Int.sub x y) with (Int.add (Int.sub i0 i) (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. - 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. - 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 le a b p x y, - eval_expr ge sp e m le a (Vptr p x) -> - eval_expr ge sp e m le b (Vptr p y) -> - eval_expr ge sp e m le (sub a b) (Vint (Int.sub x y)). -Proof. - intros until y. - unfold sub; case (sub_match a b); intros; InvEval. - replace (Int.sub x y) with (Int.add (Int.sub i0 i) (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. - 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. - 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 le a amount mask x, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le (rolm a amount mask) (Vint (Int.rolm x amount mask)). -Proof. - intros until x. unfold rolm; case (rolm_match a); intros; InvEval. - eauto with evalexpr. - case (Int.is_rlw_mask (Int.and (Int.rol mask1 amount) mask)). - 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. econstructor. EvalOp. simpl. rewrite H. reflexivity. constructor. auto. - EvalOp. -Qed. - -Theorem eval_shlimm: - forall le a n x, - eval_expr ge sp e m le a (Vint x) -> - Int.ltu n (Int.repr 32) = true -> - eval_expr ge sp e m le (shlimm a n) (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 le a n x, - eval_expr ge sp e m le a (Vint x) -> - Int.ltu n (Int.repr 32) = true -> - eval_expr ge sp e m le (shruimm a n) (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 le a n x, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le (mulimm_base n a) (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 (Vint x). 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. - intros. EvalOp. -Qed. - -Theorem eval_mulimm: - forall le a n x, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le (mulimm n a) (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. - 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. - EvalOp. rewrite Int.mul_commut. reflexivity. - 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 le a b x y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - eval_expr ge sp e m le (mul a b) (Vint (Int.mul x y)). -Proof. - intros until y. - unfold mul; case (mul_match a b); intros; InvEval. - rewrite Int.mul_commut. apply eval_mulimm. auto. - apply eval_mulimm. auto. - EvalOp. -Qed. - -Theorem eval_divs: - forall le a b x y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - y <> Int.zero -> - eval_expr ge sp e m le (divs a b) (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 le a b x y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - y <> Int.zero -> - eval_expr ge sp e m le (mod_aux divop a b) - (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. - apply H. assumption. - eapply eval_Econs. apply eval_Eletvar. simpl; reflexivity. - apply eval_Enil. - simpl; reflexivity. apply eval_Enil. - reflexivity. -Qed. - -Theorem eval_mods: - forall le a b x y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - y <> Int.zero -> - eval_expr ge sp e m le (mods a b) (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 le a x b y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - y <> Int.zero -> - eval_expr ge sp e m le (Eop Odivu (a ::: b ::: Enil)) (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 le a x b y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - y <> Int.zero -> - eval_expr ge sp e m le (divu a b) (Vint (Int.divu x y)). -Proof. - intros until y. - unfold divu; case (divu_match b); intros; InvEval. - caseEq (Int.is_power2 y). - intros. rewrite (Int.divu_pow2 x y i H0). - apply eval_shruimm. auto. - apply Int.is_power2_range with y. auto. - intros. apply eval_divu_base. auto. EvalOp. auto. - eapply eval_divu_base; eauto. -Qed. - -Theorem eval_modu: - forall le a x b y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - y <> Int.zero -> - eval_expr ge sp e m le (modu a b) (Vint (Int.modu x y)). -Proof. - intros until y; unfold modu; case (divu_match b); intros; InvEval. - caseEq (Int.is_power2 y). - intros. rewrite (Int.modu_and x y i H0). - rewrite <- Int.rolm_zero. apply eval_rolm. auto. - intro. rewrite Int.modu_divu. eapply eval_mod_aux. - intros. simpl. predSpec Int.eq Int.eq_spec y0 Int.zero. - contradiction. auto. - auto. EvalOp. auto. auto. - rewrite Int.modu_divu. eapply eval_mod_aux. - intros. simpl. predSpec Int.eq Int.eq_spec y0 Int.zero. - contradiction. auto. auto. auto. auto. auto. -Qed. - -Theorem eval_andimm: - forall le n a x, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le (andimm n a) (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 le a x b y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - eval_expr ge sp e m le (and a b) (Vint (Int.and x y)). -Proof. - intros until y; unfold and; case (mul_match a b); intros; InvEval. - rewrite Int.and_commut. apply eval_andimm; auto. - apply eval_andimm; auto. - EvalOp. -Qed. - -Remark eval_same_expr: - forall a1 a2 le v1 v2, - same_expr_pure a1 a2 = true -> - eval_expr ge sp e m le a1 v1 -> - eval_expr ge sp e m le a2 v2 -> - a1 = a2 /\ v1 = v2. -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. split. auto. congruence. - discriminate. -Qed. - -Lemma eval_or: - forall le a x b y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - eval_expr ge sp e m le (or a b) (Vint (Int.or x y)). -Proof. - intros until y; unfold or; case (or_match a b); intros; InvEval. - caseEq (Int.eq amount1 amount2 - && Int.is_rlw_mask (Int.or mask1 mask2) - && same_expr_pure t1 t2); intro. - destruct (andb_prop _ _ H1). destruct (andb_prop _ _ H4). - generalize (Int.eq_spec amount1 amount2). rewrite H6. intro. subst amount2. - exploit eval_same_expr; eauto. intros [EQ1 EQ2]. inv EQ1. inv EQ2. - simpl. EvalOp. simpl. rewrite Int.or_rolm. auto. - simpl. apply eval_Eop with (Vint x :: Vint y :: nil). - econstructor. EvalOp. simpl. congruence. - econstructor. EvalOp. simpl. congruence. constructor. auto. - EvalOp. -Qed. - -Theorem eval_shl: - forall le a x b y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - Int.ltu y (Int.repr 32) = true -> - eval_expr ge sp e m le (shl a b) (Vint (Int.shl x y)). -Proof. - intros until y; unfold shl; case (shift_match b); intros. - InvEval. apply eval_shlimm; auto. - EvalOp. simpl. rewrite H1. auto. -Qed. - -Theorem eval_shru: - forall le a x b y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - Int.ltu y (Int.repr 32) = true -> - eval_expr ge sp e m le (shru a b) (Vint (Int.shru x y)). -Proof. - intros until y; unfold shru; case (shift_match b); intros. - InvEval. apply eval_shruimm; auto. - EvalOp. simpl. rewrite H1. auto. -Qed. - -Theorem eval_addf: - forall le a x b y, - eval_expr ge sp e m le a (Vfloat x) -> - eval_expr ge sp e m le b (Vfloat y) -> - eval_expr ge sp e m le (addf a b) (Vfloat (Float.add x y)). -Proof. - intros until y; unfold addf. - destruct (use_fused_mul tt). - case (addf_match a b); intros; InvEval. - EvalOp. simpl. congruence. - EvalOp. simpl. rewrite Float.addf_commut. congruence. - EvalOp. - intros. EvalOp. -Qed. - -Theorem eval_subf: - forall le a x b y, - eval_expr ge sp e m le a (Vfloat x) -> - eval_expr ge sp e m le b (Vfloat y) -> - eval_expr ge sp e m le (subf a b) (Vfloat (Float.sub x y)). -Proof. - intros until y; unfold subf. - destruct (use_fused_mul tt). - case (subf_match a b); intros. - InvEval. EvalOp. simpl. congruence. - EvalOp. - intros. EvalOp. -Qed. - -Theorem eval_cast8signed: - forall le a v, - eval_expr ge sp e m le a v -> - eval_expr ge sp e m le (cast8signed a) (Val.sign_ext 8 v). -Proof. - intros until v; unfold cast8signed; case (cast8signed_match a); intros; InvEval. - EvalOp. simpl. subst v. destruct v1; simpl; auto. - rewrite Int.sign_ext_idem. reflexivity. compute; auto. - EvalOp. -Qed. - -Theorem eval_cast8unsigned: - forall le a v, - eval_expr ge sp e m le a v -> - eval_expr ge sp e m le (cast8unsigned a) (Val.zero_ext 8 v). -Proof. - intros until v; unfold cast8unsigned; case (cast8unsigned_match a); intros; InvEval. - EvalOp. simpl. subst v. destruct v1; simpl; auto. - rewrite Int.zero_ext_idem. reflexivity. compute; auto. - EvalOp. -Qed. - -Theorem eval_cast16signed: - forall le a v, - eval_expr ge sp e m le a v -> - eval_expr ge sp e m le (cast16signed a) (Val.sign_ext 16 v). -Proof. - intros until v; unfold cast16signed; case (cast16signed_match a); intros; InvEval. - EvalOp. simpl. subst v. destruct v1; simpl; auto. - rewrite Int.sign_ext_idem. reflexivity. compute; auto. - EvalOp. -Qed. - -Theorem eval_cast16unsigned: - forall le a v, - eval_expr ge sp e m le a v -> - eval_expr ge sp e m le (cast16unsigned a) (Val.zero_ext 16 v). -Proof. - intros until v; unfold cast16unsigned; case (cast16unsigned_match a); intros; InvEval. - EvalOp. simpl. subst v. destruct v1; simpl; auto. - rewrite Int.zero_ext_idem. reflexivity. compute; auto. - EvalOp. -Qed. - -Theorem eval_singleoffloat: - forall le a v, - eval_expr ge sp e m le a v -> - eval_expr ge sp e m le (singleoffloat a) (Val.singleoffloat v). -Proof. - intros until v; unfold singleoffloat; case (singleoffloat_match a); intros; InvEval. - EvalOp. simpl. subst v. destruct v1; simpl; auto. rewrite Float.singleoffloat_idem. reflexivity. - EvalOp. -Qed. - -Theorem eval_comp_int: - forall le c a x b y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - eval_expr ge sp e m le (comp c a b) (Val.of_bool(Int.cmp c x y)). -Proof. - intros until y. - unfold comp; case (comp_match a b); intros; InvEval. - EvalOp. simpl. rewrite Int.swap_cmp. destruct (Int.cmp c x y); reflexivity. - EvalOp. simpl. destruct (Int.cmp c x y); reflexivity. - EvalOp. simpl. destruct (Int.cmp c x y); reflexivity. -Qed. - -Theorem eval_comp_ptr_int: - forall le c a x1 x2 b y v, - eval_expr ge sp e m le a (Vptr x1 x2) -> - eval_expr ge sp e m le b (Vint y) -> - (if Int.eq y Int.zero then Cminor.eval_compare_mismatch c else None) = Some v -> - eval_expr ge sp e m le (comp c a b) v. -Proof. - intros until v. - unfold comp; case (comp_match a b); intros; InvEval. - EvalOp. simpl. destruct (Int.eq y Int.zero); try discriminate. - unfold Cminor.eval_compare_mismatch in H1. unfold eval_compare_mismatch. - destruct c; try discriminate; auto. - EvalOp. simpl. destruct (Int.eq y Int.zero); try discriminate. - unfold Cminor.eval_compare_mismatch in H1. unfold eval_compare_mismatch. - destruct c; try discriminate; auto. -Qed. - -Theorem eval_comp_int_ptr: - forall le c a x b y1 y2 v, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vptr y1 y2) -> - (if Int.eq x Int.zero then Cminor.eval_compare_mismatch c else None) = Some v -> - eval_expr ge sp e m le (comp c a b) v. -Proof. - intros until v. - unfold comp; case (comp_match a b); intros; InvEval. - EvalOp. simpl. destruct (Int.eq x Int.zero); try discriminate. - unfold Cminor.eval_compare_mismatch in H1. unfold eval_compare_mismatch. - destruct c; try discriminate; auto. - EvalOp. simpl. destruct (Int.eq x Int.zero); try discriminate. - unfold Cminor.eval_compare_mismatch in H1. unfold eval_compare_mismatch. - destruct c; try discriminate; auto. -Qed. - -Theorem eval_comp_ptr_ptr: - forall le c a x1 x2 b y1 y2, - eval_expr ge sp e m le a (Vptr x1 x2) -> - eval_expr ge sp e m le b (Vptr y1 y2) -> - valid_pointer m x1 (Int.signed x2) && - valid_pointer m y1 (Int.signed y2) = true -> - x1 = y1 -> - eval_expr ge sp e m le (comp c a b) (Val.of_bool(Int.cmp c x2 y2)). -Proof. - intros until y2. - unfold comp; case (comp_match a b); intros; InvEval. - EvalOp. simpl. rewrite H1. subst y1. rewrite dec_eq_true. - destruct (Int.cmp c x2 y2); reflexivity. -Qed. - -Theorem eval_comp_ptr_ptr_2: - forall le c a x1 x2 b y1 y2 v, - eval_expr ge sp e m le a (Vptr x1 x2) -> - eval_expr ge sp e m le b (Vptr y1 y2) -> - valid_pointer m x1 (Int.signed x2) && - valid_pointer m y1 (Int.signed y2) = true -> - x1 <> y1 -> - Cminor.eval_compare_mismatch c = Some v -> - eval_expr ge sp e m le (comp c a b) v. -Proof. - intros until y2. - unfold comp; case (comp_match a b); intros; InvEval. - EvalOp. simpl. rewrite H1. rewrite dec_eq_false; auto. - destruct c; simpl in H3; inv H3; auto. -Qed. - -Theorem eval_compu: - forall le c a x b y, - eval_expr ge sp e m le a (Vint x) -> - eval_expr ge sp e m le b (Vint y) -> - eval_expr ge sp e m le (compu c a b) (Val.of_bool(Int.cmpu c x y)). -Proof. - intros until y. - unfold compu; case (comp_match a b); intros; InvEval. - EvalOp. simpl. rewrite Int.swap_cmpu. destruct (Int.cmpu c x y); reflexivity. - EvalOp. simpl. destruct (Int.cmpu c x y); reflexivity. - EvalOp. simpl. destruct (Int.cmpu c x y); reflexivity. -Qed. - -Theorem eval_compf: - forall le c a x b y, - eval_expr ge sp e m le a (Vfloat x) -> - eval_expr ge sp e m le b (Vfloat y) -> - eval_expr ge sp e m le (compf c a b) (Val.of_bool(Float.cmp c x y)). -Proof. - intros. unfold compf. EvalOp. simpl. - destruct (Float.cmp c x y); reflexivity. -Qed. - -Lemma negate_condexpr_correct: - forall le a b, - eval_condexpr ge sp e m le a b -> - eval_condexpr ge sp e m le (negate_condexpr a) (negb b). -Proof. - induction 1; simpl. - constructor. - constructor. - econstructor. eauto. apply eval_negate_condition. auto. - econstructor. eauto. destruct vb1; auto. -Qed. - -Scheme expr_ind2 := Induction for expr Sort Prop - with exprlist_ind2 := Induction for exprlist Sort Prop. - -Fixpoint forall_exprlist (P: expr -> Prop) (el: exprlist) {struct el}: Prop := - match el with - | Enil => True - | Econs e el' => P e /\ forall_exprlist P el' - end. - -Lemma expr_induction_principle: - forall (P: expr -> Prop), - (forall i : ident, P (Evar i)) -> - (forall (o : operation) (e : exprlist), - forall_exprlist P e -> P (Eop o e)) -> - (forall (m : memory_chunk) (a : Op.addressing) (e : exprlist), - forall_exprlist P e -> P (Eload m a e)) -> - (forall (c : condexpr) (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. -Proof. - intros. apply expr_ind2 with (P := P) (P0 := forall_exprlist P); auto. - simpl. auto. - intros. simpl. auto. -Qed. - -Lemma eval_base_condition_of_expr: - forall le a v b, - eval_expr ge sp e m le a v -> - Val.bool_of_val v b -> - eval_condexpr ge sp e m le - (CEcond (Ccompimm Cne Int.zero) (a ::: Enil)) - b. -Proof. - intros. - eapply eval_CEcond. eauto with evalexpr. - inversion H0; simpl. rewrite Int.eq_false; auto. auto. auto. -Qed. - -Lemma is_compare_neq_zero_correct: - forall c v b, - is_compare_neq_zero c = true -> - eval_condition c (v :: nil) m = Some b -> - Val.bool_of_val v b. -Proof. - intros. - destruct c; simpl in H; try discriminate; - destruct c; simpl in H; try discriminate; - generalize (Int.eq_spec i Int.zero); rewrite H; intro; subst i. - - simpl in H0. destruct v; inv H0. - generalize (Int.eq_spec i Int.zero). destruct (Int.eq i Int.zero); intros; simpl. - subst i; constructor. constructor; auto. constructor. - - simpl in H0. destruct v; inv H0. - generalize (Int.eq_spec i Int.zero). destruct (Int.eq i Int.zero); intros; simpl. - subst i; constructor. constructor; auto. -Qed. - -Lemma is_compare_eq_zero_correct: - forall c v b, - is_compare_eq_zero c = true -> - eval_condition c (v :: nil) m = Some b -> - Val.bool_of_val v (negb b). -Proof. - intros. apply is_compare_neq_zero_correct with (negate_condition c). - destruct c; simpl in H; simpl; try discriminate; - destruct c; simpl; try discriminate; auto. - apply eval_negate_condition; auto. -Qed. - -Lemma eval_condition_of_expr: - forall a le v b, - eval_expr ge sp e m le a v -> - Val.bool_of_val v b -> - eval_condexpr ge sp e m le (condexpr_of_expr a) b. -Proof. - intro a0; pattern a0. - apply expr_induction_principle; simpl; intros; - try (eapply eval_base_condition_of_expr; eauto; fail). - - destruct o; try (eapply eval_base_condition_of_expr; eauto; fail). - - destruct e0. InvEval. - inversion H1. - rewrite Int.eq_false; auto. constructor. - subst i; rewrite Int.eq_true. constructor. - eapply eval_base_condition_of_expr; eauto. - - inv H0. simpl in H7. - assert (eval_condition c vl m = Some b). - destruct (eval_condition c vl m); try discriminate. - destruct b0; inv H7; inversion H1; congruence. - assert (eval_condexpr ge sp e m le (CEcond c e0) b). - eapply eval_CEcond; eauto. - destruct e0; auto. destruct e1; auto. - simpl in H. destruct H. - inv H5. inv H11. - - case_eq (is_compare_neq_zero c); intros. - eapply H; eauto. - apply is_compare_neq_zero_correct with c; auto. - - case_eq (is_compare_eq_zero c); intros. - replace b with (negb (negb b)). apply negate_condexpr_correct. - eapply H; eauto. - apply is_compare_eq_zero_correct with c; auto. - apply negb_involutive. - - auto. - - inv H1. destruct v1; eauto with evalexpr. -Qed. - -Lemma eval_addressing: - forall le a v b ofs, - eval_expr ge sp e m le a v -> - v = Vptr b ofs -> - match addressing a with (mode, args) => - exists vl, - eval_exprlist ge sp e m le args vl /\ - eval_addressing ge sp mode vl = Some v - end. -Proof. - intros until v. unfold addressing; case (addressing_match a); intros; InvEval. - exists (@nil val). split. eauto with evalexpr. simpl. auto. - exists (@nil val). split. eauto with evalexpr. simpl. auto. - destruct (Genv.find_symbol ge s); congruence. - exists (Vint i0 :: nil). split. eauto with evalexpr. - simpl. destruct (Genv.find_symbol ge s). congruence. discriminate. - exists (Vptr b0 i :: nil). split. eauto with evalexpr. - simpl. congruence. - exists (Vint i :: Vptr b0 i0 :: nil). - split. eauto with evalexpr. simpl. - 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 le a v chunk v', - eval_expr ge sp e m le a v -> - Mem.loadv chunk m v = Some v' -> - eval_expr ge sp e m le (load chunk a) 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 chunk a1 a2 v1 v2 f k m', - eval_expr ge sp e m nil a1 v1 -> - eval_expr ge sp e m nil a2 v2 -> - Mem.storev chunk m v1 v2 = Some m' -> - step ge (State f (store chunk a1 a2) k sp e m) - E0 (State f Sskip k sp e m'). -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 step_store; 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 le op a1 v1 v, - eval_expr ge sp e m le a1 v1 -> - eval_unop op v1 = Some v -> - eval_expr ge sp e m le (sel_unop op a1) 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. - EvalOp. -Qed. - -Lemma eval_sel_binop: - forall le op a1 a2 v1 v2 v, - eval_expr ge sp e m le a1 v1 -> - eval_expr ge sp e m le a2 v2 -> - eval_binop op v1 v2 m = Some v -> - eval_expr ge sp e m le (sel_binop op a1 a2) v. -Proof. - destruct op; simpl; intros; FuncInv; try subst v. - apply eval_add; auto. - apply eval_add_ptr_2; auto. - apply eval_add_ptr; auto. - apply eval_sub; auto. - apply eval_sub_ptr_int; auto. - destruct (eq_block b b0); inv H1. - eapply eval_sub_ptr_ptr; eauto. - apply eval_mul; eauto. - generalize (Int.eq_spec i0 Int.zero). destruct (Int.eq i0 Int.zero); inv H1. - apply eval_divs; eauto. - generalize (Int.eq_spec i0 Int.zero). destruct (Int.eq i0 Int.zero); inv H1. - apply eval_divu; eauto. - generalize (Int.eq_spec i0 Int.zero). destruct (Int.eq i0 Int.zero); inv H1. - apply eval_mods; eauto. - generalize (Int.eq_spec i0 Int.zero). destruct (Int.eq i0 Int.zero); inv H1. - apply eval_modu; eauto. - apply eval_and; auto. - apply eval_or; auto. - EvalOp. - caseEq (Int.ltu i0 (Int.repr 32)); intro; rewrite H2 in H1; inv H1. - apply eval_shl; auto. - EvalOp. - caseEq (Int.ltu i0 (Int.repr 32)); intro; rewrite H2 in H1; inv H1. - apply eval_shru; auto. - apply eval_addf; auto. - apply eval_subf; auto. - EvalOp. - EvalOp. - apply eval_comp_int; auto. - eapply eval_comp_int_ptr; eauto. - eapply eval_comp_ptr_int; eauto. - generalize H1; clear H1. - case_eq (valid_pointer m b (Int.signed i) && valid_pointer m b0 (Int.signed i0)); intros. - destruct (eq_block b b0); inv H2. - eapply eval_comp_ptr_ptr; eauto. - eapply eval_comp_ptr_ptr_2; eauto. - discriminate. - eapply eval_compu; eauto. - eapply eval_compf; eauto. -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. - -(** Semantic preservation for expressions. *) - -Lemma sel_expr_correct: - forall sp e m a v, - Cminor.eval_expr ge sp e m a v -> - forall le, - eval_expr tge sp e m le (sel_expr a) v. -Proof. - induction 1; 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 *) - eapply eval_sel_binop; eauto. - (* Eload *) - eapply eval_load; eauto. - (* Econdition *) - econstructor; eauto. eapply eval_condition_of_expr; eauto. - destruct b1; auto. -Qed. - -Hint Resolve sel_expr_correct: evalexpr. - -Lemma sel_exprlist_correct: - forall sp e m a v, - Cminor.eval_exprlist ge sp e m a v -> - forall le, - eval_exprlist tge sp e m le (sel_exprlist a) v. -Proof. - induction 1; intros; simpl; constructor; auto with evalexpr. -Qed. - -Hint Resolve sel_exprlist_correct: evalexpr. - -(** Semantic preservation for terminating function calls and statements. *) - -Fixpoint sel_cont (k: Cminor.cont) : CminorSel.cont := - match k with - | Cminor.Kstop => Kstop - | Cminor.Kseq s1 k1 => Kseq (sel_stmt s1) (sel_cont k1) - | Cminor.Kblock k1 => Kblock (sel_cont k1) - | Cminor.Kcall id f sp e k1 => - Kcall id (sel_function f) sp e (sel_cont k1) - end. - -Inductive match_states: Cminor.state -> CminorSel.state -> Prop := - | match_state: forall f s k s' k' sp e m, - s' = sel_stmt s -> - k' = sel_cont k -> - match_states - (Cminor.State f s k sp e m) - (State (sel_function f) s' k' sp e m) - | match_callstate: forall f args k k' m, - k' = sel_cont k -> - match_states - (Cminor.Callstate f args k m) - (Callstate (sel_fundef f) args k' m) - | match_returnstate: forall v k k' m, - k' = sel_cont k -> - match_states - (Cminor.Returnstate v k m) - (Returnstate v k' m). - -Remark call_cont_commut: - forall k, call_cont (sel_cont k) = sel_cont (Cminor.call_cont k). -Proof. - induction k; simpl; auto. -Qed. - -Remark find_label_commut: - forall lbl s k, - find_label lbl (sel_stmt s) (sel_cont k) = - option_map (fun sk => (sel_stmt (fst sk), sel_cont (snd sk))) - (Cminor.find_label lbl s k). -Proof. - induction s; intros; simpl; auto. - unfold store. destruct (addressing (sel_expr e)); auto. - change (Kseq (sel_stmt s2) (sel_cont k)) - with (sel_cont (Cminor.Kseq s2 k)). - rewrite IHs1. rewrite IHs2. - destruct (Cminor.find_label lbl s1 (Cminor.Kseq s2 k)); auto. - rewrite IHs1. rewrite IHs2. - destruct (Cminor.find_label lbl s1 k); auto. - change (Kseq (Sloop (sel_stmt s)) (sel_cont k)) - with (sel_cont (Cminor.Kseq (Cminor.Sloop s) k)). - auto. - change (Kblock (sel_cont k)) - with (sel_cont (Cminor.Kblock k)). - auto. - destruct o; auto. - destruct (ident_eq lbl l); auto. -Qed. - -Lemma sel_step_correct: - forall S1 t S2, Cminor.step ge S1 t S2 -> - forall T1, match_states S1 T1 -> - exists T2, step tge T1 t T2 /\ match_states S2 T2. -Proof. - induction 1; intros T1 ME; inv ME; simpl; - try (econstructor; split; [econstructor; eauto with evalexpr | econstructor; eauto]; fail). - - (* skip call *) - econstructor; split. - econstructor. destruct k; simpl in H; simpl; auto. - rewrite <- H0; reflexivity. - constructor; auto. - (* assign *) - exists (State (sel_function f) Sskip (sel_cont k) sp (PTree.set id v e) m); split. - constructor. auto with evalexpr. - constructor; auto. - (* store *) - econstructor; split. - eapply eval_store; eauto with evalexpr. - constructor; auto. - (* Scall *) - econstructor; split. - econstructor; eauto with evalexpr. - apply functions_translated; eauto. - apply sig_function_translated. - constructor; auto. - (* Stailcall *) - econstructor; split. - econstructor; eauto with evalexpr. - apply functions_translated; eauto. - apply sig_function_translated. - constructor; auto. apply call_cont_commut. - (* Salloc *) - exists (State (sel_function f) Sskip (sel_cont k) sp (PTree.set id (Vptr b Int.zero) e) m'); split. - econstructor; eauto with evalexpr. - constructor; auto. - (* Sifthenelse *) - exists (State (sel_function f) (if b then sel_stmt s1 else sel_stmt s2) (sel_cont k) sp e m); split. - constructor. eapply eval_condition_of_expr; eauto with evalexpr. - constructor; auto. destruct b; auto. - (* Sreturn None *) - econstructor; split. - econstructor. rewrite <- H; reflexivity. - constructor; auto. apply call_cont_commut. - (* Sreturn Some *) - econstructor; split. - econstructor. simpl. auto. eauto with evalexpr. - constructor; auto. apply call_cont_commut. - (* Sgoto *) - econstructor; split. - econstructor. simpl. rewrite call_cont_commut. rewrite find_label_commut. - rewrite H. simpl. reflexivity. - constructor; auto. -Qed. - -Lemma sel_initial_states: - forall S, Cminor.initial_state prog S -> - exists R, initial_state tprog R /\ match_states S R. -Proof. - induction 1. - econstructor; split. - econstructor. - simpl. fold tge. rewrite symbols_preserved. eexact H. - apply function_ptr_translated. eauto. - rewrite <- H1. apply sig_function_translated; auto. - unfold tprog, sel_program. rewrite Genv.init_mem_transf. - constructor; auto. -Qed. - -Lemma sel_final_states: - forall S R r, - match_states S R -> Cminor.final_state S r -> final_state R r. -Proof. - intros. inv H0. inv H. simpl. constructor. -Qed. - -Theorem transf_program_correct: - forall (beh: program_behavior), - Cminor.exec_program prog beh -> CminorSel.exec_program tprog beh. -Proof. - unfold CminorSel.exec_program, Cminor.exec_program; intros. - eapply simulation_step_preservation; eauto. - eexact sel_initial_states. - eexact sel_final_states. - exact sel_step_correct. -Qed. - -End PRESERVATION. diff --git a/backend/Stacking.v b/backend/Stacking.v index 3f08daa..1cf010b 100644 --- a/backend/Stacking.v +++ b/backend/Stacking.v @@ -24,61 +24,12 @@ Require Import Linear. Require Import Bounds. Require Import Mach. Require Import Conventions. +Require Import Stacklayout. (** * Layout of activation records *) -(** The general shape of activation records is as follows, - from bottom (lowest offsets) to top: -- 24 reserved bytes. The first 4 bytes hold the back pointer to the - activation record of the caller. We use the 4 bytes at offset 12 - to store the return address. (These are reserved by the PowerPC - application binary interface.) The remaining bytes are unused. -- Space for outgoing arguments to function calls. -- Local stack slots of integer type. -- Saved values of integer callee-save registers used by the function. -- One word of padding, if necessary to align the following data - on a 8-byte boundary. -- Local stack slots of float type. -- Saved values of float callee-save registers used by the function. -- Space for the stack-allocated data declared in Cminor. - -To facilitate some of the proofs, the Cminor stack-allocated data -starts at offset 0; the preceding areas in the activation record -therefore have negative offsets. This part (with negative offsets) -is called the ``frame'', by opposition with the ``Cminor stack data'' -which is the part with positive offsets. - -The [frame_env] compilation environment records the positions of -the boundaries between areas in the frame part. -*) - -Definition fe_ofs_arg := 24. - -Record frame_env : Set := mk_frame_env { - fe_size: Z; - fe_ofs_link: Z; - fe_ofs_retaddr: Z; - fe_ofs_int_local: Z; - fe_ofs_int_callee_save: Z; - fe_num_int_callee_save: Z; - fe_ofs_float_local: Z; - fe_ofs_float_callee_save: Z; - fe_num_float_callee_save: Z -}. - -(** Computation of the frame environment from the bounds of the current - function. *) - -Definition make_env (b: bounds) := - let oil := 24 + 4 * b.(bound_outgoing) in (* integer locals *) - let oics := oil + 4 * b.(bound_int_local) in (* integer callee-saves *) - let oendi := oics + 4 * b.(bound_int_callee_save) in - let ofl := align oendi 8 in (* float locals *) - let ofcs := ofl + 8 * b.(bound_float_local) in (* float callee-saves *) - let sz := ofcs + 8 * b.(bound_float_callee_save) in (* total frame size *) - mk_frame_env sz 0 12 - oil oics b.(bound_int_callee_save) - ofl ofcs b.(bound_float_callee_save). +(** The machine- and ABI-dependent aspects of the layout are defined + in module [Stacklayout]. *) (** Computation the frame offset for the given component of the frame. The component is expressed by the following [frame_index] sum type. *) diff --git a/backend/Stackingproof.v b/backend/Stackingproof.v index a9187ee..e17f67a 100644 --- a/backend/Stackingproof.v +++ b/backend/Stackingproof.v @@ -38,6 +38,7 @@ Require Import Mach. Require Import Machabstr. Require Import Bounds. Require Import Conventions. +Require Import Stacklayout. Require Import Stacking. (** * Properties of frames and frame accesses *) @@ -50,92 +51,6 @@ Proof. destruct ty; auto. Qed. -(* -Lemma get_slot_ok: - forall fr ty ofs, - 24 <= ofs -> fr.(fr_low) + ofs + 4 * typesize ty <= 0 -> - exists v, get_slot fr ty ofs v. -Proof. - 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, - 24 <= ofs -> fr.(fr_low) + ofs + 4 * typesize ty <= 0 -> - exists fr', set_slot fr ty ofs v fr'. -Proof. - intros. rewrite <- typesize_typesize in H0. - econstructor. constructor; eauto. -Qed. - -Lemma slot_gss: - forall fr1 ty ofs v fr2, - set_slot fr1 ty ofs v fr2 -> - get_slot fr2 ty ofs v. -Proof. - 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: - forall fr1 ty ofs v fr2 ty' ofs' v', - set_slot fr1 ty ofs v fr2 -> - get_slot fr1 ty' ofs' v' -> - ofs' + 4 * typesize ty' <= ofs \/ ofs + 4 * typesize ty <= ofs' -> - get_slot fr2 ty' ofs' v'. -Proof. - intros. inv H. inv H0. - constructor; auto. - symmetry. simpl fr_low. apply frame_update_gso. omega. -Qed. - -Lemma slot_gi: - forall f ofs ty, - 24 <= ofs -> fr_low (init_frame f) + ofs + 4 * typesize ty <= 0 -> - get_slot (init_frame f) ty ofs Vundef. -Proof. - intros. rewrite <- typesize_typesize in H0. constructor; auto. -Qed. -*) - Section PRESERVATION. Variable prog: Linear.program. @@ -219,20 +134,13 @@ Definition index_diff (idx1 idx2: frame_index) : Prop := | _, _ => True end. -Remark align_float_part: - 24 + 4 * bound_outgoing b + 4 * bound_int_local b + 4 * bound_int_callee_save b <= - align (24 + 4 * bound_outgoing b + 4 * bound_int_local b + 4 * bound_int_callee_save b) 8. -Proof. - apply align_le. omega. -Qed. - Ltac AddPosProps := 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. + generalize (align_float_part b); intro. Lemma size_pos: fe.(fe_size) >= 0. Proof. @@ -1383,10 +1291,9 @@ Lemma shift_eval_addressing: (transl_addr (make_env (function_bounds f)) addr) args = Some v. Proof. - intros. destruct addr; auto. - simpl. rewrite symbols_preserved. auto. - simpl. rewrite symbols_preserved. auto. - unfold transl_addr, eval_addressing in *. + intros. + unfold transl_addr, eval_addressing in *; + destruct addr; try (rewrite symbols_preserved); auto. destruct args; try discriminate. apply shift_offset_sp; auto. Qed. diff --git a/backend/Stackingtyping.v b/backend/Stackingtyping.v index f3fe24f..f1fe2cf 100644 --- a/backend/Stackingtyping.v +++ b/backend/Stackingtyping.v @@ -25,6 +25,7 @@ Require Import Lineartyping. Require Import Mach. Require Import Machtyping. Require Import Bounds. +Require Import Stacklayout. Require Import Stacking. Require Import Stackingproof. diff --git a/caml/CMlexer.mli b/caml/CMlexer.mli deleted file mode 100644 index c6afb72..0000000 --- a/caml/CMlexer.mli +++ /dev/null @@ -1,17 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -val token: Lexing.lexbuf -> CMparser.token -exception Error of string diff --git a/caml/CMlexer.mll b/caml/CMlexer.mll deleted file mode 100644 index 9854117..0000000 --- a/caml/CMlexer.mll +++ /dev/null @@ -1,132 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -{ -open Camlcoq -open CMparser -exception Error of string -} - -let blank = [' ' '\009' '\012' '\010' '\013'] -let floatlit = - ['0'-'9'] ['0'-'9' '_']* - ('.' ['0'-'9' '_']* )? - (['e' 'E'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']*)? -let ident = ['A'-'Z' 'a'-'z' '_'] ['A'-'Z' 'a'-'z' '_' '0'-'9']* -let intlit = "-"? ( ['0'-'9']+ | "0x" ['0'-'9' 'a'-'f' 'A'-'F']+ - | "0o" ['0'-'7']+ | "0b" ['0'-'1']+ ) -let stringlit = "\"" [ ^ '"' ] * '"' - -rule token = parse - | blank + { token lexbuf } - | "/*" { comment lexbuf; token lexbuf } - | "absf" { ABSF } - | "alloc" { ALLOC } - | "&" { AMPERSAND } - | "&&" { AMPERSANDAMPERSAND } - | "!" { BANG } - | "!=" { BANGEQUAL } - | "!=f" { BANGEQUALF } - | "!=u" { BANGEQUALU } - | "|" { BAR } - | "||" { BARBAR } - | "^" { CARET } - | "case" { CASE } - | ":" { COLON } - | "," { COMMA } - | "default" { DEFAULT } - | "$" { DOLLAR } - | "else" { ELSE } - | "=" { EQUAL } - | "==" { EQUALEQUAL } - | "==f" { EQUALEQUALF } - | "==u" { EQUALEQUALU } - | "exit" { EXIT } - | "extern" { EXTERN } - | "float" { FLOAT } - | "float32" { FLOAT32 } - | "float64" { FLOAT64 } - | "floatofint" { FLOATOFINT } - | "floatofintu" { FLOATOFINTU } - | ">" { GREATER } - | ">f" { GREATERF } - | ">u" { GREATERU } - | ">=" { GREATEREQUAL } - | ">=f" { GREATEREQUALF } - | ">=u" { GREATEREQUALU } - | ">>" { GREATERGREATER } - | ">>u" { GREATERGREATERU } - | "if" { IF } - | "in" { IN } - | "int" { INT } - | "int16s" { INT16S } - | "int16u" { INT16U } - | "int32" { INT32 } - | "int8s" { INT8S } - | "int8u" { INT8U } - | "intoffloat" { INTOFFLOAT } - | "intuoffloat" { INTUOFFLOAT } - | "{" { LBRACE } - | "{{" { LBRACELBRACE } - | "[" { LBRACKET } - | "<" { LESS } - | "" { MINUSGREATER } - | "-f" { MINUSF } - | "%" { PERCENT } - | "%u" { PERCENTU } - | "+" { PLUS } - | "+f" { PLUSF } - | "?" { QUESTION } - | "}" { RBRACE } - | "}}" { RBRACERBRACE } - | "]" { RBRACKET } - | "return" { RETURN } - | ")" { RPAREN } - | ";" { SEMICOLON } - | "/" { SLASH } - | "/f" { SLASHF } - | "/u" { SLASHU } - | "stack" { STACK } - | "*" { STAR } - | "*f" { STARF } - | "switch" { SWITCH } - | "tailcall" { TAILCALL } - | "~" { TILDE } - | "var" { VAR } - | "void" { VOID } - - | intlit { INTLIT(Int32.of_string(Lexing.lexeme lexbuf)) } - | floatlit { FLOATLIT(float_of_string(Lexing.lexeme lexbuf)) } - | stringlit { let s = Lexing.lexeme lexbuf in - STRINGLIT(intern_string(String.sub s 1 (String.length s - 2))) } - | ident { IDENT(intern_string(Lexing.lexeme lexbuf)) } - | eof { EOF } - | _ { raise(Error("illegal character `" ^ Char.escaped (Lexing.lexeme_char lexbuf 0) ^ "'")) } - -and comment = parse - "*/" { () } - | eof { raise(Error "unterminated comment") } - | _ { comment lexbuf } diff --git a/caml/CMparser.mly b/caml/CMparser.mly deleted file mode 100644 index 25fb032..0000000 --- a/caml/CMparser.mly +++ /dev/null @@ -1,541 +0,0 @@ -/* *********************************************************************/ -/* */ -/* The Compcert verified compiler */ -/* */ -/* Xavier Leroy, INRIA Paris-Rocquencourt */ -/* */ -/* Copyright Institut National de Recherche en Informatique et en */ -/* Automatique. All rights reserved. This file is distributed */ -/* under the terms of the GNU General Public License as published by */ -/* the Free Software Foundation, either version 2 of the License, or */ -/* (at your option) any later version. This file is also distributed */ -/* under the terms of the INRIA Non-Commercial License Agreement. */ -/* */ -/* *********************************************************************/ - -%{ -open Datatypes -open CList -open Camlcoq -open BinPos -open BinInt -open Integers -open AST -open Cminor - -(** Naming function calls in expressions *) - -type rexpr = - | Rvar of ident - | Rconst of constant - | Runop of unary_operation * rexpr - | Rbinop of binary_operation * rexpr * rexpr - | Rload of memory_chunk * rexpr - | Rcondition of rexpr * rexpr * rexpr - | Rcall of signature * rexpr * rexpr list - | Ralloc of rexpr - -let temp_counter = ref 0 - -let temporaries = ref [] - -let mktemp () = - incr temp_counter; - let n = Printf.sprintf "__t%d" !temp_counter in - let id = intern_string n in - temporaries := id :: !temporaries; - id - -let convert_accu = ref [] - -let rec convert_rexpr = function - | Rvar id -> Evar id - | Rconst c -> Econst c - | Runop(op, e1) -> Eunop(op, convert_rexpr e1) - | Rbinop(op, e1, e2) -> - let c1 = convert_rexpr e1 in - let c2 = convert_rexpr e2 in - Ebinop(op, c1, c2) - | Rload(chunk, e1) -> Eload(chunk, convert_rexpr e1) - | Rcondition(e1, e2, e3) -> - let c1 = convert_rexpr e1 in - let c2 = convert_rexpr e2 in - let c3 = convert_rexpr e3 in - Econdition(c1, c2, c3) - | Rcall(sg, e1, el) -> - let c1 = convert_rexpr e1 in - let cl = convert_rexpr_list el in - let t = mktemp() in - convert_accu := Scall(Some t, sg, c1, cl) :: !convert_accu; - Evar t - | Ralloc e1 -> - let c1 = convert_rexpr e1 in - let t = mktemp() in - convert_accu := Salloc(t, c1) :: !convert_accu; - Evar t - -and convert_rexpr_list = function - | [] -> [] - | e1 :: el -> - let c1 = convert_rexpr e1 in - let cl = convert_rexpr_list el in - c1 :: cl - -let rec prepend_seq stmts last = - match stmts with - | [] -> last - | s1 :: sl -> prepend_seq sl (Sseq(s1, last)) - -let mkeval e = - convert_accu := []; - match e with - | Rcall(sg, e1, el) -> - let c1 = convert_rexpr e1 in - let cl = convert_rexpr_list el in - prepend_seq !convert_accu (Scall(None, sg, c1, cl)) - | _ -> - ignore (convert_rexpr e); - prepend_seq !convert_accu Sskip - -let mkassign id e = - convert_accu := []; - match e with - | Rcall(sg, e1, el) -> - let c1 = convert_rexpr e1 in - let cl = convert_rexpr_list el in - prepend_seq !convert_accu (Scall(Some id, sg, c1, cl)) - | Ralloc(e1) -> - let c1 = convert_rexpr e1 in - prepend_seq !convert_accu (Salloc(id, c1)) - | _ -> - let c = convert_rexpr e in - prepend_seq !convert_accu (Sassign(id, c)) - -let mkstore chunk e1 e2 = - convert_accu := []; - let c1 = convert_rexpr e1 in - let c2 = convert_rexpr e2 in - prepend_seq !convert_accu (Sstore(chunk, c1, c2)) - -let mkifthenelse e s1 s2 = - convert_accu := []; - let c = convert_rexpr e in - prepend_seq !convert_accu (Sifthenelse(c, s1, s2)) - -let mkreturn_some e = - convert_accu := []; - let c = convert_rexpr e in - prepend_seq !convert_accu (Sreturn (Some c)) - -let mktailcall sg e1 el = - convert_accu := []; - let c1 = convert_rexpr e1 in - let cl = convert_rexpr_list el in - prepend_seq !convert_accu (Stailcall(sg, c1, cl)) - -(** Other constructors *) - -let intconst n = - Rconst(Ointconst(coqint_of_camlint n)) - -let andbool e1 e2 = - Rcondition(e1, e2, intconst 0l) -let orbool e1 e2 = - Rcondition(e1, intconst 1l, e2) - -let exitnum n = nat_of_camlint(Int32.pred n) - -let mkswitch expr (cases, dfl) = - convert_accu := []; - let c = convert_rexpr expr in - let rec mktable = function - | [] -> [] - | (key, exit) :: rem -> - Coq_pair(coqint_of_camlint key, exitnum exit) :: mktable rem in - prepend_seq !convert_accu (Sswitch(c, 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] -> [] - | (key, action) :: rem -> - 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 = - convert_accu := []; - let c = convert_rexpr expr in - let s = - match cases with - | [] -> Sskip (* ??? *) - | [key, action] -> action - | _ -> mkmatch_aux c cases in - prepend_seq !convert_accu s - -%} - -%token ABSF -%token AMPERSAND -%token AMPERSANDAMPERSAND -%token ALLOC -%token BANG -%token BANGEQUAL -%token BANGEQUALF -%token BANGEQUALU -%token BAR -%token BARBAR -%token CARET -%token CASE -%token COLON -%token COMMA -%token DEFAULT -%token DOLLAR -%token ELSE -%token EQUAL -%token EQUALEQUAL -%token EQUALEQUALF -%token EQUALEQUALU -%token EOF -%token EXIT -%token EXTERN -%token FLOAT -%token FLOAT32 -%token FLOAT64 -%token FLOATLIT -%token FLOATOFINT -%token FLOATOFINTU -%token GREATER -%token GREATERF -%token GREATERU -%token GREATEREQUAL -%token GREATEREQUALF -%token GREATEREQUALU -%token GREATERGREATER -%token GREATERGREATERU -%token IDENT -%token IF -%token IN -%token INT -%token INT16S -%token INT16U -%token INT32 -%token INT8S -%token INT8U -%token INTLIT -%token INTOFFLOAT -%token INTUOFFLOAT -%token LBRACE -%token LBRACELBRACE -%token LBRACKET -%token LESS -%token LESSU -%token LESSF -%token LESSEQUAL -%token LESSEQUALU -%token LESSEQUALF -%token LESSLESS -%token LET -%token LOOP -%token LPAREN -%token MATCH -%token MINUS -%token MINUSF -%token MINUSGREATER -%token PERCENT -%token PERCENTU -%token PLUS -%token PLUSF -%token QUESTION -%token RBRACE -%token RBRACERBRACE -%token RBRACKET -%token RETURN -%token RPAREN -%token SEMICOLON -%token SLASH -%token SLASHF -%token SLASHU -%token STACK -%token STAR -%token STARF -%token STRINGLIT -%token SWITCH -%token TILDE -%token TAILCALL -%token VAR -%token VOID - -/* Precedences from low to high */ - -%left COMMA -%left p_let -%right EQUAL -%right QUESTION COLON -%left BARBAR -%left AMPERSANDAMPERSAND -%left BAR -%left CARET -%left AMPERSAND -%left EQUALEQUAL BANGEQUAL LESS LESSEQUAL GREATER GREATEREQUAL EQUALEQUALU BANGEQUALU LESSU LESSEQUALU GREATERU GREATEREQUALU EQUALEQUALF BANGEQUALF LESSF LESSEQUALF GREATERF GREATEREQUALF -%left LESSLESS GREATERGREATER GREATERGREATERU -%left PLUS PLUSF MINUS MINUSF -%left STAR SLASH PERCENT STARF SLASHF SLASHU PERCENTU -%nonassoc BANG TILDE p_uminus ABSF INTOFFLOAT INTUOFFLOAT FLOATOFINT FLOATOFINTU INT8S INT8U INT16S INT16U FLOAT32 ALLOC -%left LPAREN - -/* Entry point */ - -%start prog -%type prog - -%% - -/* Programs */ - -prog: - global_declarations proc_list EOF - { { prog_funct = CList.rev $2; - prog_main = intern_string "main"; - prog_vars = CList.rev $1; } } -; - -global_declarations: - /* empty */ { [] } - | global_declarations global_declaration { $2 :: $1 } -; - -global_declaration: - VAR STRINGLIT LBRACKET INTLIT RBRACKET - { Coq_pair(Coq_pair($2, [ Init_space (z_of_camlint $4) ]), ()) } -; - -proc_list: - /* empty */ { [] } - | proc_list proc { $2 :: $1 } -; - -/* Procedures */ - -proc: - STRINGLIT LPAREN parameters RPAREN COLON signature - LBRACE - stack_declaration - var_declarations - stmt_list - RBRACE - { let tmp = !temporaries in - temporaries := []; - temp_counter := 0; - Coq_pair($1, - Internal { fn_sig = $6; - fn_params = CList.rev $3; - fn_vars = CList.rev (CList.app tmp $9); - fn_stackspace = $8; - fn_body = $10 }) } - | EXTERN STRINGLIT COLON signature - { Coq_pair($2, - External { ef_id = $2; - ef_sig = $4 }) } -; - -signature: - type_ - { {sig_args = []; sig_res = Some $1} } - | VOID - { {sig_args = []; sig_res = None} } - | type_ MINUSGREATER signature - { let s = $3 in {s with sig_args = $1 :: s.sig_args} } -; - -parameters: - /* empty */ { [] } - | parameter_list { $1 } -; - -parameter_list: - IDENT { $1 :: [] } - | parameter_list COMMA IDENT { $3 :: $1 } -; - -stack_declaration: - /* empty */ { Z0 } - | STACK INTLIT SEMICOLON { z_of_camlint $2 } -; - -var_declarations: - /* empty */ { [] } - | var_declarations var_declaration { CList.app $2 $1 } -; - -var_declaration: - VAR parameter_list SEMICOLON { $2 } -; - -/* Statements */ - -stmt: - expr SEMICOLON { mkeval $1 } - | IDENT EQUAL expr SEMICOLON { mkassign $1 $3 } - | memory_chunk LBRACKET expr RBRACKET EQUAL expr SEMICOLON - { mkstore $1 $3 $6 } - | IF LPAREN expr RPAREN stmts ELSE stmts { mkifthenelse $3 $5 $7 } - | IF LPAREN expr RPAREN stmts { mkifthenelse $3 $5 Sskip } - | LOOP stmts { Sloop($2) } - | LBRACELBRACE stmt_list RBRACERBRACE { Sblock($2) } - | EXIT SEMICOLON { Sexit O } - | EXIT INTLIT SEMICOLON { Sexit (exitnum $2) } - | RETURN SEMICOLON { Sreturn None } - | RETURN expr SEMICOLON { mkreturn_some $2 } - | SWITCH LPAREN expr RPAREN LBRACE switch_cases RBRACE - { mkswitch $3 $6 } - | MATCH LPAREN expr RPAREN LBRACE match_cases RBRACE - { mkmatch $3 $6 } - | TAILCALL expr LPAREN expr_list RPAREN COLON signature SEMICOLON - { mktailcall $7 $2 $4 } -; - -stmts: - LBRACE stmt_list RBRACE { $2 } - | stmt { $1 } -; - -stmt_list: - /* empty */ { Sskip } - | 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 { Rvar $1 } - | INTLIT { intconst $1 } - | FLOATLIT { Rconst(Ofloatconst $1) } - | STRINGLIT { Rconst(Oaddrsymbol($1, Int.zero)) } - | AMPERSAND INTLIT { Rconst(Oaddrstack(coqint_of_camlint $2)) } - | MINUS expr %prec p_uminus { Rbinop(Osub, intconst 0l, $2) } /***FIXME***/ - | MINUSF expr %prec p_uminus { Runop(Onegf, $2) } - | ABSF expr { Runop(Oabsf, $2) } - | INTOFFLOAT expr { Runop(Ointoffloat, $2) } - | INTUOFFLOAT expr { Runop(Ointuoffloat, $2) } - | FLOATOFINT expr { Runop(Ofloatofint, $2) } - | FLOATOFINTU expr { Runop(Ofloatofintu, $2) } - | TILDE expr { Runop(Onotint, $2) } - | BANG expr { Runop(Onotbool, $2) } - | INT8S expr { Runop(Ocast8signed, $2) } - | INT8U expr { Runop(Ocast8unsigned, $2) } - | INT16S expr { Runop(Ocast16signed, $2) } - | INT16U expr { Runop(Ocast16unsigned, $2) } - | FLOAT32 expr { Runop(Osingleoffloat, $2) } - | expr PLUS expr { Rbinop(Oadd, $1, $3) } - | expr MINUS expr { Rbinop(Osub, $1, $3) } - | expr STAR expr { Rbinop(Omul, $1, $3) } - | expr SLASH expr { Rbinop(Odiv, $1, $3) } - | expr PERCENT expr { Rbinop(Omod, $1, $3) } - | expr SLASHU expr { Rbinop(Odivu, $1, $3) } - | expr PERCENTU expr { Rbinop(Omodu, $1, $3) } - | expr AMPERSAND expr { Rbinop(Oand, $1, $3) } - | expr BAR expr { Rbinop(Oor, $1, $3) } - | expr CARET expr { Rbinop(Oxor, $1, $3) } - | expr LESSLESS expr { Rbinop(Oshl, $1, $3) } - | expr GREATERGREATER expr { Rbinop(Oshr, $1, $3) } - | expr GREATERGREATERU expr { Rbinop(Oshru, $1, $3) } - | expr PLUSF expr { Rbinop(Oaddf, $1, $3) } - | expr MINUSF expr { Rbinop(Osubf, $1, $3) } - | expr STARF expr { Rbinop(Omulf, $1, $3) } - | expr SLASHF expr { Rbinop(Odivf, $1, $3) } - | expr EQUALEQUAL expr { Rbinop(Ocmp Ceq, $1, $3) } - | expr BANGEQUAL expr { Rbinop(Ocmp Cne, $1, $3) } - | expr LESS expr { Rbinop(Ocmp Clt, $1, $3) } - | expr LESSEQUAL expr { Rbinop(Ocmp Cle, $1, $3) } - | expr GREATER expr { Rbinop(Ocmp Cgt, $1, $3) } - | expr GREATEREQUAL expr { Rbinop(Ocmp Cge, $1, $3) } - | expr EQUALEQUALU expr { Rbinop(Ocmpu Ceq, $1, $3) } - | expr BANGEQUALU expr { Rbinop(Ocmpu Cne, $1, $3) } - | expr LESSU expr { Rbinop(Ocmpu Clt, $1, $3) } - | expr LESSEQUALU expr { Rbinop(Ocmpu Cle, $1, $3) } - | expr GREATERU expr { Rbinop(Ocmpu Cgt, $1, $3) } - | expr GREATEREQUALU expr { Rbinop(Ocmpu Cge, $1, $3) } - | expr EQUALEQUALF expr { Rbinop(Ocmpf Ceq, $1, $3) } - | expr BANGEQUALF expr { Rbinop(Ocmpf Cne, $1, $3) } - | expr LESSF expr { Rbinop(Ocmpf Clt, $1, $3) } - | expr LESSEQUALF expr { Rbinop(Ocmpf Cle, $1, $3) } - | expr GREATERF expr { Rbinop(Ocmpf Cgt, $1, $3) } - | expr GREATEREQUALF expr { Rbinop(Ocmpf Cge, $1, $3) } - | memory_chunk LBRACKET expr RBRACKET { Rload($1, $3) } - | expr AMPERSANDAMPERSAND expr { andbool $1 $3 } - | expr BARBAR expr { orbool $1 $3 } - | expr QUESTION expr COLON expr { Rcondition($1, $3, $5) } - | expr LPAREN expr_list RPAREN COLON signature{ Rcall($6, $1, $3) } - | ALLOC expr { Ralloc $2 } -; - -expr_list: - /* empty */ { [] } - | expr_list_1 { $1 } -; - -expr_list_1: - expr %prec COMMA { $1 :: [] } - | expr COMMA expr_list_1 { $1 :: $3 } -; - -memory_chunk: - INT8S { Mint8signed } - | INT8U { Mint8unsigned } - | INT16S { Mint16signed } - | INT16U { Mint16unsigned } - | INT32 { Mint32 } - | INT { Mint32 } - | FLOAT32 { Mfloat32 } - | FLOAT64 { Mfloat64 } - | FLOAT { Mfloat64 } -; - -/* Types */ - -type_: - INT { Tint } - | FLOAT { Tfloat } -; diff --git a/caml/CMtypecheck.ml b/caml/CMtypecheck.ml deleted file mode 100644 index d761f75..0000000 --- a/caml/CMtypecheck.ml +++ /dev/null @@ -1,370 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(* A type-checker for Cminor *) - -open Printf -open Datatypes -open CList -open Camlcoq -open AST -open Integers -open Cminor - -exception Error of string - -let name_of_typ = function Tint -> "int" | Tfloat -> "float" - -type ty = Base of typ | Var of ty option ref - -let newvar () = Var (ref None) -let tint = Base Tint -let tfloat = Base Tfloat - -let ty_of_typ = function Tint -> tint | Tfloat -> tfloat - -let ty_of_sig_args tyl = List.map ty_of_typ tyl - -let rec repr t = - match t with - | Base _ -> t - | Var r -> match !r with None -> t | Some t' -> repr t' - -let unify t1 t2 = - match (repr t1, repr t2) with - | Base b1, Base b2 -> - if b1 <> b2 then - raise (Error (sprintf "Expected type %s, actual type %s\n" - (name_of_typ b1) (name_of_typ b2))) - | Base b, Var r -> r := Some (Base b) - | Var r, Base b -> r := Some (Base b) - | Var r1, Var r2 -> r1 := Some (Var r2) - -let unify_list l1 l2 = - let ll1 = List.length l1 and ll2 = List.length l2 in - if ll1 <> ll2 then - raise (Error (sprintf "Arity mismatch: expected %d, actual %d\n" ll1 ll2)); - List.iter2 unify l1 l2 - -let type_var env id = - try - List.assoc id env - with Not_found -> - raise (Error (sprintf "Unbound variable %s\n" (extern_atom id))) - -let type_letvar env n = - let n = camlint_of_nat n in - try - List.nth env n - with Not_found -> - raise (Error (sprintf "Unbound let variable #%d\n" n)) - -let name_of_comparison = function - | Ceq -> "eq" - | Cne -> "ne" - | Clt -> "lt" - | Cle -> "le" - | Cgt -> "gt" - | Cge -> "ge" - -let type_constant = function - | Ointconst _ -> tint - | Ofloatconst _ -> tfloat - | Oaddrsymbol _ -> tint - | Oaddrstack _ -> tint - -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 - | Ointuoffloat -> tfloat, tint - | Ofloatofint -> tint, tfloat - | Ofloatofintu -> tint, tfloat - -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_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) - -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" - | Ointuoffloat -> "intuoffloat" - | Ofloatofint -> "floatofint" - | Ofloatofintu -> "floatofintu" - -let name_of_binary_operation = function - | Oadd -> "add" - | Osub -> "sub" - | Omul -> "mul" - | Odiv -> "div" - | Odivu -> "divu" - | Omod -> "mod" - | Omodu -> "modu" - | Oand -> "and" - | Oor -> "or" - | Oxor -> "xor" - | Oshl -> "shl" - | Oshr -> "shr" - | Oshru -> "shru" - | Oaddf -> "addf" - | Osubf -> "subf" - | Omulf -> "mulf" - | Odivf -> "divf" - | 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 - | Mint8unsigned -> tint - | Mint16signed -> tint - | Mint16unsigned -> tint - | Mint32 -> tint - | Mfloat32 -> tfloat - | Mfloat64 -> tfloat - -let name_of_chunk = function - | Mint8signed -> "int8signed" - | Mint8unsigned -> "int8unsigned" - | Mint16signed -> "int16signed" - | Mint16unsigned -> "int16unsigned" - | Mint32 -> "int32" - | Mfloat32 -> "float32" - | Mfloat64 -> "float64" - -let rec type_expr env lenv e = - match e with - | Evar id -> - type_var env id - | 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 targ te1 - with Error s -> - raise (Error (sprintf "In application of operator %s:\n%s" - (name_of_unary_operation op) s)) - end; - tres - | 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 targ1 te1; unify targ2 te2 - with Error 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 - | Econdition(e1, e2, e3) -> - type_condexpr env lenv e1; - let te2 = type_expr env lenv e2 in - let te3 = type_expr env lenv e3 in - begin try - unify te2 te3 - with Error s -> - raise (Error (sprintf "In conditional expression:\n%s" s)) - end; - te2 -(* - | Elet(e1, e2) -> - let te1 = type_expr env lenv e1 in - let te2 = type_expr env (te1 :: lenv) e2 in - te2 - | Eletvar n -> - type_letvar lenv n -*) - -and type_exprlist env lenv el = - match el with - | [] -> [] - | e1 :: et -> - let te1 = type_expr env lenv e1 in - let tet = type_exprlist env lenv et in - (te1 :: tet) - -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 - | Sskip -> () - | Sassign(id, e1) -> - let tid = type_var env id in - let te1 = type_expr env [] e1 in - begin try - unify tid te1 - with Error s -> - raise (Error (sprintf "In assignment to %s:\n%s" (extern_atom id) s)) - end - | Sstore(chunk, e1, e2) -> - let te1 = type_expr env [] e1 in - let te2 = type_expr env [] e2 in - begin try - unify tint te1; - unify (type_chunk chunk) te2 - with Error s -> - raise (Error (sprintf "In store %s:\n%s" - (name_of_chunk chunk) s)) - end - | Scall(optid, 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; - let ty_res = - match sg.sig_res with - | None -> tint (*???*) - | Some t -> ty_of_typ t in - begin match optid with - | None -> () - | Some id -> unify (type_var env id) ty_res - end - with Error s -> - raise (Error (sprintf "In call:\n%s" s)) - end - | Salloc(id, e) -> - let tid = type_var env id in - let te = type_expr env [] e in - begin try - unify tint te; - unify tint tid - with Error s -> - raise (Error (sprintf "In alloc:\n%s" s)) - end - | Sseq(s1, s2) -> - type_stmt env blk ret s1; - type_stmt env blk ret s2 - | Sifthenelse(ce, s1, s2) -> - type_condexpr env [] ce; - type_stmt env blk ret s1; - type_stmt env blk ret s2 - | Sloop s1 -> - type_stmt env blk ret s1 - | Sblock s1 -> - type_stmt env (blk + 1) ret s1 - | Sexit n -> - if camlint_of_nat n >= blk then - raise (Error (sprintf "Bad exit(%d)\n" (camlint_of_nat n))) - | Sswitch(e, cases, deflt) -> - unify (type_expr env [] e) tint - | Sreturn None -> - begin match ret with - | None -> () - | Some tret -> raise (Error ("return without argument")) - end - | Sreturn (Some e) -> - begin match ret with - | None -> raise (Error "return with argument") - | Some tret -> - begin try - unify (type_expr env [] e) (ty_of_typ tret) - with Error 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 - | Slabel(lbl, s1) -> - type_stmt env blk ret s1 - | Sgoto lbl -> - () - -let rec env_of_vars idl = - match idl with - | [] -> [] - | id1 :: idt -> (id1, newvar()) :: env_of_vars idt - -let type_function id f = - try - type_stmt - (env_of_vars f.fn_vars @ env_of_vars f.fn_params) - 0 f.fn_sig.sig_res f.fn_body - with Error s -> - raise (Error (sprintf "In function %s:\n%s" (extern_atom id) s)) - -let type_fundef (Coq_pair (id, fd)) = - match fd with - | Internal f -> type_function id f - | External ef -> () - -let type_program p = - List.iter type_fundef p.prog_funct; p diff --git a/caml/CMtypecheck.mli b/caml/CMtypecheck.mli deleted file mode 100644 index 44c7654..0000000 --- a/caml/CMtypecheck.mli +++ /dev/null @@ -1,19 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -exception Error of string - -val type_program: Cminor.program -> Cminor.program - diff --git a/caml/Camlcoq.ml b/caml/Camlcoq.ml deleted file mode 100644 index 98fd79c..0000000 --- a/caml/Camlcoq.ml +++ /dev/null @@ -1,130 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(* Library of useful Caml <-> Coq conversions *) - -open Datatypes -open CList -open BinPos -open BinInt - -(* Integers *) - -let rec camlint_of_positive = function - | Coq_xI p -> Int32.add (Int32.shift_left (camlint_of_positive p) 1) 1l - | Coq_xO p -> Int32.shift_left (camlint_of_positive p) 1 - | Coq_xH -> 1l - -let camlint_of_z = function - | Z0 -> 0l - | Zpos p -> camlint_of_positive p - | Zneg p -> Int32.neg (camlint_of_positive p) - -let camlint_of_coqint : Integers.int -> int32 = camlint_of_z - -let rec camlint_of_nat = function - | O -> 0 - | S n -> camlint_of_nat n + 1 - -let rec nat_of_camlint n = - assert (n >= 0l); - if n = 0l then O else S (nat_of_camlint (Int32.sub n 1l)) - -let rec positive_of_camlint n = - if n = 0l then assert false else - if n = 1l then Coq_xH else - if Int32.logand n 1l = 0l - then Coq_xO (positive_of_camlint (Int32.shift_right_logical n 1)) - else Coq_xI (positive_of_camlint (Int32.shift_right_logical n 1)) - -let z_of_camlint n = - if n = 0l then Z0 else - if n > 0l then Zpos (positive_of_camlint n) - else Zneg (positive_of_camlint (Int32.neg n)) - -let coqint_of_camlint (n: int32) : Integers.int = - (* Interpret n as unsigned so that resulting Z is in range *) - if n = 0l then Z0 else Zpos (positive_of_camlint n) - -(* 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) -let next_atom = ref Coq_xH - -let intern_string s = - try - Hashtbl.find atom_of_string s - with Not_found -> - let a = !next_atom in - next_atom := coq_Psucc !next_atom; - Hashtbl.add atom_of_string s a; - Hashtbl.add string_of_atom a s; - a - -let extern_atom a = - try - Hashtbl.find string_of_atom a - with Not_found -> - Printf.sprintf "" (camlint_of_positive a) - -(* 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 *) - -(* -let timers = (Hashtbl.create 9 : (string, float) Hashtbl.t) - -let add_to_timer name time = - let old = try Hashtbl.find timers name with Not_found -> 0.0 in - Hashtbl.replace timers name (old +. time) - -let time name fn arg = - let start = Unix.gettimeofday() in - try - let res = fn arg in - add_to_timer name (Unix.gettimeofday() -. start); - res - with x -> - add_to_timer name (Unix.gettimeofday() -. start); - raise x - -let print_timers () = - Hashtbl.iter - (fun name time -> Printf.printf "%-20s %.3f\n" name time) - timers - -let _ = at_exit print_timers -*) diff --git a/caml/Cil2Csyntax.ml b/caml/Cil2Csyntax.ml deleted file mode 100644 index 41fe1d4..0000000 --- a/caml/Cil2Csyntax.ml +++ /dev/null @@ -1,992 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Thomas Moniot, INRIA Paris-Rocquencourt *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(************************************************************************** -CIL -> CabsCoq translator -**************************************************************************) - -open Cil -open CList -open Camlcoq -open AST -open Csyntax - - - - -module type TypeSpecifierTranslator = - sig - val convertIkind: Cil.ikind -> (intsize * signedness) option - val convertFkind: Cil.fkind -> floatsize option - end - - - - - -module Make(TS: TypeSpecifierTranslator) = struct -(*-----------------------------------------------------------------------*) - - -(** Pre-defined constants *) -let constInt32 = Tint (I32, Signed) -let constInt32uns = Tint (I32, Unsigned) -let const0 = Expr (Econst_int (coqint_of_camlint Int32.zero), constInt32) - - -(** Global variables *) -let currentLocation = ref Cil.locUnknown -let currentGlobalPrefix = ref "" -let stringNum = ref 0 (* number of next global for string literals *) -let stringTable = Hashtbl.create 47 - -(** ** Functions related to [struct]s and [union]s *) - -(* Unroll recursion in struct or union types: - substitute [Tcomp_ptr id] by [Tpointer compty] in [ty]. *) - -let unrollType id compty ty = - let rec unrType ty = - match ty with - | Tvoid -> ty - | Tint(sz, sg) -> ty - | Tfloat sz -> ty - | Tpointer ty -> Tpointer (unrType ty) - | Tarray(ty, sz) -> Tarray (unrType ty, sz) - | Tfunction(args, res) -> Tfunction(unrTypelist args, unrType res) - | Tstruct(id', fld) -> - if id' = id then ty else Tstruct(id', unrFieldlist fld) - | Tunion(id', fld) -> - if id' = id then ty else Tunion(id', unrFieldlist fld) - | Tcomp_ptr id' -> - if id' = id then Tpointer compty else ty - and unrTypelist = function - | Tnil -> Tnil - | Tcons(hd, tl) -> Tcons(unrType hd, unrTypelist tl) - and unrFieldlist = function - | Fnil -> Fnil - | Fcons(id, ty, tl) -> Fcons(id, unrType ty, unrFieldlist tl) - in unrType ty - -(* Return the type of a [struct] field *) -let rec getFieldType f = function - | Fnil -> raise Not_found - | Fcons(idf, t, rem) -> if idf = f then t else getFieldType f rem - -(** ** Some functions over lists *) - -(** Keep the elements in a list from [elt] (included) to the end - (used for the translation of the [switch] statement) *) -let rec keepFrom elt = function - | [] -> [] - | (x :: l) as l' -> if x == elt then l' else keepFrom elt l - -(** Keep the elements in a list before [elt'] (excluded) - (used for the translation of the [switch] statement) *) -let rec keepUntil elt' = function - | [] -> [] - | x :: l -> if x == elt' then [] else x :: (keepUntil elt' l) - -(** Keep the elements in a list from [elt] (included) to [elt'] (excluded) - (used for the translation of the [switch] statement) *) -let keepBetween elt elt' l = - keepUntil elt' (keepFrom elt l) - -(** ** Functions used to handle locations *) - -(** Update the current location *) -let updateLoc loc = - currentLocation := loc - -(** Convert the current location into a string *) -let currentLoc() = - match !currentLocation with { line=l; file=f } -> - f ^ ":" ^ (if l = -1 then "?" else string_of_int l) ^ ": " - -(** Exception raised when an unsupported feature is encountered *) -exception Unsupported of string -let unsupported msg = - raise (Unsupported(currentLoc() ^ "Unsupported C feature: " ^ msg)) - -(** Exception raised when an internal error is encountered *) -exception Internal_error of string -let internal_error msg = - raise (Internal_error(currentLoc() ^ "Internal error: " ^ msg)) - -(** Warning messages *) -let warning msg = - prerr_string (currentLoc()); - prerr_string "Warning: "; - prerr_endline msg - -(** ** Functions used to handle string literals *) -let name_for_string_literal s = - try - Hashtbl.find stringTable s - with Not_found -> - incr stringNum; - let symbol_name = - Printf.sprintf "_%s__stringlit_%d" - !currentGlobalPrefix !stringNum in - let symbol_ident = intern_string symbol_name in - Hashtbl.add stringTable s symbol_ident; - symbol_ident - -let typeStringLiteral s = - Tarray(Tint(I8, Unsigned), z_of_camlint(Int32.of_int(String.length s + 1))) - -let global_for_string s id = - let init = ref [] in - let add_char c = - init := - AST.Init_int8(coqint_of_camlint(Int32.of_int(Char.code c))) - :: !init in - add_char '\000'; - for i = String.length s - 1 downto 0 do add_char s.[i] done; - Datatypes.Coq_pair(Datatypes.Coq_pair(id, !init), typeStringLiteral s) - -let globals_for_strings globs = - Hashtbl.fold - (fun s id l -> global_for_string s id :: l) - stringTable globs - -(** ** Handling of stubs for variadic functions *) - -let stub_function_table = Hashtbl.create 47 - -let register_stub_function name tres targs = - let rec letters_of_type = function - | Tnil -> [] - | Tcons(Tfloat _, tl) -> "f" :: letters_of_type tl - | Tcons(_, tl) -> "i" :: letters_of_type tl in - let stub_name = - name ^ "$" ^ String.concat "" (letters_of_type targs) in - try - (stub_name, Hashtbl.find stub_function_table stub_name) - with Not_found -> - let rec types_of_types = function - | Tnil -> Tnil - | Tcons(Tfloat _, tl) -> Tcons(Tfloat F64, types_of_types tl) - | Tcons(_, tl) -> Tcons(Tpointer Tvoid, types_of_types tl) in - let stub_type = Tfunction (types_of_types targs, tres) in - Hashtbl.add stub_function_table stub_name stub_type; - (stub_name, stub_type) - -let declare_stub_function stub_name stub_type = - match stub_type with - | Tfunction(targs, tres) -> - Datatypes.Coq_pair(intern_string stub_name, - External(intern_string stub_name, targs, tres)) - | _ -> assert false - -let declare_stub_functions k = - Hashtbl.fold (fun n i k -> declare_stub_function n i :: k) - stub_function_table k - -(** ** Generation of temporary variable names *) - -let current_function = ref (None: Cil.fundec option) - -let make_temp typ = - match !current_function with - | None -> assert false - | Some f -> - let v = Cil.makeTempVar f typ in - intern_string v.vname - -(** Detect and report GCC's __builtin_ functions *) - -let check_builtin s = - let b = "__builtin_" in - if String.length s >= String.length b - && String.sub s 0 (String.length b) = b - then unsupported ("GCC `" ^ s ^ "' built-in function") - -(** ** Translation functions *) - -(** Convert a [Cil.ikind] into a pair [(intsize * signedness)] *) -let convertIkind ik = - match TS.convertIkind ik with - | Some p -> p - | None -> unsupported "integer type specifier" - - -(** Convert a [Cil.fkind] into a [floatsize] *) -let convertFkind fk = - match TS.convertFkind fk with - | Some fs -> fs - | None -> unsupported "floating-point type specifier" - - -(** Convert a [Cil.constant] into a [CabsCoq.expr] *) -let rec convertConstant = function - | CInt64 (i64, _, _) -> - let i = coqint_of_camlint (Int64.to_int32 i64) in - Expr (Econst_int i, constInt32) - | CStr s -> - let symb = name_for_string_literal s in - Expr (Evar symb, typeStringLiteral s) - | CWStr _ -> - unsupported "wide string literal" - | CChr c -> - let i = coqint_of_camlint (Int32.of_int (Char.code c)) in - Expr (Econst_int i, constInt32) - | CReal (f, _, _) -> - Expr (Econst_float f, Tfloat F64) - | (CEnum (exp, str, enumInfo)) as enum -> - (* do constant folding on an enum constant *) - let e = Cil.constFold false (Const enum) in - convertExp e - - -(** Convert a [Cil.UnOp] into a [CabsCoq.expr] - ([t] is the type of the result of applying [uop] to [e]) *) -and convertUnop uop e t = - let e' = convertExp e in - let t' = convertTyp t in - let uop' = match uop with - | Neg -> Eunop (Oneg, e') - | BNot -> Eunop (Onotint, e') - | LNot -> Eunop (Onotbool, e') - in - Expr (uop', t') - - -(** Convert a [Cil.BinOp] into a [CabsCoq.expr] - ([t] is the type of the result of applying [bop] to [(e1, e2)], every - arithmetic conversion being made explicit by CIL for both arguments] *) -and convertBinop bop e1 e2 t = - let e1' = convertExp e1 in - let e2' = convertExp e2 in - let t' = convertTyp t in - let bop' = match bop with - | PlusA -> Ebinop (Oadd, e1', e2') - | PlusPI -> Ebinop (Oadd, e1', e2') - | IndexPI -> Ebinop (Oadd, e1', e2') - | MinusA -> Ebinop (Osub, e1', e2') - | MinusPI -> Ebinop (Osub, e1', e2') - | MinusPP -> Ebinop (Osub, e1', e2') - | Mult -> Ebinop (Omul, e1', e2') - | Div -> Ebinop (Odiv, e1', e2') - | Mod -> Ebinop (Omod, e1', e2') - | Shiftlt -> Ebinop (Oshl, e1', e2') - | Shiftrt -> Ebinop (Oshr, e1', e2') - | Lt -> Ebinop (Olt, e1', e2') - | Gt -> Ebinop (Ogt, e1', e2') - | Le -> Ebinop (Ole, e1', e2') - | Ge -> Ebinop (Oge, e1', e2') - | Eq -> Ebinop (Oeq, e1', e2') - | Ne -> Ebinop (One, e1', e2') - | BAnd -> Ebinop (Oand, e1', e2') - | BXor -> Ebinop (Oxor, e1', e2') - | BOr -> Ebinop (Oor, e1', e2') - | LAnd -> Eandbool (e1', e2') - | LOr -> Eorbool (e1', e2') - in - Expr (bop', t') - - -(** Test if two types are compatible - (in order to cast one of the types to the other) *) -and compatibleTypes t1 t2 = true -(* - let isArithmeticType = function - | Tint _ | Tfloat _ -> true - | _ -> false - in - let isPointerType = function - | Tpointer _ | Tarray _ -> true - | _ -> false - in - (t1 = t2) - || (isArithmeticType t1 && isArithmeticType t2) - || match (t1, t2) with - | (Tpointer Tvoid, t) | (t, Tpointer Tvoid) -> isPointerType t - | (Tint _, t) | (t, Tint _) -> isPointerType t - | _ -> false -*) - - -(** Convert a [Cil.CastE] into a [CabsCoq.expr] - (fail if the cast is illegal) *) -and processCast t e = - let t' = convertTyp t in - let te = convertTyp (Cil.typeOf e) in - if compatibleTypes t' te then - let e' = convertExp e in - Expr (Ecast (t', e'), t') - else internal_error "processCast: illegal cast" - - -(** Convert a [Cil.exp list] into an [CamlCoq.exprlist] *) -and processParamsE = function - | [] -> [] - | e :: l -> - let (Expr (_, t)) as e' = convertExp e in - match t with - | Tstruct _ | Tunion _ -> - unsupported "function parameter of struct or union type" - | _ -> e' :: processParamsE l - - -(** Convert a [Cil.exp] into a [CabsCoq.expr] *) -and convertExp = function - | Const c -> - convertConstant c - | Lval lv -> - convertLval lv - | SizeOf t -> - Expr (Esizeof (convertTyp t), constInt32uns) - | SizeOfE e -> - let ty = convertTyp (Cil.typeOf e) in - Expr (Esizeof ty, constInt32uns) - | SizeOfStr str -> - let n = coqint_of_camlint (Int32.of_int(String.length str)) in - Expr (Econst_int n, constInt32uns) - | AlignOf t -> - unsupported "GCC `alignof' construct" - | AlignOfE e -> - unsupported "GCC `alignof' construct" - | UnOp (uop, e, t) -> - convertUnop uop e t - | BinOp (bop, e1, e2, t) -> - convertBinop bop e1 e2 t - | CastE (t, e) -> - processCast t e - | AddrOf lv -> - let (Expr (_, t)) as e = convertLval lv in - Expr (Eaddrof e, Tpointer t) - | StartOf lv -> - (* convert an array into a pointer to the beginning of the array *) - match Cil.unrollType (Cil.typeOfLval lv) with - | TArray (t, _, _) -> - let t' = convertTyp t in - let tPtr = Tpointer t' in - let e = convertLval lv in - (* array A of type T replaced by (T* )A *) - Expr (Ecast (tPtr, e), tPtr) - | _ -> internal_error "convertExp: StartOf applied to a \ - lvalue whose type is not an array" - - -(** Convert a [Cil.lval] into a [CabsCoq.expression] *) -and convertLval lv = - (* convert the offset of the lvalue *) - let rec processOffset ((Expr (_, t)) as e) = function - | NoOffset -> e - | Field (f, ofs) -> - begin match t with - | Tstruct(id, fList) -> - begin try - let idf = intern_string f.fname in - let t' = unrollType id t (getFieldType idf fList) in - processOffset (Expr (Efield (e, idf), t')) ofs - with Not_found -> - internal_error "processOffset: no such struct field" - end - | Tunion(id, fList) -> - begin try - let idf = intern_string f.fname in - let t' = unrollType id t (getFieldType idf fList) in - processOffset (Expr (Efield (e, idf), t')) ofs - with Not_found -> - internal_error "processOffset: no such union field" - end - | _ -> - internal_error "processOffset: Field on a non-struct nor union" - end - | Index (e', ofs) -> - match t with - | Tarray (t', _) -> - let e'' = Ederef(Expr (Ebinop(Oadd, e, convertExp e'), t)) in - processOffset (Expr (e'', t')) ofs - | _ -> internal_error "processOffset: Index on a non-array" - in - (* convert the lvalue *) - match lv with - | (Var v, ofs) -> - check_builtin v.vname; - let id = intern_string v.vname in - processOffset (Expr (Evar id, convertTyp v.vtype)) ofs - | (Mem e, ofs) -> - match Cil.unrollType (Cil.typeOf e) with - | TPtr (t, _) -> let e' = Ederef (convertExp e) in - processOffset (Expr (e', convertTyp t)) ofs - | _ -> internal_error "convertLval: Mem on a non-pointer" - - -(** Convert a [(Cil.string * Cil.typ * Cil.attributes)] list - into a [typelist] *) -and processParamsT convert = function - | [] -> Tnil - | (_, t, _) :: l -> - let t' = convert t in - match t' with - | Tstruct _ | Tunion _ -> - unsupported "function parameter of struct or union type" - | _ -> Tcons (t', processParamsT convert l) - - -(** Convert a [Cil.typ] into a [coq_type] *) -and convertTypGen env = function - | TVoid _ -> Tvoid - | TInt (k, _) -> let (x, y) = convertIkind k in Tint (x, y) - | TFloat (k, _) -> Tfloat (convertFkind k) - | TPtr (TComp(c, _), _) when List.mem c.ckey env -> - Tcomp_ptr (intern_string (Cil.compFullName c)) - | TPtr (t, _) -> Tpointer (convertTypGen env t) - | TArray (t, eOpt, _) -> - begin match eOpt with - | None -> - warning "array type of unspecified size"; - Tarray (convertTypGen env t, coqint_of_camlint 0l) - | Some e -> - match Cil.constFold true e with - | Const (CInt64 (i64, _, _)) -> - Tarray (convertTypGen env t, - coqint_of_camlint (Int64.to_int32 i64)) - | _ -> unsupported "size of array type not an integer constant" - end - | TFun (t, argListOpt, vArg, _) -> - if vArg then unsupported "variadic function type"; - let argList = - match argListOpt with - | None -> unsupported "un-prototyped function type" - | Some l -> l - in - let t' = convertTypGen env t in - begin match t' with - | Tstruct _ | Tunion _ -> - unsupported "return type is a struct or union" - | _ -> Tfunction (processParamsT (convertTypGen env) argList, t') - end - | TNamed (tinfo, _) -> convertTypGen env tinfo.ttype - | TComp (c, _) -> - let rec convertFieldList = function - | [] -> Fnil - | {fname=str; ftype=t} :: rem -> - let idf = intern_string str in - let t' = convertTypGen (c.ckey :: env) t in - Fcons(idf, t', convertFieldList rem) in - let fList = convertFieldList c.cfields in - let id = intern_string (Cil.compFullName c) in - if c.cstruct then Tstruct(id, fList) else Tunion(id, fList) - | TEnum _ -> constInt32 (* enum constants are integers *) - | TBuiltin_va_list _ -> unsupported "GCC `builtin va_list' type" - -and convertTyp ty = convertTypGen [] ty - -(** Convert a [Cil.varinfo] into a pair [(ident * coq_type)] *) -let convertVarinfo v = - updateLoc(v.vdecl); - let id = intern_string v.vname in - Datatypes.Coq_pair (id, convertTyp v.vtype) - - -(** Convert a [Cil.varinfo] into a pair [(ident * coq_type)] - (fail if the variable is of type struct or union) *) -let convertVarinfoParam v = - updateLoc(v.vdecl); - let id = intern_string v.vname in - let t' = convertTyp v.vtype in - match t' with - | Tstruct _ | Tunion _ -> - unsupported "function parameter of struct or union type" - | _ -> Datatypes.Coq_pair (id, t') - - -(** Convert a [Cil.exp] which has a function type into a [CabsCoq.expr] - (used only to translate function calls) *) -let convertExpFuncall e eList = - match typeOf e with - | TFun (res, argListOpt, vArg, _) -> - begin match argListOpt, vArg with - | Some argList, false -> - (* Prototyped, non-variadic function *) - if List.length argList <> List.length eList then - internal_error "convertExpFuncall: wrong number of arguments"; - (convertExp e, processParamsE eList) - | _, _ -> - (* Variadic or unprototyped function: generate a call to - a stub function with the appropriate number and types - of arguments. Works only if the function expression e - is a global variable. *) - let params = processParamsE eList in - let fun_name = - match e with - | Lval(Var v, NoOffset) -> - warning "working around a call to a variadic function"; - v.vname - | _ -> - unsupported "call to variadic function" in - let rec typeOfExprList = function - | [] -> Tnil - | Expr (_, ty) :: rem -> Tcons (ty, typeOfExprList rem) in - let targs = typeOfExprList params in - let tres = convertTyp res in - let (stub_fun_name, stub_fun_typ) = - register_stub_function fun_name tres targs in - (Expr(Evar(intern_string stub_fun_name), stub_fun_typ), - params) - end - | _ -> internal_error "convertExpFuncall: not a function" - -(** Auxiliaries for function calls *) - -let makeFuncall1 tyfun (Expr(_, tlhs) as elhs) efun eargs = - match tyfun with - | TFun (t, _, _, _) -> - let tres = convertTyp t in - if tlhs = tres then - Scall(Datatypes.Some elhs, efun, eargs) - else begin - let tmp = make_temp t in - let elhs' = Expr(Evar tmp, tres) in - Ssequence(Scall(Datatypes.Some elhs', efun, eargs), - Sassign(elhs, Expr(Ecast(tlhs, elhs'), tlhs))) - end - | _ -> internal_error "wrong type for function in call" - -let makeFuncall2 tyfun tylhs elhs efun eargs = - match elhs with - | Expr(Evar _, _) -> - makeFuncall1 tyfun elhs efun eargs - | Expr(_, tlhs) -> - let tmp = make_temp tylhs in - let elhs' = Expr(Evar tmp, tlhs) in - Ssequence(makeFuncall1 tyfun elhs' efun eargs, - Sassign(elhs, elhs')) - - -(** Convert a [Cil.instr list] into a [CabsCoq.statement] *) -let rec processInstrList l = - (* convert an instruction *) - let convertInstr = function - | Set (lv, e, loc) -> - updateLoc(loc); - begin match convertTyp (Cil.typeOf e) with - | Tstruct _ | Tunion _ -> unsupported "struct or union assignment" - | t -> Sassign (convertLval lv, convertExp e) - end - | Call (None, e, eList, loc) -> - updateLoc(loc); - let (efun, params) = convertExpFuncall e eList in - Scall(Datatypes.None, efun, params) - | Call (Some lv, e, eList, loc) -> - updateLoc(loc); - let (efun, params) = convertExpFuncall e eList in - makeFuncall2 (Cil.typeOf e) (Cil.typeOfLval lv) (convertLval lv) efun params - | Asm (_, _, _, _, _, loc) -> - updateLoc(loc); - unsupported "inline assembly" - in - (* convert a list of instructions *) - match l with - | [] -> Sskip - | [s] -> convertInstr s - | s :: l -> - let cs = convertInstr s in - let cl = processInstrList l in - Ssequence (cs, cl) - - -(** Convert a [Cil.stmt list] into a [CabsCoq.statement] *) -let rec processStmtList = function - | [] -> Sskip - | [s] -> convertStmt s - | s :: l -> - let cs = convertStmt s in - let cl = processStmtList l in - Ssequence (cs, cl) - - -(** Return the list of the constant expressions in a label list - (return [None] if this is the default case) - (fail if the constant expression is not of type integer) *) -and getCaseList lblList = - match lblList with - | [] -> Some [] - | Label (_, loc, _) :: l -> updateLoc(loc); getCaseList l - | Default loc :: _ -> updateLoc(loc); None - | Case (e, loc) :: l -> - updateLoc(loc); - begin match convertExp e with - | Expr (Econst_int n, _) -> - begin match getCaseList l with - | None -> None - | Some cl -> Some (n :: cl) - end - | _ -> internal_error "getCaseList: case label does not \ - reduce to an integer constant" - end - - -(** Convert a list of integers into a [CabsCoq.lblStatementList] *) -and processCaseList cl s lrem = - match cl with - | [] -> internal_error "processCaseList: syntax error in switch statement" - | [n] -> LScase (n, s, lrem) - | n1 :: l -> LScase (n1, Sskip, processCaseList l s lrem) - - -(** Convert a [Cil.stmt list] which is the body of a Switch structure - into a [CabsCoq.lblStatementList] - (Pre-condition: all the Case labels are supposed to be at the same level, - ie. no nested structures) *) -and processLblStmtList switchBody = function - | [] -> LSdefault Sskip - | [ls] -> - let s = processStmtList (keepFrom ls switchBody) in - begin match getCaseList ls.labels with - | None -> LSdefault s - | Some cl -> processCaseList cl s (LSdefault Sskip) - end - | ls :: ((ls' :: _) as l) -> - if ls.labels = ls'.labels then processLblStmtList switchBody l - else - begin match getCaseList ls.labels with - | None -> unsupported "default case is not at the end of this `switch' statement" - | Some cl -> - let s = processStmtList (keepBetween ls ls' switchBody) in - let lrem = processLblStmtList switchBody l in - processCaseList cl s lrem - end - - -(** Convert a [Cil.stmt] into a [CabsCoq.statement] *) -and convertStmt s = - match s.skind with - | Instr iList -> processInstrList iList - | Return (eOpt, loc) -> - updateLoc(loc); - let eOpt' = match eOpt with - | None -> Datatypes.None - | Some e -> Datatypes.Some (convertExp e) - in - Sreturn eOpt' - | Goto (_, loc) -> - updateLoc(loc); - unsupported "`goto' statement" - | Break loc -> - updateLoc(loc); - Sbreak - | Continue loc -> - updateLoc(loc); - Scontinue - | If (e, b1, b2, loc) -> - updateLoc(loc); - let e1 = processStmtList b1.bstmts in - let e2 = processStmtList b2.bstmts in - Sifthenelse (convertExp e, e1, e2) - | Switch (e, b, l, loc) -> - updateLoc(loc); - Sswitch (convertExp e, processLblStmtList b.bstmts l) - | While (e, b, loc) -> - updateLoc(loc); - Swhile (convertExp e, processStmtList b.bstmts) - | DoWhile (e, b, loc) -> - updateLoc(loc); - Sdowhile (convertExp e, processStmtList b.bstmts) - | For (bInit, e, bIter, b, loc) -> - updateLoc(loc); - let sInit = processStmtList bInit.bstmts in - let e' = convertExp e in - let sIter = processStmtList bIter.bstmts in - Sfor (sInit, e', sIter, processStmtList b.bstmts) - | Block b -> processStmtList b.bstmts - | TryFinally (_, _, loc) -> - updateLoc(loc); - unsupported "`try'...`finally' statement" - | TryExcept (_, _, _, loc) -> - updateLoc(loc); - unsupported "`try'...`except' statement" - -(** Convert a [Cil.GFun] into a pair [(ident * coq_fundecl)] *) -let convertGFun fdec = - current_function := Some fdec; - let v = fdec.svar in - let ret = match v.vtype with - | TFun (t, _, vArg, _) -> - if vArg then unsupported "variadic function"; - begin match convertTyp t with - | Tstruct _ | Tunion _ -> - unsupported "return value of struct or union type" - | t' -> t' - end - | _ -> internal_error "convertGFun: incorrect function type" - in - let s = processStmtList fdec.sbody.bstmts in (* function body -- do it first because of generated temps *) - let args = List.map convertVarinfoParam fdec.sformals in (* parameters*) - let varList = List.map convertVarinfo fdec.slocals in (* local vars *) - if v.vname = "main" then begin - match ret with - | Tint(_, _) -> () - | _ -> updateLoc v.vdecl; - unsupported "the return type of main() must be an integer type" - end; - current_function := None; - Datatypes.Coq_pair - (intern_string v.vname, - Internal { fn_return=ret; fn_params=args; fn_vars=varList; fn_body=s }) - -(** Auxiliary for [convertInit] *) - -let rec initDataLen accu = function - | [] -> accu - | i1 :: il -> - let sz = match i1 with - | Init_int8 _ -> 1l - | Init_int16 _ -> 2l - | Init_int32 _ -> 4l - | Init_float32 _ -> 4l - | Init_float64 _ -> 8l - | Init_space n -> camlint_of_z n - | Init_pointer _ -> 4l in - initDataLen (Int32.add sz accu) il - -(** Convert a [Cil.init] into a list of [AST.init_data] prepended to - the given list [k]. Result is in reverse order. *) - -(* Cil.constFold does not reduce floating-point operations. - We treat here those that appear naturally in initializers. *) - -type init_constant = - | ICint of int64 * intsize - | ICfloat of float * floatsize - | ICstring of string - | ICnone - -let rec extract_constant e = - match e with - | Const (CInt64(n, ikind, _)) -> - ICint(n, fst (convertIkind ikind)) - | Const (CReal(n, fkind, _)) -> - ICfloat(n, convertFkind fkind) - | Const (CStr s) -> - ICstring s - | CastE (ty, e1) -> - begin match extract_constant e1, convertTyp ty with - | ICfloat(n, _), Tfloat sz -> - ICfloat(n, sz) - | ICint(n, _), Tfloat sz -> - ICfloat(Int64.to_float n, sz) - | ICint(n, sz), Tpointer _ -> - ICint(n, sz) - | ICstring s, (Tint _ | Tpointer _) -> - ICstring s - | _, _ -> - ICnone - end - | UnOp (Neg, e1, _) -> - begin match extract_constant e1 with - | ICfloat(n, sz) -> ICfloat(-. n, sz) - | _ -> ICnone - end - | _ -> ICnone - -let init_data_of_string s = - let id = ref [] in - let enter_char c = - let n = coqint_of_camlint(Int32.of_int(Char.code c)) in - id := Init_int8 n :: !id in - enter_char '\000'; - for i = String.length s - 1 downto 0 do enter_char s.[i] done; - !id - -let convertInit init = - let k = ref [] - and pos = ref 0 in - let emit size datum = - k := datum :: !k; - pos := !pos + size in - let emit_space size = - emit size (Init_space (z_of_camlint (Int32.of_int size))) in - let check_align size = - assert (!pos land (size - 1) = 0) in - let align size = - let n = !pos land (size - 1) in - if n > 0 then emit_space (size - n) in - - let rec cvtInit init = - match init with - | SingleInit e -> - begin match extract_constant(Cil.constFold true e) with - | ICint(n, I8) -> - let n' = coqint_of_camlint (Int64.to_int32 n) in - emit 1 (Init_int8 n') - | ICint(n, I16) -> - check_align 2; - let n' = coqint_of_camlint (Int64.to_int32 n) in - emit 2 (Init_int16 n') - | ICint(n, I32) -> - check_align 4; - let n' = coqint_of_camlint (Int64.to_int32 n) in - emit 4 (Init_int32 n') - | ICfloat(n, F32) -> - check_align 4; - emit 4 (Init_float32 n) - | ICfloat(n, F64) -> - check_align 8; - emit 8 (Init_float64 n) - | ICstring s -> - check_align 4; - emit 4 (Init_pointer(init_data_of_string s)) - | ICnone -> - unsupported "this kind of expression is not supported in global initializers" - end - | CompoundInit(ty, data) -> - let ty' = convertTyp ty in - let sz = Int32.to_int (camlint_of_z (Csyntax.sizeof ty')) in - let pos0 = !pos in - Cil.foldLeftCompoundAll - ~doinit: cvtCompoundInit - ~ct: ty - ~initl: data - ~acc: (); - let pos1 = !pos in - assert (pos1 <= pos0 + sz); - if pos1 < pos0 + sz then emit_space (pos0 + sz - pos1) - - and cvtCompoundInit ofs init ty () = - let ty' = convertTyp ty in - let al = Int32.to_int (camlint_of_z (Csyntax.alignof ty')) in - align al; - cvtInit init - - in cvtInit init; CList.rev !k - -(** Convert a [Cil.initinfo] into a list of [AST.init_data] *) - -let convertInitInfo ty info = - match info.init with - | None -> - [ Init_space(Csyntax.sizeof (convertTyp ty)) ] - | Some init -> - convertInit init - -(** Convert a [Cil.GVar] into a global variable definition *) - -let convertGVar v i = - updateLoc(v.vdecl); - let id = intern_string v.vname in - Datatypes.Coq_pair (Datatypes.Coq_pair(id, convertInitInfo v.vtype i), - convertTyp v.vtype) - - -(** Convert a [Cil.GVarDecl] into a global variable declaration *) - -let convertExtVar v = - updateLoc(v.vdecl); - let id = intern_string v.vname in - Datatypes.Coq_pair (Datatypes.Coq_pair(id, []), - convertTyp v.vtype) - -(** Convert a [Cil.GVarDecl] into an external function declaration *) - -let convertExtFun v = - updateLoc(v.vdecl); - match convertTyp v.vtype with - | Tfunction(args, res) -> - let id = intern_string v.vname in - Datatypes.Coq_pair (id, External(id, args, res)) - | _ -> - assert false - -(** Convert a [Cil.global list] into a pair whose first component, - of type [(ident * coq_function) coqlist], represents the definitions of the - functions and the second component, of type [(ident * coq_type) coqlist], - the definitions of the global variables of the program *) -let rec processGlobals = function - | [] -> ([], []) - | g :: l -> - match g with - | GType _ -> processGlobals l (* typedefs are unrolled... *) - | GCompTag _ -> processGlobals l - | GCompTagDecl _ -> processGlobals l - | GEnumTag _ -> processGlobals l (* enum constants are folded... *) - | GEnumTagDecl _ -> processGlobals l - | GVarDecl (v, loc) -> - updateLoc(loc); - (* Functions become external declarations, - variadic and unprototyped functions are skipped, - variables become uninitialized variables *) - begin match Cil.unrollType v.vtype with - | TFun (tres, Some targs, false, _) -> - let fn = convertExtFun v in - let (fList, vList) = processGlobals l in - (fn :: fList, vList) - | TFun (tres, _, _, _) -> - processGlobals l - | _ -> - let var = convertExtVar v in - let (fList, vList) = processGlobals l in - (fList, var :: vList) - end - | GVar (v, init, loc) -> - updateLoc(loc); - let var = convertGVar v init in - let (fList, vList) = processGlobals l in - (fList, var :: vList) - | GFun (fdec, loc) -> - updateLoc(loc); - let fn = convertGFun fdec in - let (fList, vList) = processGlobals l in - (fn :: fList, vList) - | GAsm (_, loc) -> - updateLoc(loc); - unsupported "inline assembly" - | GPragma (_, loc) -> - updateLoc(loc); - warning "#pragma directive ignored"; - processGlobals l - | GText _ -> processGlobals l (* comments are ignored *) - -(** Eliminate forward declarations of globals that are defined later *) - -let cleanupGlobals globs = - let defined = - List.fold_right - (fun g def -> - match g with GVar (v, init, loc) -> v.vname :: def - | GFun (fdec, loc) -> fdec.svar.vname :: def - | _ -> def) - globs [] in - List.filter - (function GVarDecl(v, loc) -> not(List.mem v.vname defined) - | g -> true) - globs - -(** Convert a [Cil.file] into a [CabsCoq.program] *) -let convertFile f = - currentGlobalPrefix := - Filename.chop_extension (Filename.basename f.fileName); - stringNum := 0; - Hashtbl.clear stringTable; - Hashtbl.clear stub_function_table; - let (funList, defList) = processGlobals (cleanupGlobals f.globals) in - let funList' = declare_stub_functions funList in - let funList'' = match f.globinit with - | Some fdec -> convertGFun fdec :: funList' - | None -> funList' in - let defList' = globals_for_strings defList in - { AST.prog_funct = funList''; - AST.prog_vars = defList'; - AST.prog_main = intern_string "main" } - - -(*-----------------------------------------------------------------------*) -end - diff --git a/caml/Clflags.ml b/caml/Clflags.ml deleted file mode 100644 index 08e4a53..0000000 --- a/caml/Clflags.ml +++ /dev/null @@ -1,25 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(* Command-line flags *) - -let prepro_options = ref ([]: string list) -let linker_options = ref ([]: string list) -let exe_name = ref "a.out" -let option_flonglong = ref false -let option_fmadd = ref false -let option_dclight = ref false -let option_dasm = ref false -let option_E = ref false -let option_S = ref false -let option_c = ref false -let option_v = ref false diff --git a/caml/Coloringaux.ml b/caml/Coloringaux.ml deleted file mode 100644 index f11738d..0000000 --- a/caml/Coloringaux.ml +++ /dev/null @@ -1,625 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -open Camlcoq -open Datatypes -open BinPos -open BinInt -open AST -open Maps -open Registers -open Locations -open RTL -open RTLtyping -open InterfGraph -open Conventions - -(* George-Appel graph coloring *) - -(* \subsection{Internal representation of the interference graph} *) - -(* To implement George-Appel coloring, we first transform the representation - of the interference graph, switching to the following - imperative representation that is well suited to the coloring algorithm. *) - -(* Each node of the graph (i.e. each pseudo-register) is represented as - follows. *) - -type node = - { ident: reg; (*r register identifier *) - typ: typ; (*r its type *) - regclass: int; (*r identifier of register class *) - spillcost: float; (*r estimated cost of spilling *) - mutable adjlist: node list; (*r all nodes it interferes with *) - mutable degree: int; (*r number of adjacent nodes *) - mutable movelist: move list; (*r list of moves it is involved in *) - mutable alias: node option; (*r [Some n] if coalesced with [n] *) - mutable color: loc option; (*r chosen color *) - mutable nstate: nodestate; (*r in which set of nodes it is *) - mutable nprev: node; (*r for double linking *) - mutable nnext: node (*r for double linking *) - } - -(* These are the possible states for nodes. *) - -and nodestate = - | Colored - | Initial - | SimplifyWorklist - | FreezeWorklist - | SpillWorklist - | CoalescedNodes - | SelectStack - -(* Each move (i.e. wish to be put in the same location) is represented - as follows. *) - -and move = - { src: node; (*r source of the move *) - dst: node; (*r destination of the move *) - mutable mstate: movestate; (*r in which set of moves it is *) - mutable mprev: move; (*r for double linking *) - mutable mnext: move (*r for double linking *) - } - -(* These are the possible states for moves *) - -and movestate = - | CoalescedMoves - | ConstrainedMoves - | FrozenMoves - | WorklistMoves - | ActiveMoves - -(* The algorithm manipulates partitions of the nodes and of the moves - according to their states, frequently moving a node or a move from - a state to another, and frequently enumerating all nodes or all moves - of a given state. To support these operations efficiently, - nodes or moves having the same state are put into imperative doubly-linked - lists, allowing for constant-time insertion and removal, and linear-time - scanning. We now define the operations over these doubly-linked lists. *) - -module DLinkNode = struct - type t = node - let make state = - let rec empty = - { ident = Coq_xH; typ = Tint; regclass = 0; - adjlist = []; degree = 0; spillcost = 0.0; - movelist = []; alias = None; color = None; - nstate = state; nprev = empty; nnext = empty } - in empty - let dummy = make Colored - let clear dl = dl.nnext <- dl; dl.nprev <- dl - let notempty dl = dl.nnext != dl - let insert n dl = - n.nstate <- dl.nstate; - n.nnext <- dl.nnext; n.nprev <- dl; - dl.nnext.nprev <- n; dl.nnext <- n - let remove n dl = - assert (n.nstate = dl.nstate); - n.nnext.nprev <- n.nprev; n.nprev.nnext <- n.nnext - let move n dl1 dl2 = - remove n dl1; insert n dl2 - let pick dl = - let n = dl.nnext in remove n dl; n - let iter f dl = - let rec iter n = if n != dl then (f n; iter n.nnext) - in iter dl.nnext - let fold f dl accu = - let rec fold n accu = if n == dl then accu else fold n.nnext (f n accu) - in fold dl.nnext accu -end - -module DLinkMove = struct - type t = move - let make state = - let rec empty = - { src = DLinkNode.dummy; dst = DLinkNode.dummy; - mstate = state; mprev = empty; mnext = empty } - in empty - let dummy = make CoalescedMoves - let clear dl = dl.mnext <- dl; dl.mprev <- dl - let notempty dl = dl.mnext != dl - let insert m dl = - m.mstate <- dl.mstate; - m.mnext <- dl.mnext; m.mprev <- dl; - dl.mnext.mprev <- m; dl.mnext <- m - let remove m dl = - assert (m.mstate = dl.mstate); - m.mnext.mprev <- m.mprev; m.mprev.mnext <- m.mnext - let move m dl1 dl2 = - remove m dl1; insert m dl2 - let pick dl = - let m = dl.mnext in remove m dl; m - let iter f dl = - let rec iter m = if m != dl then (f m; iter m.mnext) - in iter dl.mnext - let fold f dl accu = - let rec fold m accu = if m == dl then accu else fold m.mnext (f m accu) - in fold dl.mnext accu -end - -(* \subsection{The George-Appel algorithm} *) - -(* Below is a straigthforward translation of the pseudo-code at the end - of the TOPLAS article by George and Appel. Two bugs were fixed - and are marked as such. Please refer to the article for explanations. *) - -(* Low-degree, non-move-related nodes *) -let simplifyWorklist = DLinkNode.make SimplifyWorklist - -(* Low-degree, move-related nodes *) -let freezeWorklist = DLinkNode.make FreezeWorklist - -(* High-degree nodes *) -let spillWorklist = DLinkNode.make SpillWorklist - -(* Nodes that have been coalesced *) -let coalescedNodes = DLinkNode.make CoalescedNodes - -(* Moves that have been coalesced *) -let coalescedMoves = DLinkMove.make CoalescedMoves - -(* Moves whose source and destination interfere *) -let constrainedMoves = DLinkMove.make ConstrainedMoves - -(* Moves that will no longer be considered for coalescing *) -let frozenMoves = DLinkMove.make FrozenMoves - -(* Moves enabled for possible coalescing *) -let worklistMoves = DLinkMove.make WorklistMoves - -(* Moves not yet ready for coalescing *) -let activeMoves = DLinkMove.make ActiveMoves - -(* Initialization of all global data structures *) - -let init() = - DLinkNode.clear simplifyWorklist; - DLinkNode.clear freezeWorklist; - DLinkNode.clear spillWorklist; - DLinkNode.clear coalescedNodes; - DLinkMove.clear coalescedMoves; - DLinkMove.clear frozenMoves; - DLinkMove.clear worklistMoves; - DLinkMove.clear activeMoves - -(* Determine if two nodes interfere *) - -let interfere n1 n2 = - if n1.degree < n2.degree - 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 *) - -let addEdge n1 n2 = - n1.adjlist <- n2 :: n1.adjlist; - n1.degree <- 1 + n1.degree; - n2.adjlist <- n1 :: n2.adjlist; - n2.degree <- 1 + n2.degree - -(* Apply the given function to the relevant adjacent nodes of a node *) - -let iterAdjacent f n = - List.iter - (fun n -> - match n.nstate with - | SelectStack | CoalescedNodes -> () - | _ -> f n) - n.adjlist - -(* Determine the moves affecting a node *) - -let moveIsActiveOrWorklist m = - match m.mstate with - | ActiveMoves | WorklistMoves -> true - | _ -> false - -let nodeMoves n = - List.filter moveIsActiveOrWorklist n.movelist - -(* Determine whether a node is involved in a move *) - -let moveRelated n = - List.exists moveIsActiveOrWorklist n.movelist - -(*i -(* Check invariants *) - -let degreeInvariant n = - let c = ref 0 in - iterAdjacent (fun n -> incr c) n; - if !c <> n.degree then - fatal_error("degree invariant violated by " ^ name_of_node n) - -let simplifyWorklistInvariant n = - if n.degree < num_available_registers.(n.regclass) - && not (moveRelated n) - then () - else fatal_error("simplify worklist invariant violated by " ^ name_of_node n) - -let freezeWorklistInvariant n = - if n.degree < num_available_registers.(n.regclass) - && moveRelated n - then () - else fatal_error("freeze worklist invariant violated by " ^ name_of_node n) - -let spillWorklistInvariant n = - if n.degree >= num_available_registers.(n.regclass) - then () - else fatal_error("spill worklist invariant violated by " ^ name_of_node n) - -let checkInvariants () = - DLinkNode.iter - (fun n -> degreeInvariant n; simplifyWorklistInvariant n) - simplifyWorklist; - DLinkNode.iter - (fun n -> degreeInvariant n; freezeWorklistInvariant n) - freezeWorklist; - DLinkNode.iter - (fun n -> degreeInvariant n; spillWorklistInvariant n) - spillWorklist -i*) - -(* Register classes *) - -let class_of_type = function Tint -> 0 | Tfloat -> 1 - -let num_register_classes = 2 - -let caller_save_registers = [| - Array.of_list Conventions.int_caller_save_regs; - Array.of_list Conventions.float_caller_save_regs -|] - -let callee_save_registers = [| - Array.of_list Conventions.int_callee_save_regs; - Array.of_list Conventions.float_callee_save_regs -|] - -let num_available_registers = - [| Array.length caller_save_registers.(0) - + Array.length callee_save_registers.(0); - Array.length caller_save_registers.(1) - + Array.length callee_save_registers.(1) |] - -(* Build the internal representation of the graph *) - -let nodeOfReg r typenv spillcosts = - let ty = typenv r in - { ident = r; typ = ty; regclass = class_of_type ty; - spillcost = (try float(Hashtbl.find spillcosts r) with Not_found -> 0.0); - adjlist = []; degree = 0; movelist = []; alias = None; - color = None; - nstate = Initial; - nprev = DLinkNode.dummy; nnext = DLinkNode.dummy } - -let nodeOfMreg mr = - let ty = mreg_type mr in - { ident = Coq_xH; typ = ty; regclass = class_of_type ty; - spillcost = 0.0; - adjlist = []; degree = 0; movelist = []; alias = None; - color = Some (R mr); - nstate = Colored; - nprev = DLinkNode.dummy; nnext = DLinkNode.dummy } - -let build g typenv spillcosts = - (* Associate an internal node to each pseudo-register and each location *) - let reg_mapping = Hashtbl.create 27 - and mreg_mapping = Hashtbl.create 27 in - let find_reg_node r = - try - Hashtbl.find reg_mapping r - with Not_found -> - let n = nodeOfReg r typenv spillcosts in - Hashtbl.add reg_mapping r n; - n - and find_mreg_node mr = - try - Hashtbl.find mreg_mapping mr - with Not_found -> - let n = nodeOfMreg mr in - Hashtbl.add mreg_mapping mr n; - n in - (* Fill the adjacency lists and compute the degrees. *) - SetRegReg.fold - (fun (Coq_pair(r1, r2)) () -> - addEdge (find_reg_node r1) (find_reg_node r2)) - g.interf_reg_reg (); - SetRegMreg.fold - (fun (Coq_pair(r1, mr2)) () -> - addEdge (find_reg_node r1) (find_mreg_node mr2)) - g.interf_reg_mreg (); - (* Process the moves and insert them in worklistMoves *) - let add_move n1 n2 = - let m = - { src = n1; dst = n2; mstate = WorklistMoves; - mnext = DLinkMove.dummy; mprev = DLinkMove.dummy } in - n1.movelist <- m :: n1.movelist; - n2.movelist <- m :: n2.movelist; - DLinkMove.insert m worklistMoves in - SetRegReg.fold - (fun (Coq_pair(r1, r2)) () -> - add_move (find_reg_node r1) (find_reg_node r2)) - g.pref_reg_reg (); - SetRegMreg.fold - (fun (Coq_pair(r1, mr2)) () -> - add_move (find_reg_node r1) (find_mreg_node mr2)) - g.pref_reg_mreg (); - (* Initial partition of nodes into spill / freeze / simplify *) - Hashtbl.iter - (fun r n -> - assert (n.nstate = Initial); - let k = num_available_registers.(n.regclass) in - if n.degree >= k then - DLinkNode.insert n spillWorklist - else if moveRelated n then - DLinkNode.insert n freezeWorklist - else - DLinkNode.insert n simplifyWorklist) - reg_mapping; - reg_mapping - -(* Enable moves that have become low-degree related *) - -let enableMoves n = - List.iter - (fun m -> - if m.mstate = ActiveMoves - then DLinkMove.move m activeMoves worklistMoves) - (nodeMoves n) - -(* Simulate the removal of a node from the graph *) - -let decrementDegree n = - let k = num_available_registers.(n.regclass) in - let d = n.degree in - n.degree <- d - 1; - if d = k then begin - enableMoves n; - iterAdjacent enableMoves n; - if n.nstate <> Colored then begin - if moveRelated n - then DLinkNode.move n spillWorklist freezeWorklist - else DLinkNode.move n spillWorklist simplifyWorklist - end - end - -(* Simulate the effect of combining nodes [n1] and [n3] on [n2], - where [n2] is a node adjacent to [n3]. *) - -let combineEdge n1 n2 = - assert (n1 != n2); - if interfere n1 n2 then begin - decrementDegree n2 - end else begin - n1.adjlist <- n2 :: n1.adjlist; - n2.adjlist <- n1 :: n2.adjlist; - n1.degree <- n1.degree + 1 - end - -(* Simplification of a low-degree node *) - -let simplify () = - let n = DLinkNode.pick simplifyWorklist in - (*i Printf.printf "Simplifying %s\n" (name_of_node n); i*) - n.nstate <- SelectStack; - iterAdjacent decrementDegree n; - n - -(* Briggs' conservative coalescing criterion *) - -let canConservativelyCoalesce n1 n2 = - let seen = ref Regset.empty in - let k = num_available_registers.(n1.regclass) in - let c = ref 0 in - let consider n = - if not (Regset.mem n.ident !seen) then begin - seen := Regset.add n.ident !seen; - if n.degree >= k then incr c - end in - iterAdjacent consider n1; - iterAdjacent consider n2; - !c < k - -(* Update worklists after a move was processed *) - -let addWorkList u = - if (not (u.nstate = Colored)) - && u.degree < num_available_registers.(u.regclass) - && (not (moveRelated u)) - then DLinkNode.move u freezeWorklist simplifyWorklist - -(* Return the canonical representative of a possibly coalesced node *) - -let rec getAlias n = - match n.alias with None -> n | Some n' -> getAlias n' - -(* Combine two nodes *) - -let combine u v = - (*i Printf.printf "Combining %s and %s\n" (name_of_node u) (name_of_node v); i*) - if v.nstate = FreezeWorklist - then DLinkNode.move v freezeWorklist coalescedNodes - else DLinkNode.move v spillWorklist coalescedNodes; - v.alias <- Some u; - u.movelist <- u.movelist @ v.movelist; - iterAdjacent (combineEdge u) v; (*r original code using [decrementDegree] is buggy *) - enableMoves v; (*r added as per Appel's book erratum *) - if u.degree >= num_available_registers.(u.regclass) - && u.nstate = FreezeWorklist - then DLinkNode.move u freezeWorklist spillWorklist - -(* Attempt coalescing *) - -let coalesce () = - let m = DLinkMove.pick worklistMoves in - let x = getAlias m.src and y = getAlias m.dst in - let (u, v) = if y.nstate = Colored then (y, x) else (x, y) in - if u == v then begin - DLinkMove.insert m coalescedMoves; - addWorkList u - end else if v.nstate = Colored || interfere u v then begin - DLinkMove.insert m constrainedMoves; - addWorkList u; - addWorkList v - end else if canConservativelyCoalesce u v then begin - DLinkMove.insert m coalescedMoves; - combine u v; - addWorkList u - end else begin - DLinkMove.insert m activeMoves - end - -(* Freeze moves associated with node [u] *) - -let freezeMoves u = - let au = getAlias u in - let freeze m = - let y = getAlias m.src in - let v = if y == au then getAlias m.dst else y in - DLinkMove.move m activeMoves frozenMoves; - if not (moveRelated v) - && v.degree < num_available_registers.(v.regclass) - && v.nstate <> Colored - then DLinkNode.move v freezeWorklist simplifyWorklist in - List.iter freeze (nodeMoves u) - -(* Pick a move and freeze it *) - -let freeze () = - let u = DLinkNode.pick freezeWorklist in - (*i Printf.printf "Freezing %s\n" (name_of_node u); i*) - DLinkNode.insert u simplifyWorklist; - freezeMoves u - -(* Chaitin's cost measure *) - -let spillCost n = n.spillcost /. float n.degree - -(* Spill a node *) - -let selectSpill () = - (* Find a spillable node of minimal cost *) - let (n, cost) = - DLinkNode.fold - (fun n (best_node, best_cost as best) -> - let cost = spillCost n in - if cost < best_cost then (n, cost) else best) - spillWorklist (DLinkNode.dummy, infinity) in - assert (n != DLinkNode.dummy); - DLinkNode.remove n spillWorklist; - (*i Printf.printf "Spilling %s\n" (name_of_node n); i*) - freezeMoves n; - n.nstate <- SelectStack; - iterAdjacent decrementDegree n; - n - -(* Produce the order of nodes that we'll use for coloring *) - -let rec nodeOrder stack = - (*i checkInvariants(); i*) - if DLinkNode.notempty simplifyWorklist then - (let n = simplify() in nodeOrder (n :: stack)) - else if DLinkMove.notempty worklistMoves then - (coalesce(); nodeOrder stack) - else if DLinkNode.notempty freezeWorklist then - (freeze(); nodeOrder stack) - else if DLinkNode.notempty spillWorklist then - (let n = selectSpill() in nodeOrder (n :: stack)) - else - stack - -(* Assign a color (i.e. a hardware register or a stack location) - to a node. The color is chosen among the colors that are not - assigned to nodes with which this node interferes. The choice - is guided by the following heuristics: consider first caller-save - hardware register of the correct type; second, callee-save registers; - third, a stack location. Callee-save registers and stack locations - are ``expensive'' resources, so we try to minimize their number - by picking the smallest available callee-save register or stack location. - In contrast, caller-save registers are ``free'', so we pick an - available one pseudo-randomly. *) - -module Locset = - Set.Make(struct type t = loc let compare = compare end) - -let start_points = Array.make num_register_classes 0 - -let find_reg conflicts regclass = - let rec find avail curr last = - if curr >= last then None else begin - let l = R avail.(curr) in - if Locset.mem l conflicts - then find avail (curr + 1) last - else Some l - end in - let caller_save = caller_save_registers.(regclass) - and callee_save = callee_save_registers.(regclass) - and start = start_points.(regclass) in - match find caller_save start (Array.length caller_save) with - | Some _ as res -> - start_points.(regclass) <- - (if start + 1 < Array.length caller_save then start + 1 else 0); - res - | None -> - match find caller_save 0 start with - | Some _ as res -> - start_points.(regclass) <- - (if start + 1 < Array.length caller_save then start + 1 else 0); - res - | None -> - find callee_save 0 (Array.length callee_save) - -let find_slot conflicts typ = - let rec find curr = - let l = S(Local(curr, typ)) in - if Locset.mem l conflicts then find (coq_Zsucc curr) else l - in find Z0 - -let assign_color n = - let conflicts = ref Locset.empty in - List.iter - (fun n' -> - match (getAlias n').color with - | None -> () - | Some l -> conflicts := Locset.add l !conflicts) - n.adjlist; - match find_reg !conflicts n.regclass with - | Some loc -> - n.color <- Some loc - | None -> - n.color <- Some (find_slot !conflicts n.typ) - -(* Extract the location of a node *) - -let location_of_node n = - match n.color with - | None -> assert false - | Some loc -> loc - -(* Estimate spilling costs - TODO *) - -let spill_costs f = Hashtbl.create 7 - -(* This is the entry point for graph coloring. *) - -let graph_coloring (f: coq_function) (g: graph) (env: regenv) (regs: Regset.t) - : (reg -> loc) = - init(); - Array.fill start_points 0 num_register_classes 0; - let mapping = build g env (spill_costs f) in - 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/Coloringaux.mli b/caml/Coloringaux.mli deleted file mode 100644 index c5070f2..0000000 --- a/caml/Coloringaux.mli +++ /dev/null @@ -1,20 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -open Registers -open Locations -open RTL -open RTLtyping -open InterfGraph - -val graph_coloring: - coq_function -> graph -> regenv -> Regset.t -> (reg -> loc) diff --git a/caml/Driver.ml b/caml/Driver.ml deleted file mode 100644 index 8fffcaa..0000000 --- a/caml/Driver.ml +++ /dev/null @@ -1,352 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -open Printf -open Clflags - -(* Location of the standard library *) - -let stdlib_path = ref( - try - Sys.getenv "COMPCERT_LIBRARY" - with Not_found -> - Configuration.stdlib_path) - -let command cmd = - if !option_v then begin - prerr_string "+ "; prerr_string cmd; prerr_endline "" - end; - Sys.command cmd - -let quote_options opts = - String.concat " " (List.rev_map Filename.quote opts) - -let safe_remove file = - try Sys.remove file with Sys_error _ -> () - -(* Printing of error messages *) - -let print_error oc msg = - let print_one_error = function - | Errors.MSG s -> output_string oc (Camlcoq.camlstring_of_coqstring s) - | Errors.CTX i -> output_string oc (Camlcoq.extern_atom i) - in List.iter print_one_error msg - -(* For the CIL -> Csyntax translator: - - * The meaning of some type specifiers may depend on compiler options: - the size of an int or the default signedness of char, for instance. - - * Those type conversions may be parameterized thanks to a functor. - - * Remark: [None] means that the type specifier is not supported - (that is, an Unsupported exception will be raised if that type - specifier is encountered in the program). -*) - -module TypeSpecifierTranslator = struct - - open Cil - open Csyntax - - (** Convert a Cil.ikind into an (intsize * signedness) option *) - let convertIkind = function - | IChar -> Some (I8, Unsigned) - | ISChar -> Some (I8, Signed) - | IUChar -> Some (I8, Unsigned) - | IInt -> Some (I32, Signed) - | IUInt -> Some (I32, Unsigned) - | IShort -> Some (I16, Signed) - | IUShort -> Some (I16, Unsigned) - | ILong -> Some (I32, Signed) - | IULong -> Some (I32, Unsigned) - | ILongLong -> if !option_flonglong then Some (I32, Signed) else None - | IULongLong -> if !option_flonglong then Some (I32, Unsigned) else None - - (** Convert a Cil.fkind into an floatsize option *) - let convertFkind = function - | FFloat -> Some F32 - | FDouble -> Some F64 - | FLongDouble -> if !option_flonglong then Some F64 else None - -end - -module Cil2CsyntaxTranslator = Cil2Csyntax.Make(TypeSpecifierTranslator) - -(* From C to preprocessed C *) - -let preprocess ifile ofile = - let cmd = - sprintf "%s -D__COMPCERT__ -I%s %s %s > %s" - Configuration.prepro - !stdlib_path - (quote_options !prepro_options) - ifile ofile in - if command cmd <> 0 then begin - safe_remove ofile; - eprintf "Error during preprocessing.\n"; - exit 2 - end - -(* From preprocessed C to asm *) - -let compile_c_file sourcename ifile ofile = - (* Parsing and production of a CIL.file *) - let cil = - try - Frontc.parse ifile () - with - | Frontc.ParseError msg -> - eprintf "Error during parsing: %s\n" msg; - exit 2 - | Errormsg.Error -> - exit 2 in - (* Remove preprocessed file (always a temp file) *) - safe_remove ifile; - (* Restore original source file name *) - cil.Cil.fileName <- sourcename; - (* Cleanup in the CIL.file *) - Rmtmps.removeUnusedTemps ~isRoot:Rmtmps.isExportedRoot cil; - (* Conversion to Csyntax *) - let csyntax = - try - Cil2CsyntaxTranslator.convertFile cil - with - | Cil2CsyntaxTranslator.Unsupported msg -> - eprintf "%s\n" msg; - exit 2 - | Cil2CsyntaxTranslator.Internal_error msg -> - eprintf "%s\nPlease report it.\n" msg; - exit 2 in - (* Save Csyntax if requested *) - if !option_dclight then begin - let targetname = Filename.chop_suffix sourcename ".c" in - let oc = open_out (targetname ^ ".light.c") in - PrintCsyntax.print_program (Format.formatter_of_out_channel oc) csyntax; - close_out oc - end; - (* Convert to PPC *) - let ppc = - match Main.transf_c_program csyntax with - | Errors.OK x -> x - | Errors.Error msg -> - print_error stderr msg; - exit 2 in - (* Save PPC asm *) - let oc = open_out ofile in - PrintPPC.print_program oc ppc; - close_out oc - -(* From Cminor to asm *) - -let compile_cminor_file ifile ofile = - let ic = open_in ifile in - let lb = Lexing.from_channel ic in - try - match Main.transf_cminor_program - (CMtypecheck.type_program - (CMparser.prog CMlexer.token lb)) with - | Errors.Error msg -> - print_error stderr msg; - exit 2 - | Errors.OK p -> - let oc = open_out ofile in - PrintPPC.print_program oc p; - close_out oc - with Parsing.Parse_error -> - eprintf "File %s, character %d: Syntax error\n" - ifile (Lexing.lexeme_start lb); - exit 2 - | CMlexer.Error msg -> - eprintf "File %s, character %d: %s\n" - ifile (Lexing.lexeme_start lb) msg; - exit 2 - | CMtypecheck.Error msg -> - eprintf "File %s, type-checking error:\n%s" - ifile msg; - exit 2 - -(* From asm to object file *) - -let assemble ifile ofile = - let cmd = - sprintf "%s -o %s %s" - Configuration.asm ofile ifile in - let retcode = command cmd in - if not !option_dasm then safe_remove ifile; - if retcode <> 0 then begin - safe_remove ofile; - eprintf "Error during assembling.\n"; - exit 2 - end - -(* Linking *) - -let linker exe_name files = - let cmd = - sprintf "%s -o %s %s -L%s -lcompcert" - Configuration.linker - (Filename.quote exe_name) - (quote_options files) - !stdlib_path in - if command cmd <> 0 then exit 2 - -(* Processing of a .c file *) - -let process_c_file sourcename = - let prefixname = Filename.chop_suffix sourcename ".c" in - if !option_E then begin - preprocess sourcename (prefixname ^ ".i") - end else begin - let preproname = Filename.temp_file "compcert" ".i" in - preprocess sourcename preproname; - if !option_S then begin - compile_c_file sourcename preproname (prefixname ^ ".s") - end else begin - let asmname = - if !option_dasm - then prefixname ^ ".s" - else Filename.temp_file "compcert" ".s" in - compile_c_file sourcename preproname asmname; - assemble asmname (prefixname ^ ".o") - end - end; - prefixname ^ ".o" - -(* Processing of a .cm file *) - -let process_cminor_file sourcename = - let prefixname = Filename.chop_suffix sourcename ".cm" in - if !option_S then begin - compile_cminor_file sourcename (prefixname ^ ".s") - end else begin - let asmname = - if !option_dasm - then prefixname ^ ".s" - else Filename.temp_file "compcert" ".s" in - compile_cminor_file sourcename asmname; - assemble asmname (prefixname ^ ".o") - end; - prefixname ^ ".o" - -(* Command-line parsing *) - -let starts_with s1 s2 = - String.length s1 >= String.length s2 && - String.sub s1 0 (String.length s2) = s2 - -let usage_string = -"ccomp [options] -Recognized source files: - .c C source file - .cm Cminor source file - .o Object file - .a Library file -Processing options: - -E Preprocess only, save result in .i - -S Compile to assembler only, save result in .s - -c Compile to object file only (no linking), result in .o -Preprocessing options: - -I Add to search path for #include files - -D= Define preprocessor symbol - -U Undefine preprocessor symbol -Compilation options: - -flonglong Treat 'long long' as 'long' and 'long double' as 'double' - -fmadd Use fused multiply-add and multiply-sub instructions - -dclight Save generated Clight in .light.c - -dasm Save generated assembly in .s -Linking options: - -l Link library - -L Add to search path for libraries - -o Generate executable in (default: a.out) -General options: - -stdlib Set the path of the Compcert run-time library - -v Print external commands before invoking them -" - -let rec parse_cmdline i = - if i < Array.length Sys.argv then begin - let s = Sys.argv.(i) in - if starts_with s "-I" || starts_with s "-D" || starts_with s "-U" - then begin - prepro_options := s :: !prepro_options; - parse_cmdline (i + 1) - end else - if starts_with s "-l" || starts_with s "-L" then begin - linker_options := s :: !linker_options; - parse_cmdline (i + 1) - end else - if s = "-o" && i + 1 < Array.length Sys.argv then begin - exe_name := Sys.argv.(i + 1); - parse_cmdline (i + 2) - end else - if s = "-stdlib" && i + 1 < Array.length Sys.argv then begin - stdlib_path := Sys.argv.(i + 1); - parse_cmdline (i + 2) - end else - if s = "-flonglong" then begin - option_flonglong := true; - parse_cmdline (i + 1) - end else - if s = "-fmadd" then begin - option_fmadd := true; - parse_cmdline (i + 1) - end else - if s = "-dclight" then begin - option_dclight := true; - parse_cmdline (i + 1) - end else - if s = "-dasm" then begin - option_dasm := true; - parse_cmdline (i + 1) - end else - if s = "-E" then begin - option_E := true; - parse_cmdline (i + 1) - end else - if s = "-S" then begin - option_S := true; - parse_cmdline (i + 1) - end else - if s = "-c" then begin - option_c := true; - parse_cmdline (i + 1) - end else - if s = "-v" then begin - option_v := true; - parse_cmdline (i + 1) - end else - if Filename.check_suffix s ".c" then begin - let objfile = process_c_file s in - linker_options := objfile :: !linker_options; - parse_cmdline (i + 1) - end else - if Filename.check_suffix s ".cm" then begin - let objfile = process_cminor_file s in - linker_options := objfile :: !linker_options; - parse_cmdline (i + 1) - end else - if Filename.check_suffix s ".o" || Filename.check_suffix s ".a" then begin - linker_options := s :: !linker_options; - parse_cmdline (i + 1) - end else begin - eprintf "Unknown argument `%s'\n" s; - eprintf "Usage: %s" usage_string; - exit 2 - end - end - -let _ = - parse_cmdline 1; - if not (!option_c || !option_S || !option_E) then begin - linker !exe_name !linker_options - end diff --git a/caml/Floataux.ml b/caml/Floataux.ml deleted file mode 100644 index 6b3b825..0000000 --- a/caml/Floataux.ml +++ /dev/null @@ -1,39 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -open Camlcoq -open Integers - -let singleoffloat f = - Int32.float_of_bits (Int32.bits_of_float f) - -let intoffloat f = - coqint_of_camlint (Int32.of_float f) - -let intuoffloat f = - coqint_of_camlint (Int64.to_int32 (Int64.of_float f)) - -let floatofint i = - Int32.to_float (camlint_of_coqint i) - -let floatofintu i = - Int64.to_float (Int64.logand (Int64.of_int32 (camlint_of_coqint i)) - 0xFFFFFFFFL) - -let cmp c (x: float) (y: float) = - match c with - | Ceq -> x = y - | Cne -> x <> y - | Clt -> x < y - | Cle -> x <= y - | Cgt -> x > y - | Cge -> x >= y diff --git a/caml/Linearizeaux.ml b/caml/Linearizeaux.ml deleted file mode 100644 index 2f2333f..0000000 --- a/caml/Linearizeaux.ml +++ /dev/null @@ -1,85 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -open BinPos -open Coqlib -open Datatypes -open LTL -open Lattice -open CList -open Maps -open Camlcoq - -(* Trivial enumeration, in decreasing order of PC *) - -(*** -let enumerate_aux f reach = - positive_rec - Coq_nil - (fun pc nodes -> - if PMap.get pc reach - then Coq_cons (pc, nodes) - else nodes) - f.fn_nextpc -***) - -(* More clever enumeration that flattens basic blocks *) - -let rec int_of_pos = function - | Coq_xI p -> (int_of_pos p lsl 1) + 1 - | Coq_xO p -> int_of_pos p lsl 1 - | Coq_xH -> 1 - -let rec pos_of_int n = - if n = 0 then assert false else - if n = 1 then Coq_xH else - if n land 1 = 0 - then Coq_xO (pos_of_int (n lsr 1)) - else Coq_xI (pos_of_int (n lsr 1)) - -(* Build the enumeration *) - -module IntSet = Set.Make(struct type t = int let compare = compare end) - -let enumerate_aux f reach = - let enum = ref [] in - let emitted = Array.make (int_of_pos f.fn_nextpc) false in - let rec emit_block pending pc = - let npc = int_of_pos pc in - if emitted.(npc) - then emit_restart pending - else begin - enum := pc :: !enum; - emitted.(npc) <- true; - match PTree.get pc f.fn_code with - | None -> assert false - | Some i -> - match i with - | Lnop s -> emit_block pending s - | Lop (op, args, res, s) -> emit_block pending s - | Lload (chunk, addr, args, dst, s) -> emit_block pending s - | Lstore (chunk, addr, args, src, s) -> emit_block pending s - | Lcall (sig0, ros, args, res, s) -> emit_block pending s - | Ltailcall (sig0, ros, args) -> emit_restart pending - | Lalloc (arg, res, s) -> emit_block pending s - | Lcond (cond, args, ifso, ifnot) -> - emit_restart (IntSet.add (int_of_pos ifso) - (IntSet.add (int_of_pos ifnot) pending)) - | Lreturn optarg -> emit_restart pending - end - and emit_restart pending = - if not (IntSet.is_empty pending) then begin - let npc = IntSet.max_elt pending in - emit_block (IntSet.remove npc pending) (pos_of_int npc) - end in - emit_block IntSet.empty f.fn_entrypoint; - CList.rev !enum diff --git a/caml/PrintCsyntax.ml b/caml/PrintCsyntax.ml deleted file mode 100644 index bb25339..0000000 --- a/caml/PrintCsyntax.ml +++ /dev/null @@ -1,501 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the GNU General Public License as published by *) -(* the Free Software Foundation, either version 2 of the License, or *) -(* (at your option) any later version. This file is also distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** Pretty-printer for Csyntax *) - -open Format -open Camlcoq -open CList -open Datatypes -open AST -open Csyntax - -let name_unop = function - | Onotbool -> "!" - | Onotint -> "~" - | Oneg -> "-" - - -let name_binop = function - | Oadd -> "+" - | Osub -> "-" - | Omul -> "*" - | Odiv -> "/" - | Omod -> "%" - | Oand -> "&" - | Oor -> "|" - | Oxor -> "^" - | Oshl -> "<<" - | Oshr -> ">>" - | Oeq -> "==" - | One -> "!=" - | Olt -> "<" - | Ogt -> ">" - | Ole -> "<=" - | Oge -> ">=" - -let name_inttype sz sg = - match sz, sg with - | I8, Signed -> "signed char" - | I8, Unsigned -> "unsigned char" - | I16, Signed -> "short" - | I16, Unsigned -> "unsigned short" - | I32, Signed -> "int" - | I32, Unsigned -> "unsigned int" - -let name_floattype sz = - match sz with - | F32 -> "float" - | F64 -> "double" - -(* Collecting the names and fields of structs and unions *) - -module StructUnionSet = Set.Make(struct - type t = string * fieldlist - let compare (n1, _ : t) (n2, _ : t) = compare n1 n2 -end) - -let struct_unions = ref StructUnionSet.empty - -let register_struct_union id fld = - struct_unions := StructUnionSet.add (extern_atom id, fld) !struct_unions - -(* Declarator (identifier + type) *) - -let name_optid id = - if id = "" then "" else " " ^ id - -let parenthesize_if_pointer id = - if String.length id > 0 && id.[0] = '*' then "(" ^ id ^ ")" else id - -let rec name_cdecl id ty = - match ty with - | Tvoid -> - "void" ^ name_optid id - | Tint(sz, sg) -> - name_inttype sz sg ^ name_optid id - | Tfloat sz -> - name_floattype sz ^ name_optid id - | Tpointer t -> - name_cdecl ("*" ^ id) t - | Tarray(t, n) -> - name_cdecl - (sprintf "%s[%ld]" (parenthesize_if_pointer id) (camlint_of_coqint n)) - t - | Tfunction(args, res) -> - let b = Buffer.create 20 in - if id = "" - then Buffer.add_string b "(*)" - else Buffer.add_string b (parenthesize_if_pointer id); - Buffer.add_char b '('; - begin match args with - | Tnil -> - Buffer.add_string b "void" - | _ -> - let rec add_args first = function - | Tnil -> () - | Tcons(t1, tl) -> - if not first then Buffer.add_string b ", "; - Buffer.add_string b (name_cdecl "" t1); - add_args false tl in - add_args true args - end; - Buffer.add_char b ')'; - name_cdecl (Buffer.contents b) res - | Tstruct(name, fld) -> - extern_atom name ^ name_optid id - | Tunion(name, fld) -> - extern_atom name ^ name_optid id - | Tcomp_ptr name -> - extern_atom name ^ " *" ^ id - -(* Type *) - -let name_type ty = name_cdecl "" ty - -(* Expressions *) - -let parenthesis_level (Expr (e, ty)) = - match e with - | Econst_int _ -> 0 - | Econst_float _ -> 0 - | Evar _ -> 0 - | Eunop(_, _) -> 30 - | Ederef _ -> 20 - | Eaddrof _ -> 30 - | Ebinop(op, _, _) -> - begin match op with - | Oand | Oor | Oxor -> 75 - | Oeq | One | Olt | Ogt | Ole | Oge -> 70 - | Oadd | Osub | Oshl | Oshr -> 60 - | Omul | Odiv | Omod -> 40 - end - | Ecast _ -> 30 - | Econdition(_, _, _) -> 80 - | Eandbool(_, _) -> 80 - | Eorbool(_, _) -> 80 - | Esizeof _ -> 20 - | Efield _ -> 20 - -let rec print_expr p (Expr (eb, ty) as e) = - let level = parenthesis_level e in - match eb with - | Econst_int n -> - fprintf p "%ld" (camlint_of_coqint n) - | Econst_float f -> - fprintf p "%F" f - | Evar id -> - fprintf p "%s" (extern_atom id) - | Eunop(op, e1) -> - fprintf p "%s%a" (name_unop op) print_expr_prec (level, e1) - | Ederef (Expr (Ebinop(Oadd, e1, e2), _)) -> - fprintf p "@[%a@,[%a]@]" - print_expr_prec (level, e1) - print_expr_prec (level, e2) - | Ederef (Expr (Efield(e1, id), _)) -> - fprintf p "%a->%s" print_expr_prec (level, e1) (extern_atom id) - | Ederef e -> - fprintf p "*%a" print_expr_prec (level, e) - | Eaddrof e -> - fprintf p "&%a" print_expr_prec (level, e) - | Ebinop(op, e1, e2) -> - fprintf p "@[%a@ %s %a@]" - print_expr_prec (level, e1) - (name_binop op) - print_expr_prec (level, e2) - | Ecast(ty, e1) -> - fprintf p "@[(%s)@,%a@]" - (name_type ty) - print_expr_prec (level, e1) - | Econdition(e1, e2, e3) -> - fprintf p "@[%a@ ? %a@ : %a@]" - print_expr_prec (level, e1) - print_expr_prec (level, e2) - print_expr_prec (level, e3) - | Eandbool(e1, e2) -> - fprintf p "@[%a@ && %a@]" - print_expr_prec (level, e1) - print_expr_prec (level, e2) - | Eorbool(e1, e2) -> - fprintf p "@[%a@ || %a@]" - print_expr_prec (level, e1) - print_expr_prec (level, e2) - | Esizeof ty -> - fprintf p "sizeof(%s)" (name_type ty) - | Efield(e1, id) -> - fprintf p "%a.%s" print_expr_prec (level, e1) (extern_atom id) - -and print_expr_prec p (context_prec, e) = - let this_prec = parenthesis_level e in - if this_prec >= context_prec - then fprintf p "(%a)" print_expr e - else print_expr p e - -let rec print_expr_list p (first, el) = - match el with - | [] -> () - | e1 :: et -> - if not first then fprintf p ",@ "; - print_expr p e1; - print_expr_list p (false, et) - -let rec print_stmt p s = - match s with - | Sskip -> - fprintf p "/*skip*/;" - | Sassign(e1, e2) -> - fprintf p "@[%a =@ %a;@]" print_expr e1 print_expr e2 - | Scall(None, e1, el) -> - fprintf p "@[%a@,(@[%a@]);@]" - print_expr e1 - print_expr_list (true, el) - | Scall(Some lhs, e1, el) -> - fprintf p "@[%a =@ %a@,(@[%a@]);@]" - print_expr lhs - print_expr e1 - print_expr_list (true, el) - | Ssequence(s1, s2) -> - fprintf p "%a@ %a" print_stmt s1 print_stmt s2 - | Sifthenelse(e, s1, Sskip) -> - fprintf p "@[if (%a) {@ %a@;<0 -2>}@]" - print_expr e - print_stmt s1 - | Sifthenelse(e, s1, s2) -> - fprintf p "@[if (%a) {@ %a@;<0 -2>} else {@ %a@;<0 -2>}@]" - print_expr e - print_stmt s1 - print_stmt s2 - | Swhile(e, s) -> - fprintf p "@[while (%a) {@ %a@;<0 -2>}@]" - print_expr e - print_stmt s - | Sdowhile(e, s) -> - fprintf p "@[do {@ %a@;<0 -2>} while(%a);@]" - print_stmt s - print_expr e - | Sfor(s_init, e, s_iter, s_body) -> - fprintf p "@[for (@[%a;@ %a;@ %a) {@]@ %a@;<0 -2>}@]" - print_stmt_for s_init - print_expr e - print_stmt_for s_iter - print_stmt s_body - | Sbreak -> - fprintf p "break;" - | Scontinue -> - fprintf p "continue;" - | Sswitch(e, cases) -> - fprintf p "@[switch (%a) {@ %a@;<0 -2>}@]" - print_expr e - print_cases cases - | Sreturn None -> - fprintf p "return;" - | Sreturn (Some e) -> - fprintf p "return %a;" print_expr e - -and print_cases p cases = - match cases with - | LSdefault Sskip -> - () - | LSdefault s -> - fprintf p "@[default:@ %a@]" print_stmt s - | LScase(lbl, Sskip, rem) -> - fprintf p "case %ld:@ %a" - (camlint_of_coqint lbl) - print_cases rem - | LScase(lbl, s, rem) -> - fprintf p "@[case %ld:@ %a@]@ %a" - (camlint_of_coqint lbl) - print_stmt s - print_cases rem - -and print_stmt_for p s = - match s with - | Sskip -> - fprintf p "/*nothing*/" - | Sassign(e1, e2) -> - fprintf p "%a = %a" print_expr e1 print_expr e2 - | Ssequence(s1, s2) -> - fprintf p "%a, %a" print_stmt_for s1 print_stmt_for s2 - | Scall(None, e1, el) -> - fprintf p "@[%a@,(@[%a@])@]" - print_expr e1 - print_expr_list (true, el) - | Scall(Some lhs, e1, el) -> - fprintf p "@[%a =@ %a@,(@[%a@])@]" - print_expr lhs - print_expr e1 - print_expr_list (true, el) - | _ -> - fprintf p "({ %a })" print_stmt s - -let name_function_parameters fun_name params = - let b = Buffer.create 20 in - Buffer.add_string b fun_name; - Buffer.add_char b '('; - begin match params with - | [] -> - Buffer.add_string b "void" - | _ -> - let rec add_params first = function - | [] -> () - | Coq_pair(id, ty) :: rem -> - if not first then Buffer.add_string b ", "; - Buffer.add_string b (name_cdecl (extern_atom id) ty); - add_params false rem in - add_params true params - end; - Buffer.add_char b ')'; - Buffer.contents b - -let print_function p id f = - fprintf p "%s@ " - (name_cdecl (name_function_parameters (extern_atom id) - f.fn_params) - f.fn_return); - fprintf p "@[{@ "; - List.iter - (fun (Coq_pair(id, ty)) -> - fprintf p "%s;@ " (name_cdecl (extern_atom id) ty)) - f.fn_vars; - print_stmt p f.fn_body; - fprintf p "@;<0 -2>}@]@ @ " - -let print_fundef p (Coq_pair(id, fd)) = - match fd with - | External(_, args, res) -> - fprintf p "extern %s;@ @ " - (name_cdecl (extern_atom id) (Tfunction(args, res))) - | Internal f -> - print_function p id f - -let string_of_init id = - try - let s = String.create (List.length id) in - let i = ref 0 in - List.iter - (function - | Init_int8 n -> - s.[!i] <- Char.chr(Int32.to_int(camlint_of_coqint n)); - incr i - | _ -> raise Not_found) - id; - Some s - with Not_found -> None - -let print_escaped_string p s = - fprintf p "\""; - for i = 0 to String.length s - 1 do - match s.[i] with - | ('\"' | '\\') as c -> fprintf p "\\%c" c - | '\n' -> fprintf p "\\n" - | '\t' -> fprintf p "\\t" - | '\r' -> fprintf p "\\r" - | c -> if c >= ' ' && c <= '~' - then fprintf p "%c" c - else fprintf p "\\x%02x" (Char.code c) - done; - fprintf p "\"" - -let print_init p = function - | Init_int8 n -> fprintf p "%ld,@ " (camlint_of_coqint n) - | Init_int16 n -> fprintf p "%ld,@ " (camlint_of_coqint n) - | Init_int32 n -> fprintf p "%ld,@ " (camlint_of_coqint n) - | Init_float32 n -> fprintf p "%F,@ " n - | Init_float64 n -> fprintf p "%F,@ " n - | Init_space n -> fprintf p "/* skip %ld, */@ " (camlint_of_coqint n) - | Init_pointer id -> - match string_of_init id with - | None -> fprintf p "/* pointer to other init*/,@ " - | Some s -> fprintf p "%a,@ " print_escaped_string s - -let print_globvar p (Coq_pair(Coq_pair(id, init), ty)) = - match init with - | [] -> - fprintf p "extern %s;@ @ " - (name_cdecl (extern_atom id) ty) - | [Init_space _] -> - fprintf p "%s;@ @ " - (name_cdecl (extern_atom id) ty) - | _ -> - fprintf p "@[%s = {@ " - (name_cdecl (extern_atom id) ty); - List.iter (print_init p) init; - fprintf p "};@]@ @ " - -(* Collect struct and union types *) - -let rec collect_type = function - | Tvoid -> () - | Tint(sz, sg) -> () - | Tfloat sz -> () - | Tpointer t -> collect_type t - | Tarray(t, n) -> collect_type t - | Tfunction(args, res) -> collect_type_list args; collect_type res - | Tstruct(id, fld) -> register_struct_union id fld; collect_fields fld - | Tunion(id, fld) -> register_struct_union id fld; collect_fields fld - | Tcomp_ptr _ -> () - -and collect_type_list = function - | Tnil -> () - | Tcons(hd, tl) -> collect_type hd; collect_type_list tl - -and collect_fields = function - | Fnil -> () - | Fcons(id, hd, tl) -> collect_type hd; collect_fields tl - -let rec collect_expr (Expr(ed, ty)) = - match ed with - | Econst_int n -> () - | Econst_float f -> () - | Evar id -> () - | Eunop(op, e1) -> collect_expr e1 - | Ederef e -> collect_expr e - | Eaddrof e -> collect_expr e - | Ebinop(op, e1, e2) -> collect_expr e1; collect_expr e2 - | Ecast(ty, e1) -> collect_type ty; collect_expr e1 - | Econdition(e1, e2, e3) -> collect_expr e1; collect_expr e2; collect_expr e3 - | Eandbool(e1, e2) -> collect_expr e1; collect_expr e2 - | Eorbool(e1, e2) -> collect_expr e1; collect_expr e2 - | Esizeof ty -> collect_type ty - | Efield(e1, id) -> collect_expr e1 - -let rec collect_expr_list = function - | [] -> () - | hd :: tl -> collect_expr hd; collect_expr_list tl - -let rec collect_stmt = function - | Sskip -> () - | Sassign(e1, e2) -> collect_expr e1; collect_expr e2 - | Scall(None, e1, el) -> collect_expr e1; collect_expr_list el - | Scall(Some lhs, e1, el) -> collect_expr lhs; collect_expr e1; collect_expr_list el - | Ssequence(s1, s2) -> collect_stmt s1; collect_stmt s2 - | Sifthenelse(e, s1, s2) -> collect_expr e; collect_stmt s1; collect_stmt s2 - | Swhile(e, s) -> collect_expr e; collect_stmt s - | Sdowhile(e, s) -> collect_stmt s; collect_expr e - | Sfor(s_init, e, s_iter, s_body) -> - collect_stmt s_init; collect_expr e; - collect_stmt s_iter; collect_stmt s_body - | Sbreak -> () - | Scontinue -> () - | Sswitch(e, cases) -> collect_expr e; collect_cases cases - | Sreturn None -> () - | Sreturn (Some e) -> collect_expr e - -and collect_cases = function - | LSdefault s -> collect_stmt s - | LScase(lbl, s, rem) -> collect_stmt s; collect_cases rem - -let collect_function f = - collect_type f.fn_return; - List.iter (fun (Coq_pair(id, ty)) -> collect_type ty) f.fn_params; - List.iter (fun (Coq_pair(id, ty)) -> collect_type ty) f.fn_vars; - collect_stmt f.fn_body - -let collect_fundef (Coq_pair(id, fd)) = - match fd with - | External(_, args, res) -> collect_type_list args; collect_type res - | Internal f -> collect_function f - -let collect_globvar (Coq_pair(Coq_pair(id, init), ty)) = - collect_type ty - -let collect_program p = - List.iter collect_globvar p.prog_vars; - List.iter collect_fundef p.prog_funct - -let declare_struct_or_union p (name, fld) = - fprintf p "%s;@ @ " name - -let print_struct_or_union p (name, fld) = - fprintf p "@[%s {" name; - let rec print_fields = function - | Fnil -> () - | Fcons(id, ty, rem) -> - fprintf p "@ %s;" (name_cdecl (extern_atom id) ty); - print_fields rem in - print_fields fld; - fprintf p "@;<0 -2>};@]@ " - -let print_program p prog = - struct_unions := StructUnionSet.empty; - collect_program prog; - fprintf p "@["; - StructUnionSet.iter (declare_struct_or_union p) !struct_unions; - StructUnionSet.iter (print_struct_or_union p) !struct_unions; - List.iter (print_globvar p) prog.prog_vars; - List.iter (print_fundef p) prog.prog_funct; - fprintf p "@]@." - - diff --git a/caml/PrintPPC.ml b/caml/PrintPPC.ml deleted file mode 100644 index 94c3a7b..0000000 --- a/caml/PrintPPC.ml +++ /dev/null @@ -1,532 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(* Printing PPC assembly code in asm syntax *) - -open Printf -open Datatypes -open CList -open Camlcoq -open AST -open PPC - -(* On-the-fly label renaming *) - -let next_label = ref 100 - -let new_label() = - let lbl = !next_label in incr next_label; lbl - -let current_function_labels = (Hashtbl.create 39 : (label, int) Hashtbl.t) - -let label_for_label lbl = - try - Hashtbl.find current_function_labels lbl - with Not_found -> - let lbl' = new_label() in - Hashtbl.add current_function_labels lbl lbl'; - lbl' - -(* Record identifiers of external functions *) - -module IdentSet = Set.Make(struct type t = ident let compare = compare end) - -let extfuns = ref IdentSet.empty - -let record_extfun (Coq_pair(name, defn)) = - match defn with - | Internal _ -> () - | External _ -> extfuns := IdentSet.add name !extfuns - -(* Basic printing functions *) - -let print_symb oc symb = - if IdentSet.mem symb !extfuns - then fprintf oc "L%s$stub" (extern_atom symb) - else fprintf oc "_%s" (extern_atom symb) - -let print_label oc lbl = - fprintf oc "L%d" (label_for_label lbl) - -let print_symb_ofs oc (symb, ofs) = - print_symb oc symb; - if ofs <> 0l then fprintf oc " + %ld" ofs - -let print_constant oc = function - | Cint n -> - fprintf oc "%ld" (camlint_of_coqint n) - | Csymbol_low(s, n) -> - fprintf oc "lo16(%a)" print_symb_ofs (s, camlint_of_coqint n) - | Csymbol_high(s, n) -> - fprintf oc "ha16(%a)" print_symb_ofs (s, camlint_of_coqint n) - -let num_crbit = function - | CRbit_0 -> 0 - | CRbit_1 -> 1 - | CRbit_2 -> 2 - | CRbit_3 -> 3 - -let print_crbit oc bit = - fprintf oc "%d" (num_crbit bit) - -let print_coqint oc n = - fprintf oc "%ld" (camlint_of_coqint n) - -let int_reg_name = function - | GPR0 -> "r0" | GPR1 -> "r1" | GPR2 -> "r2" | GPR3 -> "r3" - | GPR4 -> "r4" | GPR5 -> "r5" | GPR6 -> "r6" | GPR7 -> "r7" - | GPR8 -> "r8" | GPR9 -> "r9" | GPR10 -> "r10" | GPR11 -> "r11" - | GPR12 -> "r12" | GPR13 -> "r13" | GPR14 -> "r14" | GPR15 -> "r15" - | GPR16 -> "r16" | GPR17 -> "r17" | GPR18 -> "r18" | GPR19 -> "r19" - | GPR20 -> "r20" | GPR21 -> "r21" | GPR22 -> "r22" | GPR23 -> "r23" - | GPR24 -> "r24" | GPR25 -> "r25" | GPR26 -> "r26" | GPR27 -> "r27" - | GPR28 -> "r28" | GPR29 -> "r29" | GPR30 -> "r30" | GPR31 -> "r31" - -let float_reg_name = function - | FPR0 -> "f0" | FPR1 -> "f1" | FPR2 -> "f2" | FPR3 -> "f3" - | FPR4 -> "f4" | FPR5 -> "f5" | FPR6 -> "f6" | FPR7 -> "f7" - | FPR8 -> "f8" | FPR9 -> "f9" | FPR10 -> "f10" | FPR11 -> "f11" - | FPR12 -> "f12" | FPR13 -> "f13" | FPR14 -> "f14" | FPR15 -> "f15" - | FPR16 -> "f16" | FPR17 -> "f17" | FPR18 -> "f18" | FPR19 -> "f19" - | FPR20 -> "f20" | FPR21 -> "f21" | FPR22 -> "f22" | FPR23 -> "f23" - | FPR24 -> "f24" | FPR25 -> "f25" | FPR26 -> "f26" | FPR27 -> "f27" - | FPR28 -> "f28" | FPR29 -> "f29" | FPR30 -> "f30" | FPR31 -> "f31" - -let ireg oc r = output_string oc (int_reg_name r) -let ireg_or_zero oc r = if r = GPR0 then output_string oc "0" else ireg oc r -let freg oc r = output_string oc (float_reg_name r) - -(* Printing of instructions *) - -module Labelset = Set.Make(struct type t = label let compare = compare end) - -let print_instruction oc labels = function - | Padd(r1, r2, r3) -> - fprintf oc " add %a, %a, %a\n" ireg r1 ireg r2 ireg r3 - | Paddi(r1, r2, c) -> - fprintf oc " addi %a, %a, %a\n" ireg r1 ireg_or_zero r2 print_constant c - | Paddis(r1, r2, c) -> - fprintf oc " addis %a, %a, %a\n" ireg r1 ireg_or_zero r2 print_constant c - | Paddze(r1, r2) -> - fprintf oc " addze %a, %a\n" ireg r1 ireg r2 - | Pallocblock -> - fprintf oc " bl _compcert_alloc\n" - | Pallocframe(lo, hi, ofs) -> - let lo = camlint_of_coqint lo - and hi = camlint_of_coqint hi - and ofs = camlint_of_coqint ofs in - let sz = Int32.sub hi lo in - (* Keep stack 16-aligned *) - let sz16 = Int32.logand (Int32.add sz 15l) 0xFFFF_FFF0l in - assert (ofs = 0l); - fprintf oc " stwu r1, %ld(r1)\n" (Int32.neg sz16) - | Pand_(r1, r2, r3) -> - fprintf oc " and. %a, %a, %a\n" ireg r1 ireg r2 ireg r3 - | Pandc(r1, r2, r3) -> - fprintf oc " andc %a, %a, %a\n" ireg r1 ireg r2 ireg r3 - | Pandi_(r1, r2, c) -> - fprintf oc " andi. %a, %a, %a\n" ireg r1 ireg r2 print_constant c - | Pandis_(r1, r2, c) -> - fprintf oc " andis. %a, %a, %a\n" ireg r1 ireg r2 print_constant c - | Pb lbl -> - fprintf oc " b %a\n" print_label lbl - | Pbctr -> - fprintf oc " bctr\n" - | Pbctrl -> - fprintf oc " bctrl\n" - | Pbf(bit, lbl) -> - 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) -> - fprintf oc " bt %a, %a\n" print_crbit bit print_label lbl - | Pcmplw(r1, r2) -> - fprintf oc " cmplw cr0, %a, %a\n" ireg r1 ireg r2 - | Pcmplwi(r1, c) -> - fprintf oc " cmplwi cr0, %a, %a\n" ireg r1 print_constant c - | Pcmpw(r1, r2) -> - fprintf oc " cmpw cr0, %a, %a\n" ireg r1 ireg r2 - | Pcmpwi(r1, c) -> - fprintf oc " cmpwi cr0, %a, %a\n" ireg r1 print_constant c - | Pcror(c1, c2, c3) -> - fprintf oc " cror %a, %a, %a\n" print_crbit c1 print_crbit c2 print_crbit c3 - | Pdivw(r1, r2, r3) -> - fprintf oc " divw %a, %a, %a\n" ireg r1 ireg r2 ireg r3 - | Pdivwu(r1, r2, r3) -> - fprintf oc " divwu %a, %a, %a\n" ireg r1 ireg r2 ireg r3 - | Peqv(r1, r2, r3) -> - fprintf oc " eqv %a, %a, %a\n" ireg r1 ireg r2 ireg r3 - | Pextsb(r1, r2) -> - fprintf oc " extsb %a, %a\n" ireg r1 ireg r2 - | Pextsh(r1, r2) -> - fprintf oc " extsh %a, %a\n" ireg r1 ireg r2 - | Pfreeframe ofs -> - fprintf oc " lwz r1, %ld(r1)\n" (camlint_of_coqint ofs) - | Pfabs(r1, r2) -> - fprintf oc " fabs %a, %a\n" freg r1 freg r2 - | Pfadd(r1, r2, r3) -> - fprintf oc " fadd %a, %a, %a\n" freg r1 freg r2 freg r3 - | Pfcmpu(r1, r2) -> - fprintf oc " fcmpu cr0, %a, %a\n" freg r1 freg r2 - | Pfcti(r1, r2) -> - fprintf oc " fctiwz f13, %a\n" freg r2; - fprintf oc " stfd f13, -8(r1)\n"; - fprintf oc " lwz %a, -4(r1)\n" ireg r1 - | Pfctiu(r1, r2) -> - let lbl1 = new_label() in - let lbl2 = new_label() in - let lbl3 = new_label() in - fprintf oc " addis r12, 0, ha16(L%d)\n" lbl1; - fprintf oc " lfd f13, lo16(L%d)(r12)\n" lbl1; - fprintf oc " fcmpu cr7, %a, f13\n" freg r2; - fprintf oc " cror 30, 29, 30\n"; - fprintf oc " beq cr7, L%d\n" lbl2; - fprintf oc " fctiwz f13, %a\n" freg r2; - fprintf oc " stfdu f13, -8(r1)\n"; - fprintf oc " lwz %a, 4(r1)\n" ireg r1; - fprintf oc " b L%d\n" lbl3; - fprintf oc "L%d: fsub f13, %a, f13\n" lbl2 freg r2; - fprintf oc " fctiwz f13, f13\n"; - fprintf oc " stfdu f13, -8(r1)\n"; - fprintf oc " lwz %a, 4(r1)\n" ireg r1; - fprintf oc " addis %a, %a, 0x8000\n" ireg r1 ireg r1; - fprintf oc "L%d: addi r1, r1, 8\n" lbl3; - fprintf oc " .const_data\n"; - fprintf oc "L%d: .long 0x41e00000, 0x00000000\n" lbl1; - fprintf oc " .text\n" - | Pfdiv(r1, r2, r3) -> - fprintf oc " fdiv %a, %a, %a\n" freg r1 freg r2 freg r3 - | Pfmadd(r1, r2, r3, r4) -> - fprintf oc " fmadd %a, %a, %a, %a\n" freg r1 freg r2 freg r3 freg r4 - | Pfmr(r1, r2) -> - fprintf oc " fmr %a, %a\n" freg r1 freg r2 - | Pfmsub(r1, r2, r3, r4) -> - fprintf oc " fmsub %a, %a, %a, %a\n" freg r1 freg r2 freg r3 freg r4 - | Pfmul(r1, r2, r3) -> - fprintf oc " fmul %a, %a, %a\n" freg r1 freg r2 freg r3 - | Pfneg(r1, r2) -> - fprintf oc " fneg %a, %a\n" freg r1 freg r2 - | Pfrsp(r1, r2) -> - fprintf oc " frsp %a, %a\n" freg r1 freg r2 - | Pfsub(r1, r2, r3) -> - fprintf oc " fsub %a, %a, %a\n" freg r1 freg r2 freg r3 - | Pictf(r1, r2) -> - let lbl = new_label() in - fprintf oc " addis r12, 0, 0x4330\n"; - fprintf oc " stw r12, -8(r1)\n"; - fprintf oc " addis r12, %a, 0x8000\n" ireg r2; - fprintf oc " stw r12, -4(r1)\n"; - fprintf oc " addis r12, 0, ha16(L%d)\n" lbl; - fprintf oc " lfd f13, lo16(L%d)(r12)\n" lbl; - fprintf oc " lfd %a, -8(r1)\n" freg r1; - fprintf oc " fsub %a, %a, f13\n" freg r1 freg r1; - fprintf oc " .const_data\n"; - fprintf oc "L%d: .long 0x43300000, 0x80000000\n" lbl; - fprintf oc " .text\n" - | Piuctf(r1, r2) -> - let lbl = new_label() in - fprintf oc " addis r12, 0, 0x4330\n"; - fprintf oc " stw r12, -8(r1)\n"; - fprintf oc " stw %a, -4(r1)\n" ireg r2; - fprintf oc " addis r12, 0, ha16(L%d)\n" lbl; - fprintf oc " lfd f13, lo16(L%d)(r12)\n" lbl; - fprintf oc " lfd %a, -8(r1)\n" freg r1; - fprintf oc " fsub %a, %a, f13\n" freg r1 freg r1; - fprintf oc " .const_data\n"; - fprintf oc "L%d: .long 0x43300000, 0x00000000\n" lbl; - fprintf oc " .text\n" - | Plbz(r1, c, r2) -> - fprintf oc " lbz %a, %a(%a)\n" ireg r1 print_constant c ireg r2 - | Plbzx(r1, r2, r3) -> - fprintf oc " lbzx %a, %a, %a\n" ireg r1 ireg r2 ireg r3 - | Plfd(r1, c, r2) -> - fprintf oc " lfd %a, %a(%a)\n" freg r1 print_constant c ireg r2 - | Plfdx(r1, r2, r3) -> - fprintf oc " lfdx %a, %a, %a\n" freg r1 ireg r2 ireg r3 - | Plfi(r1, c) -> - let lbl = new_label() in - fprintf oc " addis r12, 0, ha16(L%d)\n" lbl; - fprintf oc " lfd %a, lo16(L%d)(r12)\n" freg r1 lbl; - fprintf oc " .const_data\n"; - let n = Int64.bits_of_float c in - let nlo = Int64.to_int32 n - and nhi = Int64.to_int32(Int64.shift_right_logical n 32) in - fprintf oc "L%d: .long 0x%lx, 0x%lx ; %f\n" lbl nhi nlo c; - fprintf oc " .text\n" - | Plfs(r1, c, r2) -> - fprintf oc " lfs %a, %a(%a)\n" freg r1 print_constant c ireg r2 - | Plfsx(r1, r2, r3) -> - fprintf oc " lfsx %a, %a, %a\n" freg r1 ireg r2 ireg r3 - | Plha(r1, c, r2) -> - fprintf oc " lha %a, %a(%a)\n" ireg r1 print_constant c ireg r2 - | Plhax(r1, r2, r3) -> - fprintf oc " lhax %a, %a, %a\n" ireg r1 ireg r2 ireg r3 - | Plhz(r1, c, r2) -> - fprintf oc " lhz %a, %a(%a)\n" ireg r1 print_constant c ireg r2 - | Plhzx(r1, r2, r3) -> - fprintf oc " lhzx %a, %a, %a\n" ireg r1 ireg r2 ireg r3 - | Plwz(r1, c, r2) -> - fprintf oc " lwz %a, %a(%a)\n" ireg r1 print_constant c ireg r2 - | Plwzx(r1, r2, r3) -> - fprintf oc " lwzx %a, %a, %a\n" ireg r1 ireg r2 ireg r3 - | Pmfcrbit(r1, bit) -> - fprintf oc " mfcr r2\n"; - fprintf oc " rlwinm %a, r2, %d, 1\n" ireg r1 (1 + num_crbit bit) - | Pmflr(r1) -> - fprintf oc " mflr %a\n" ireg r1 - | Pmr(r1, r2) -> - fprintf oc " mr %a, %a\n" ireg r1 ireg r2 - | Pmtctr(r1) -> - fprintf oc " mtctr %a\n" ireg r1 - | Pmtlr(r1) -> - fprintf oc " mtlr %a\n" ireg r1 - | Pmulli(r1, r2, c) -> - fprintf oc " mulli %a, %a, %a\n" ireg r1 ireg r2 print_constant c - | Pmullw(r1, r2, r3) -> - fprintf oc " mullw %a, %a, %a\n" ireg r1 ireg r2 ireg r3 - | Pnand(r1, r2, r3) -> - fprintf oc " nand %a, %a, %a\n" ireg r1 ireg r2 ireg r3 - | Pnor(r1, r2, r3) -> - fprintf oc " nor %a, %a, %a\n" ireg r1 ireg r2 ireg r3 - | Por(r1, r2, r3) -> - fprintf oc " or %a, %a, %a\n" ireg r1 ireg r2 ireg r3 - | Porc(r1, r2, r3) -> - fprintf oc " orc %a, %a, %a\n" ireg r1 ireg r2 ireg r3 - | Pori(r1, r2, c) -> - fprintf oc " ori %a, %a, %a\n" ireg r1 ireg r2 print_constant c - | Poris(r1, r2, c) -> - fprintf oc " oris %a, %a, %a\n" ireg r1 ireg r2 print_constant c - | Prlwinm(r1, r2, c1, c2) -> - fprintf oc " rlwinm %a, %a, %ld, 0x%lx\n" - ireg r1 ireg r2 (camlint_of_coqint c1) (camlint_of_coqint c2) - | Pslw(r1, r2, r3) -> - fprintf oc " slw %a, %a, %a\n" ireg r1 ireg r2 ireg r3 - | Psraw(r1, r2, r3) -> - fprintf oc " sraw %a, %a, %a\n" ireg r1 ireg r2 ireg r3 - | Psrawi(r1, r2, c) -> - fprintf oc " srawi %a, %a, %ld\n" ireg r1 ireg r2 (camlint_of_coqint c) - | Psrw(r1, r2, r3) -> - fprintf oc " srw %a, %a, %a\n" ireg r1 ireg r2 ireg r3 - | Pstb(r1, c, r2) -> - fprintf oc " stb %a, %a(%a)\n" ireg r1 print_constant c ireg r2 - | Pstbx(r1, r2, r3) -> - fprintf oc " stbx %a, %a, %a\n" ireg r1 ireg r2 ireg r3 - | Pstfd(r1, c, r2) -> - fprintf oc " stfd %a, %a(%a)\n" freg r1 print_constant c ireg r2 - | Pstfdx(r1, r2, r3) -> - fprintf oc " stfdx %a, %a, %a\n" freg r1 ireg r2 ireg r3 - | Pstfs(r1, c, r2) -> - fprintf oc " stfs %a, %a(%a)\n" freg r1 print_constant c ireg r2 - | Pstfsx(r1, r2, r3) -> - fprintf oc " stfsx %a, %a, %a\n" freg r1 ireg r2 ireg r3 - | Psth(r1, c, r2) -> - fprintf oc " sth %a, %a(%a)\n" ireg r1 print_constant c ireg r2 - | Psthx(r1, r2, r3) -> - fprintf oc " sthx %a, %a, %a\n" ireg r1 ireg r2 ireg r3 - | Pstw(r1, c, r2) -> - fprintf oc " stw %a, %a(%a)\n" ireg r1 print_constant c ireg r2 - | Pstwx(r1, r2, r3) -> - fprintf oc " stwx %a, %a, %a\n" ireg r1 ireg r2 ireg r3 - | Psubfc(r1, r2, r3) -> - fprintf oc " subfc %a, %a, %a\n" ireg r1 ireg r2 ireg r3 - | Psubfic(r1, r2, c) -> - fprintf oc " subfic %a, %a, %a\n" ireg r1 ireg r2 print_constant c - | Pxor(r1, r2, r3) -> - fprintf oc " xor %a, %a, %a\n" ireg r1 ireg r2 ireg r3 - | Pxori(r1, r2, c) -> - fprintf oc " xori %a, %a, %a\n" ireg r1 ireg r2 print_constant c - | Pxoris(r1, r2, c) -> - 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 - -let rec labels_of_code = function - | [] -> Labelset.empty - | (Pb lbl | Pbf(_, lbl) | Pbt(_, lbl)) :: c -> - Labelset.add lbl (labels_of_code c) - | _ :: c -> labels_of_code c - -let print_function oc name code = - Hashtbl.clear current_function_labels; - fprintf oc " .text\n"; - fprintf oc " .align 2\n"; - fprintf oc " .globl %a\n" print_symb name; - fprintf oc "%a:\n" print_symb name; - List.iter (print_instruction oc (labels_of_code code)) code - -(* Generation of stub code for variadic functions, e.g. printf. - Calling conventions for variadic functions are: - - always reserve 8 stack words (offsets 24 to 52) so that the - variadic function can save there the integer registers parameters - r3 ... r10 - - treat float arguments as pairs of integers, i.e. if we - must pass them in registers, use a pair of integer registers - for this purpose. - The code we generate is: - - allocate large enough stack frame - - save return address - - copy our arguments (registers and stack) to the stack frame, - starting at offset 24 - - load relevant integer parameter registers r3...r10 from the - stack frame, limited by the actual number of arguments - - call the variadic thing - - deallocate stack frame and return -*) - -let variadic_stub oc stub_name fun_name ty_args = - (* Compute total size of arguments *) - let arg_size = - CList.fold_left - (fun sz ty -> match ty with Tint -> sz + 4 | Tfloat -> sz + 8) - ty_args 0 in - (* Stack size is linkage area + argument size, with a minimum of 56 bytes *) - let frame_size = max 56 (24 + arg_size) in - fprintf oc " mflr r0\n"; - fprintf oc " stwu r1, %d(r1)\n" (-frame_size); - fprintf oc " stw r0, %d(r1)\n" (frame_size + 4); - (* Copy our parameters to our stack frame. - As an optimization, don't copy parameters that are already in - integer registers, since these stay in place. *) - let rec copy gpr fpr src_ofs dst_ofs = function - | [] -> () - | Tint :: rem -> - if gpr > 10 then begin - fprintf oc " lwz r0, %d(r1)\n" src_ofs; - fprintf oc " stw r0, %d(r1)\n" dst_ofs - end; - copy (gpr + 1) fpr (src_ofs + 4) (dst_ofs + 4) rem - | Tfloat :: rem -> - if fpr <= 10 then begin - fprintf oc " stfd f%d, %d(r1)\n" fpr dst_ofs - end else begin - fprintf oc " lfd f0, %d(r1)\n" src_ofs; - fprintf oc " stfd f0, %d(r1)\n" dst_ofs - end; - copy (gpr + 2) (fpr + 1) (src_ofs + 8) (dst_ofs + 8) rem - in copy 3 1 (frame_size + 24) 24 ty_args; - (* Load the first parameters into integer registers. - As an optimization, don't load parameters that are already - in the correct integer registers. *) - let rec load gpr ofs = function - | [] -> () - | Tint :: rem -> - load (gpr + 1) (ofs + 4) rem - | Tfloat :: rem -> - if gpr <= 10 then - fprintf oc " lwz r%d, %d(r1)\n" gpr ofs; - if gpr + 1 <= 10 then - fprintf oc " lwz r%d, %d(r1)\n" (gpr + 1) (ofs + 4); - load (gpr + 2) (ofs + 8) rem - in load 3 24 ty_args; - (* Call the function *) - fprintf oc " addis r11, 0, ha16(L%s$ptr)\n" stub_name; - fprintf oc " lwz r11, lo16(L%s$ptr)(r11)\n" stub_name; - fprintf oc " mtctr r11\n"; - fprintf oc " bctrl\n"; - (* Free our frame and return *) - fprintf oc " lwz r0, %d(r1)\n" (frame_size + 4); - fprintf oc " mtlr r0\n"; - fprintf oc " addi r1, r1, %d\n" frame_size; - fprintf oc " blr\n"; - (* The function pointer *) - fprintf oc " .non_lazy_symbol_pointer\n"; - fprintf oc "L%s$ptr:\n" stub_name; - fprintf oc " .indirect_symbol _%s\n" fun_name; - fprintf oc " .long 0\n" - -(* Stubs for fixed-type functions are much simpler *) - -let non_variadic_stub oc name = - fprintf oc " addis r11, 0, ha16(L%s$ptr)\n" name; - fprintf oc " lwz r11, lo16(L%s$ptr)(r11)\n" name; - fprintf oc " mtctr r11\n"; - fprintf oc " bctr\n"; - fprintf oc " .non_lazy_symbol_pointer\n"; - fprintf oc "L%s$ptr:\n" name; - fprintf oc " .indirect_symbol _%s\n" name; - fprintf oc " .long 0\n" - -let re_variadic_stub = Str.regexp "\\(.*\\)\\$[if]*$" - -let print_external_function oc name ef = - let name = extern_atom name in - fprintf oc " .text\n"; - fprintf oc " .align 2\n"; - fprintf oc "L%s$stub:\n" name; - if Str.string_match re_variadic_stub name 0 - then variadic_stub oc name (Str.matched_group 1 name) ef.ef_sig.sig_args - else non_variadic_stub oc name - -let print_fundef oc (Coq_pair(name, defn)) = - match defn with - | Internal code -> print_function oc name code - | External ef -> print_external_function oc name ef - -let init_data_queue = ref [] - -let print_init oc = function - | Init_int8 n -> - fprintf oc " .byte %ld\n" (camlint_of_coqint n) - | Init_int16 n -> - fprintf oc " .short %ld\n" (camlint_of_coqint n) - | Init_int32 n -> - fprintf oc " .long %ld\n" (camlint_of_coqint n) - | Init_float32 n -> - fprintf oc " .long %ld ; %g \n" (Int32.bits_of_float n) n - | Init_float64 n -> - (* .quad not working on all versions of the MacOSX assembler *) - let b = Int64.bits_of_float n in - fprintf oc " .long %Ld, %Ld ; %g \n" - (Int64.shift_right_logical b 32) - (Int64.logand b 0xFFFFFFFFL) - n - | Init_space n -> - let n = camlint_of_z n in - if n > 0l then fprintf oc " .space %ld\n" n - | Init_pointer id -> - let lbl = new_label() in - fprintf oc " .long L%d\n" lbl; - init_data_queue := (lbl, id) :: !init_data_queue - -let print_init_data oc id = - init_data_queue := []; - List.iter (print_init oc) id; - let rec print_remainder () = - match !init_data_queue with - | [] -> () - | (lbl, id) :: rem -> - init_data_queue := rem; - fprintf oc "L%d:\n" lbl; - List.iter (print_init oc) id; - print_remainder() - in print_remainder() - -let print_var oc (Coq_pair(Coq_pair(name, init_data), _)) = - match init_data with - | [] -> () - | _ -> - fprintf oc " .data\n"; - fprintf oc " .align 3\n"; - fprintf oc " .globl %a\n" print_symb name; - fprintf oc "%a:\n" print_symb name; - print_init_data oc init_data - -let print_program oc p = - extfuns := IdentSet.empty; - List.iter record_extfun p.prog_funct; - List.iter (print_var oc) p.prog_vars; - List.iter (print_fundef oc) p.prog_funct - diff --git a/caml/PrintPPC.mli b/caml/PrintPPC.mli deleted file mode 100644 index 2ebbb95..0000000 --- a/caml/PrintPPC.mli +++ /dev/null @@ -1,13 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -val print_program: out_channel -> PPC.program -> unit diff --git a/caml/RTLgenaux.ml b/caml/RTLgenaux.ml deleted file mode 100644 index 4c1fc05..0000000 --- a/caml/RTLgenaux.ml +++ /dev/null @@ -1,72 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -open Camlcoq -open 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 - | [] -> [] - | 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 minval maxval = - match hi - lo with - | 0 -> - CTaction default - | 1 -> - let (key, act) = sw.(lo) in - if Integers.Int.sub maxval minval = Integers.Int.zero - then CTaction act - else CTifeq(key, act, CTaction default) - | 2 -> - let (key1, act1) = sw.(lo) - and (key2, act2) = sw.(lo+1) in - CTifeq(key1, act1, - if Integers.Int.sub maxval minval = Integers.Int.one - then CTaction act2 - else CTifeq(key2, act2, CTaction default)) - | 3 -> - let (key1, act1) = sw.(lo) - and (key2, act2) = sw.(lo+1) - and (key3, act3) = sw.(lo+2) in - CTifeq(key1, act1, - CTifeq(key2, act2, - if Integers.Int.sub maxval minval = coqint_of_camlint 2l - then CTaction act3 - else CTifeq(key3, act3, CTaction default))) - | _ -> - let mid = (lo + hi) / 2 in - let (pivot, _) = sw.(mid) in - CTiflt(pivot, - build lo mid minval (Integers.Int.sub pivot Integers.Int.one), - build mid hi pivot maxval) - in build 0 (Array.length sw) Integers.Int.zero Integers.Int.max_unsigned diff --git a/caml/RTLtypingaux.ml b/caml/RTLtypingaux.ml deleted file mode 100644 index ff704eb..0000000 --- a/caml/RTLtypingaux.ml +++ /dev/null @@ -1,156 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(* Type inference for RTL *) - -open Datatypes -open CList -open Camlcoq -open Maps -open AST -open Op -open Registers -open RTL - -exception Type_error of string - -let env = ref (PTree.empty : typ PTree.t) - -let set_type r ty = - match PTree.get r !env with - | None -> env := PTree.set r ty !env - | Some ty' -> if ty <> ty' then raise (Type_error "type mismatch") - -let rec set_types rl tyl = - match rl, tyl with - | [], [] -> () - | r1 :: rs, ty1 :: tys -> set_type r1 ty1; set_types rs tys - | _, _ -> raise (Type_error "arity mismatch") - -(* First pass: process constraints of the form typeof(r) = ty *) - -let type_instr retty (Coq_pair(pc, i)) = - match i with - | Inop(_) -> - () - | Iop(Omove, _, _, _) -> - () - | Iop(op, args, res, _) -> - let (Coq_pair(targs, tres)) = type_of_operation op in - set_types args targs; set_type res tres - | Iload(chunk, addr, args, dst, _) -> - set_types args (type_of_addressing addr); - set_type dst (type_of_chunk chunk) - | Istore(chunk, addr, args, src, _) -> - set_types args (type_of_addressing addr); - set_type src (type_of_chunk chunk) - | Icall(sg, ros, args, res, _) -> - begin try - begin match ros with - | Coq_inl r -> set_type r Tint - | Coq_inr _ -> () - end; - set_types args sg.sig_args; - set_type res (match sg.sig_res with None -> Tint | Some ty -> ty) - 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 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, _, _) -> - set_types args (type_of_condition cond) - | Ireturn(optres) -> - begin match optres, retty with - | None, None -> () - | Some r, Some ty -> set_type r ty - | _, _ -> raise (Type_error "type mismatch in Ireturn") - end - -let type_pass1 retty instrs = - List.iter (type_instr retty) instrs - -(* Second pass: extract move constraints typeof(r1) = typeof(r2) - and solve them iteratively *) - -let rec extract_moves = function - | [] -> [] - | Coq_pair(pc, i) :: rem -> - match i with - | Iop(Omove, [r1], r2, _) -> - (r1, r2) :: extract_moves rem - | Iop(Omove, _, _, _) -> - raise (Type_error "wrong Omove") - | _ -> - extract_moves rem - -let changed = ref false - -let rec solve_moves = function - | [] -> [] - | (r1, r2) :: rem -> - match (PTree.get r1 !env, PTree.get r2 !env) with - | Some ty1, Some ty2 -> - if ty1 = ty2 - then (changed := true; solve_moves rem) - else raise (Type_error "type mismatch in Omove") - | Some ty1, None -> - env := PTree.set r2 ty1 !env; changed := true; solve_moves rem - | None, Some ty2 -> - env := PTree.set r1 ty2 !env; changed := true; solve_moves rem - | None, None -> - (r1, r2) :: solve_moves rem - -let rec iter_solve_moves mvs = - changed := false; - let mvs' = solve_moves mvs in - if !changed then iter_solve_moves mvs' - -let type_pass2 instrs = - iter_solve_moves (extract_moves instrs) - -let typeof e r = - match PTree.get r e with Some ty -> ty | None -> Tint - -let infer_type_environment f instrs = - try - env := PTree.empty; - set_types f.fn_params f.fn_sig.sig_args; - type_pass1 f.fn_sig.sig_res instrs; - type_pass2 instrs; - let e = !env in - env := PTree.empty; - Some(typeof e) - with Type_error msg -> - Printf.eprintf "Error during RTL type inference: %s\n" msg; - None diff --git a/cfrontend/Cil2Csyntax.ml b/cfrontend/Cil2Csyntax.ml new file mode 100644 index 0000000..41fe1d4 --- /dev/null +++ b/cfrontend/Cil2Csyntax.ml @@ -0,0 +1,992 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Thomas Moniot, INRIA Paris-Rocquencourt *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU General Public License as published by *) +(* the Free Software Foundation, either version 2 of the License, or *) +(* (at your option) any later version. This file is also distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(************************************************************************** +CIL -> CabsCoq translator +**************************************************************************) + +open Cil +open CList +open Camlcoq +open AST +open Csyntax + + + + +module type TypeSpecifierTranslator = + sig + val convertIkind: Cil.ikind -> (intsize * signedness) option + val convertFkind: Cil.fkind -> floatsize option + end + + + + + +module Make(TS: TypeSpecifierTranslator) = struct +(*-----------------------------------------------------------------------*) + + +(** Pre-defined constants *) +let constInt32 = Tint (I32, Signed) +let constInt32uns = Tint (I32, Unsigned) +let const0 = Expr (Econst_int (coqint_of_camlint Int32.zero), constInt32) + + +(** Global variables *) +let currentLocation = ref Cil.locUnknown +let currentGlobalPrefix = ref "" +let stringNum = ref 0 (* number of next global for string literals *) +let stringTable = Hashtbl.create 47 + +(** ** Functions related to [struct]s and [union]s *) + +(* Unroll recursion in struct or union types: + substitute [Tcomp_ptr id] by [Tpointer compty] in [ty]. *) + +let unrollType id compty ty = + let rec unrType ty = + match ty with + | Tvoid -> ty + | Tint(sz, sg) -> ty + | Tfloat sz -> ty + | Tpointer ty -> Tpointer (unrType ty) + | Tarray(ty, sz) -> Tarray (unrType ty, sz) + | Tfunction(args, res) -> Tfunction(unrTypelist args, unrType res) + | Tstruct(id', fld) -> + if id' = id then ty else Tstruct(id', unrFieldlist fld) + | Tunion(id', fld) -> + if id' = id then ty else Tunion(id', unrFieldlist fld) + | Tcomp_ptr id' -> + if id' = id then Tpointer compty else ty + and unrTypelist = function + | Tnil -> Tnil + | Tcons(hd, tl) -> Tcons(unrType hd, unrTypelist tl) + and unrFieldlist = function + | Fnil -> Fnil + | Fcons(id, ty, tl) -> Fcons(id, unrType ty, unrFieldlist tl) + in unrType ty + +(* Return the type of a [struct] field *) +let rec getFieldType f = function + | Fnil -> raise Not_found + | Fcons(idf, t, rem) -> if idf = f then t else getFieldType f rem + +(** ** Some functions over lists *) + +(** Keep the elements in a list from [elt] (included) to the end + (used for the translation of the [switch] statement) *) +let rec keepFrom elt = function + | [] -> [] + | (x :: l) as l' -> if x == elt then l' else keepFrom elt l + +(** Keep the elements in a list before [elt'] (excluded) + (used for the translation of the [switch] statement) *) +let rec keepUntil elt' = function + | [] -> [] + | x :: l -> if x == elt' then [] else x :: (keepUntil elt' l) + +(** Keep the elements in a list from [elt] (included) to [elt'] (excluded) + (used for the translation of the [switch] statement) *) +let keepBetween elt elt' l = + keepUntil elt' (keepFrom elt l) + +(** ** Functions used to handle locations *) + +(** Update the current location *) +let updateLoc loc = + currentLocation := loc + +(** Convert the current location into a string *) +let currentLoc() = + match !currentLocation with { line=l; file=f } -> + f ^ ":" ^ (if l = -1 then "?" else string_of_int l) ^ ": " + +(** Exception raised when an unsupported feature is encountered *) +exception Unsupported of string +let unsupported msg = + raise (Unsupported(currentLoc() ^ "Unsupported C feature: " ^ msg)) + +(** Exception raised when an internal error is encountered *) +exception Internal_error of string +let internal_error msg = + raise (Internal_error(currentLoc() ^ "Internal error: " ^ msg)) + +(** Warning messages *) +let warning msg = + prerr_string (currentLoc()); + prerr_string "Warning: "; + prerr_endline msg + +(** ** Functions used to handle string literals *) +let name_for_string_literal s = + try + Hashtbl.find stringTable s + with Not_found -> + incr stringNum; + let symbol_name = + Printf.sprintf "_%s__stringlit_%d" + !currentGlobalPrefix !stringNum in + let symbol_ident = intern_string symbol_name in + Hashtbl.add stringTable s symbol_ident; + symbol_ident + +let typeStringLiteral s = + Tarray(Tint(I8, Unsigned), z_of_camlint(Int32.of_int(String.length s + 1))) + +let global_for_string s id = + let init = ref [] in + let add_char c = + init := + AST.Init_int8(coqint_of_camlint(Int32.of_int(Char.code c))) + :: !init in + add_char '\000'; + for i = String.length s - 1 downto 0 do add_char s.[i] done; + Datatypes.Coq_pair(Datatypes.Coq_pair(id, !init), typeStringLiteral s) + +let globals_for_strings globs = + Hashtbl.fold + (fun s id l -> global_for_string s id :: l) + stringTable globs + +(** ** Handling of stubs for variadic functions *) + +let stub_function_table = Hashtbl.create 47 + +let register_stub_function name tres targs = + let rec letters_of_type = function + | Tnil -> [] + | Tcons(Tfloat _, tl) -> "f" :: letters_of_type tl + | Tcons(_, tl) -> "i" :: letters_of_type tl in + let stub_name = + name ^ "$" ^ String.concat "" (letters_of_type targs) in + try + (stub_name, Hashtbl.find stub_function_table stub_name) + with Not_found -> + let rec types_of_types = function + | Tnil -> Tnil + | Tcons(Tfloat _, tl) -> Tcons(Tfloat F64, types_of_types tl) + | Tcons(_, tl) -> Tcons(Tpointer Tvoid, types_of_types tl) in + let stub_type = Tfunction (types_of_types targs, tres) in + Hashtbl.add stub_function_table stub_name stub_type; + (stub_name, stub_type) + +let declare_stub_function stub_name stub_type = + match stub_type with + | Tfunction(targs, tres) -> + Datatypes.Coq_pair(intern_string stub_name, + External(intern_string stub_name, targs, tres)) + | _ -> assert false + +let declare_stub_functions k = + Hashtbl.fold (fun n i k -> declare_stub_function n i :: k) + stub_function_table k + +(** ** Generation of temporary variable names *) + +let current_function = ref (None: Cil.fundec option) + +let make_temp typ = + match !current_function with + | None -> assert false + | Some f -> + let v = Cil.makeTempVar f typ in + intern_string v.vname + +(** Detect and report GCC's __builtin_ functions *) + +let check_builtin s = + let b = "__builtin_" in + if String.length s >= String.length b + && String.sub s 0 (String.length b) = b + then unsupported ("GCC `" ^ s ^ "' built-in function") + +(** ** Translation functions *) + +(** Convert a [Cil.ikind] into a pair [(intsize * signedness)] *) +let convertIkind ik = + match TS.convertIkind ik with + | Some p -> p + | None -> unsupported "integer type specifier" + + +(** Convert a [Cil.fkind] into a [floatsize] *) +let convertFkind fk = + match TS.convertFkind fk with + | Some fs -> fs + | None -> unsupported "floating-point type specifier" + + +(** Convert a [Cil.constant] into a [CabsCoq.expr] *) +let rec convertConstant = function + | CInt64 (i64, _, _) -> + let i = coqint_of_camlint (Int64.to_int32 i64) in + Expr (Econst_int i, constInt32) + | CStr s -> + let symb = name_for_string_literal s in + Expr (Evar symb, typeStringLiteral s) + | CWStr _ -> + unsupported "wide string literal" + | CChr c -> + let i = coqint_of_camlint (Int32.of_int (Char.code c)) in + Expr (Econst_int i, constInt32) + | CReal (f, _, _) -> + Expr (Econst_float f, Tfloat F64) + | (CEnum (exp, str, enumInfo)) as enum -> + (* do constant folding on an enum constant *) + let e = Cil.constFold false (Const enum) in + convertExp e + + +(** Convert a [Cil.UnOp] into a [CabsCoq.expr] + ([t] is the type of the result of applying [uop] to [e]) *) +and convertUnop uop e t = + let e' = convertExp e in + let t' = convertTyp t in + let uop' = match uop with + | Neg -> Eunop (Oneg, e') + | BNot -> Eunop (Onotint, e') + | LNot -> Eunop (Onotbool, e') + in + Expr (uop', t') + + +(** Convert a [Cil.BinOp] into a [CabsCoq.expr] + ([t] is the type of the result of applying [bop] to [(e1, e2)], every + arithmetic conversion being made explicit by CIL for both arguments] *) +and convertBinop bop e1 e2 t = + let e1' = convertExp e1 in + let e2' = convertExp e2 in + let t' = convertTyp t in + let bop' = match bop with + | PlusA -> Ebinop (Oadd, e1', e2') + | PlusPI -> Ebinop (Oadd, e1', e2') + | IndexPI -> Ebinop (Oadd, e1', e2') + | MinusA -> Ebinop (Osub, e1', e2') + | MinusPI -> Ebinop (Osub, e1', e2') + | MinusPP -> Ebinop (Osub, e1', e2') + | Mult -> Ebinop (Omul, e1', e2') + | Div -> Ebinop (Odiv, e1', e2') + | Mod -> Ebinop (Omod, e1', e2') + | Shiftlt -> Ebinop (Oshl, e1', e2') + | Shiftrt -> Ebinop (Oshr, e1', e2') + | Lt -> Ebinop (Olt, e1', e2') + | Gt -> Ebinop (Ogt, e1', e2') + | Le -> Ebinop (Ole, e1', e2') + | Ge -> Ebinop (Oge, e1', e2') + | Eq -> Ebinop (Oeq, e1', e2') + | Ne -> Ebinop (One, e1', e2') + | BAnd -> Ebinop (Oand, e1', e2') + | BXor -> Ebinop (Oxor, e1', e2') + | BOr -> Ebinop (Oor, e1', e2') + | LAnd -> Eandbool (e1', e2') + | LOr -> Eorbool (e1', e2') + in + Expr (bop', t') + + +(** Test if two types are compatible + (in order to cast one of the types to the other) *) +and compatibleTypes t1 t2 = true +(* + let isArithmeticType = function + | Tint _ | Tfloat _ -> true + | _ -> false + in + let isPointerType = function + | Tpointer _ | Tarray _ -> true + | _ -> false + in + (t1 = t2) + || (isArithmeticType t1 && isArithmeticType t2) + || match (t1, t2) with + | (Tpointer Tvoid, t) | (t, Tpointer Tvoid) -> isPointerType t + | (Tint _, t) | (t, Tint _) -> isPointerType t + | _ -> false +*) + + +(** Convert a [Cil.CastE] into a [CabsCoq.expr] + (fail if the cast is illegal) *) +and processCast t e = + let t' = convertTyp t in + let te = convertTyp (Cil.typeOf e) in + if compatibleTypes t' te then + let e' = convertExp e in + Expr (Ecast (t', e'), t') + else internal_error "processCast: illegal cast" + + +(** Convert a [Cil.exp list] into an [CamlCoq.exprlist] *) +and processParamsE = function + | [] -> [] + | e :: l -> + let (Expr (_, t)) as e' = convertExp e in + match t with + | Tstruct _ | Tunion _ -> + unsupported "function parameter of struct or union type" + | _ -> e' :: processParamsE l + + +(** Convert a [Cil.exp] into a [CabsCoq.expr] *) +and convertExp = function + | Const c -> + convertConstant c + | Lval lv -> + convertLval lv + | SizeOf t -> + Expr (Esizeof (convertTyp t), constInt32uns) + | SizeOfE e -> + let ty = convertTyp (Cil.typeOf e) in + Expr (Esizeof ty, constInt32uns) + | SizeOfStr str -> + let n = coqint_of_camlint (Int32.of_int(String.length str)) in + Expr (Econst_int n, constInt32uns) + | AlignOf t -> + unsupported "GCC `alignof' construct" + | AlignOfE e -> + unsupported "GCC `alignof' construct" + | UnOp (uop, e, t) -> + convertUnop uop e t + | BinOp (bop, e1, e2, t) -> + convertBinop bop e1 e2 t + | CastE (t, e) -> + processCast t e + | AddrOf lv -> + let (Expr (_, t)) as e = convertLval lv in + Expr (Eaddrof e, Tpointer t) + | StartOf lv -> + (* convert an array into a pointer to the beginning of the array *) + match Cil.unrollType (Cil.typeOfLval lv) with + | TArray (t, _, _) -> + let t' = convertTyp t in + let tPtr = Tpointer t' in + let e = convertLval lv in + (* array A of type T replaced by (T* )A *) + Expr (Ecast (tPtr, e), tPtr) + | _ -> internal_error "convertExp: StartOf applied to a \ + lvalue whose type is not an array" + + +(** Convert a [Cil.lval] into a [CabsCoq.expression] *) +and convertLval lv = + (* convert the offset of the lvalue *) + let rec processOffset ((Expr (_, t)) as e) = function + | NoOffset -> e + | Field (f, ofs) -> + begin match t with + | Tstruct(id, fList) -> + begin try + let idf = intern_string f.fname in + let t' = unrollType id t (getFieldType idf fList) in + processOffset (Expr (Efield (e, idf), t')) ofs + with Not_found -> + internal_error "processOffset: no such struct field" + end + | Tunion(id, fList) -> + begin try + let idf = intern_string f.fname in + let t' = unrollType id t (getFieldType idf fList) in + processOffset (Expr (Efield (e, idf), t')) ofs + with Not_found -> + internal_error "processOffset: no such union field" + end + | _ -> + internal_error "processOffset: Field on a non-struct nor union" + end + | Index (e', ofs) -> + match t with + | Tarray (t', _) -> + let e'' = Ederef(Expr (Ebinop(Oadd, e, convertExp e'), t)) in + processOffset (Expr (e'', t')) ofs + | _ -> internal_error "processOffset: Index on a non-array" + in + (* convert the lvalue *) + match lv with + | (Var v, ofs) -> + check_builtin v.vname; + let id = intern_string v.vname in + processOffset (Expr (Evar id, convertTyp v.vtype)) ofs + | (Mem e, ofs) -> + match Cil.unrollType (Cil.typeOf e) with + | TPtr (t, _) -> let e' = Ederef (convertExp e) in + processOffset (Expr (e', convertTyp t)) ofs + | _ -> internal_error "convertLval: Mem on a non-pointer" + + +(** Convert a [(Cil.string * Cil.typ * Cil.attributes)] list + into a [typelist] *) +and processParamsT convert = function + | [] -> Tnil + | (_, t, _) :: l -> + let t' = convert t in + match t' with + | Tstruct _ | Tunion _ -> + unsupported "function parameter of struct or union type" + | _ -> Tcons (t', processParamsT convert l) + + +(** Convert a [Cil.typ] into a [coq_type] *) +and convertTypGen env = function + | TVoid _ -> Tvoid + | TInt (k, _) -> let (x, y) = convertIkind k in Tint (x, y) + | TFloat (k, _) -> Tfloat (convertFkind k) + | TPtr (TComp(c, _), _) when List.mem c.ckey env -> + Tcomp_ptr (intern_string (Cil.compFullName c)) + | TPtr (t, _) -> Tpointer (convertTypGen env t) + | TArray (t, eOpt, _) -> + begin match eOpt with + | None -> + warning "array type of unspecified size"; + Tarray (convertTypGen env t, coqint_of_camlint 0l) + | Some e -> + match Cil.constFold true e with + | Const (CInt64 (i64, _, _)) -> + Tarray (convertTypGen env t, + coqint_of_camlint (Int64.to_int32 i64)) + | _ -> unsupported "size of array type not an integer constant" + end + | TFun (t, argListOpt, vArg, _) -> + if vArg then unsupported "variadic function type"; + let argList = + match argListOpt with + | None -> unsupported "un-prototyped function type" + | Some l -> l + in + let t' = convertTypGen env t in + begin match t' with + | Tstruct _ | Tunion _ -> + unsupported "return type is a struct or union" + | _ -> Tfunction (processParamsT (convertTypGen env) argList, t') + end + | TNamed (tinfo, _) -> convertTypGen env tinfo.ttype + | TComp (c, _) -> + let rec convertFieldList = function + | [] -> Fnil + | {fname=str; ftype=t} :: rem -> + let idf = intern_string str in + let t' = convertTypGen (c.ckey :: env) t in + Fcons(idf, t', convertFieldList rem) in + let fList = convertFieldList c.cfields in + let id = intern_string (Cil.compFullName c) in + if c.cstruct then Tstruct(id, fList) else Tunion(id, fList) + | TEnum _ -> constInt32 (* enum constants are integers *) + | TBuiltin_va_list _ -> unsupported "GCC `builtin va_list' type" + +and convertTyp ty = convertTypGen [] ty + +(** Convert a [Cil.varinfo] into a pair [(ident * coq_type)] *) +let convertVarinfo v = + updateLoc(v.vdecl); + let id = intern_string v.vname in + Datatypes.Coq_pair (id, convertTyp v.vtype) + + +(** Convert a [Cil.varinfo] into a pair [(ident * coq_type)] + (fail if the variable is of type struct or union) *) +let convertVarinfoParam v = + updateLoc(v.vdecl); + let id = intern_string v.vname in + let t' = convertTyp v.vtype in + match t' with + | Tstruct _ | Tunion _ -> + unsupported "function parameter of struct or union type" + | _ -> Datatypes.Coq_pair (id, t') + + +(** Convert a [Cil.exp] which has a function type into a [CabsCoq.expr] + (used only to translate function calls) *) +let convertExpFuncall e eList = + match typeOf e with + | TFun (res, argListOpt, vArg, _) -> + begin match argListOpt, vArg with + | Some argList, false -> + (* Prototyped, non-variadic function *) + if List.length argList <> List.length eList then + internal_error "convertExpFuncall: wrong number of arguments"; + (convertExp e, processParamsE eList) + | _, _ -> + (* Variadic or unprototyped function: generate a call to + a stub function with the appropriate number and types + of arguments. Works only if the function expression e + is a global variable. *) + let params = processParamsE eList in + let fun_name = + match e with + | Lval(Var v, NoOffset) -> + warning "working around a call to a variadic function"; + v.vname + | _ -> + unsupported "call to variadic function" in + let rec typeOfExprList = function + | [] -> Tnil + | Expr (_, ty) :: rem -> Tcons (ty, typeOfExprList rem) in + let targs = typeOfExprList params in + let tres = convertTyp res in + let (stub_fun_name, stub_fun_typ) = + register_stub_function fun_name tres targs in + (Expr(Evar(intern_string stub_fun_name), stub_fun_typ), + params) + end + | _ -> internal_error "convertExpFuncall: not a function" + +(** Auxiliaries for function calls *) + +let makeFuncall1 tyfun (Expr(_, tlhs) as elhs) efun eargs = + match tyfun with + | TFun (t, _, _, _) -> + let tres = convertTyp t in + if tlhs = tres then + Scall(Datatypes.Some elhs, efun, eargs) + else begin + let tmp = make_temp t in + let elhs' = Expr(Evar tmp, tres) in + Ssequence(Scall(Datatypes.Some elhs', efun, eargs), + Sassign(elhs, Expr(Ecast(tlhs, elhs'), tlhs))) + end + | _ -> internal_error "wrong type for function in call" + +let makeFuncall2 tyfun tylhs elhs efun eargs = + match elhs with + | Expr(Evar _, _) -> + makeFuncall1 tyfun elhs efun eargs + | Expr(_, tlhs) -> + let tmp = make_temp tylhs in + let elhs' = Expr(Evar tmp, tlhs) in + Ssequence(makeFuncall1 tyfun elhs' efun eargs, + Sassign(elhs, elhs')) + + +(** Convert a [Cil.instr list] into a [CabsCoq.statement] *) +let rec processInstrList l = + (* convert an instruction *) + let convertInstr = function + | Set (lv, e, loc) -> + updateLoc(loc); + begin match convertTyp (Cil.typeOf e) with + | Tstruct _ | Tunion _ -> unsupported "struct or union assignment" + | t -> Sassign (convertLval lv, convertExp e) + end + | Call (None, e, eList, loc) -> + updateLoc(loc); + let (efun, params) = convertExpFuncall e eList in + Scall(Datatypes.None, efun, params) + | Call (Some lv, e, eList, loc) -> + updateLoc(loc); + let (efun, params) = convertExpFuncall e eList in + makeFuncall2 (Cil.typeOf e) (Cil.typeOfLval lv) (convertLval lv) efun params + | Asm (_, _, _, _, _, loc) -> + updateLoc(loc); + unsupported "inline assembly" + in + (* convert a list of instructions *) + match l with + | [] -> Sskip + | [s] -> convertInstr s + | s :: l -> + let cs = convertInstr s in + let cl = processInstrList l in + Ssequence (cs, cl) + + +(** Convert a [Cil.stmt list] into a [CabsCoq.statement] *) +let rec processStmtList = function + | [] -> Sskip + | [s] -> convertStmt s + | s :: l -> + let cs = convertStmt s in + let cl = processStmtList l in + Ssequence (cs, cl) + + +(** Return the list of the constant expressions in a label list + (return [None] if this is the default case) + (fail if the constant expression is not of type integer) *) +and getCaseList lblList = + match lblList with + | [] -> Some [] + | Label (_, loc, _) :: l -> updateLoc(loc); getCaseList l + | Default loc :: _ -> updateLoc(loc); None + | Case (e, loc) :: l -> + updateLoc(loc); + begin match convertExp e with + | Expr (Econst_int n, _) -> + begin match getCaseList l with + | None -> None + | Some cl -> Some (n :: cl) + end + | _ -> internal_error "getCaseList: case label does not \ + reduce to an integer constant" + end + + +(** Convert a list of integers into a [CabsCoq.lblStatementList] *) +and processCaseList cl s lrem = + match cl with + | [] -> internal_error "processCaseList: syntax error in switch statement" + | [n] -> LScase (n, s, lrem) + | n1 :: l -> LScase (n1, Sskip, processCaseList l s lrem) + + +(** Convert a [Cil.stmt list] which is the body of a Switch structure + into a [CabsCoq.lblStatementList] + (Pre-condition: all the Case labels are supposed to be at the same level, + ie. no nested structures) *) +and processLblStmtList switchBody = function + | [] -> LSdefault Sskip + | [ls] -> + let s = processStmtList (keepFrom ls switchBody) in + begin match getCaseList ls.labels with + | None -> LSdefault s + | Some cl -> processCaseList cl s (LSdefault Sskip) + end + | ls :: ((ls' :: _) as l) -> + if ls.labels = ls'.labels then processLblStmtList switchBody l + else + begin match getCaseList ls.labels with + | None -> unsupported "default case is not at the end of this `switch' statement" + | Some cl -> + let s = processStmtList (keepBetween ls ls' switchBody) in + let lrem = processLblStmtList switchBody l in + processCaseList cl s lrem + end + + +(** Convert a [Cil.stmt] into a [CabsCoq.statement] *) +and convertStmt s = + match s.skind with + | Instr iList -> processInstrList iList + | Return (eOpt, loc) -> + updateLoc(loc); + let eOpt' = match eOpt with + | None -> Datatypes.None + | Some e -> Datatypes.Some (convertExp e) + in + Sreturn eOpt' + | Goto (_, loc) -> + updateLoc(loc); + unsupported "`goto' statement" + | Break loc -> + updateLoc(loc); + Sbreak + | Continue loc -> + updateLoc(loc); + Scontinue + | If (e, b1, b2, loc) -> + updateLoc(loc); + let e1 = processStmtList b1.bstmts in + let e2 = processStmtList b2.bstmts in + Sifthenelse (convertExp e, e1, e2) + | Switch (e, b, l, loc) -> + updateLoc(loc); + Sswitch (convertExp e, processLblStmtList b.bstmts l) + | While (e, b, loc) -> + updateLoc(loc); + Swhile (convertExp e, processStmtList b.bstmts) + | DoWhile (e, b, loc) -> + updateLoc(loc); + Sdowhile (convertExp e, processStmtList b.bstmts) + | For (bInit, e, bIter, b, loc) -> + updateLoc(loc); + let sInit = processStmtList bInit.bstmts in + let e' = convertExp e in + let sIter = processStmtList bIter.bstmts in + Sfor (sInit, e', sIter, processStmtList b.bstmts) + | Block b -> processStmtList b.bstmts + | TryFinally (_, _, loc) -> + updateLoc(loc); + unsupported "`try'...`finally' statement" + | TryExcept (_, _, _, loc) -> + updateLoc(loc); + unsupported "`try'...`except' statement" + +(** Convert a [Cil.GFun] into a pair [(ident * coq_fundecl)] *) +let convertGFun fdec = + current_function := Some fdec; + let v = fdec.svar in + let ret = match v.vtype with + | TFun (t, _, vArg, _) -> + if vArg then unsupported "variadic function"; + begin match convertTyp t with + | Tstruct _ | Tunion _ -> + unsupported "return value of struct or union type" + | t' -> t' + end + | _ -> internal_error "convertGFun: incorrect function type" + in + let s = processStmtList fdec.sbody.bstmts in (* function body -- do it first because of generated temps *) + let args = List.map convertVarinfoParam fdec.sformals in (* parameters*) + let varList = List.map convertVarinfo fdec.slocals in (* local vars *) + if v.vname = "main" then begin + match ret with + | Tint(_, _) -> () + | _ -> updateLoc v.vdecl; + unsupported "the return type of main() must be an integer type" + end; + current_function := None; + Datatypes.Coq_pair + (intern_string v.vname, + Internal { fn_return=ret; fn_params=args; fn_vars=varList; fn_body=s }) + +(** Auxiliary for [convertInit] *) + +let rec initDataLen accu = function + | [] -> accu + | i1 :: il -> + let sz = match i1 with + | Init_int8 _ -> 1l + | Init_int16 _ -> 2l + | Init_int32 _ -> 4l + | Init_float32 _ -> 4l + | Init_float64 _ -> 8l + | Init_space n -> camlint_of_z n + | Init_pointer _ -> 4l in + initDataLen (Int32.add sz accu) il + +(** Convert a [Cil.init] into a list of [AST.init_data] prepended to + the given list [k]. Result is in reverse order. *) + +(* Cil.constFold does not reduce floating-point operations. + We treat here those that appear naturally in initializers. *) + +type init_constant = + | ICint of int64 * intsize + | ICfloat of float * floatsize + | ICstring of string + | ICnone + +let rec extract_constant e = + match e with + | Const (CInt64(n, ikind, _)) -> + ICint(n, fst (convertIkind ikind)) + | Const (CReal(n, fkind, _)) -> + ICfloat(n, convertFkind fkind) + | Const (CStr s) -> + ICstring s + | CastE (ty, e1) -> + begin match extract_constant e1, convertTyp ty with + | ICfloat(n, _), Tfloat sz -> + ICfloat(n, sz) + | ICint(n, _), Tfloat sz -> + ICfloat(Int64.to_float n, sz) + | ICint(n, sz), Tpointer _ -> + ICint(n, sz) + | ICstring s, (Tint _ | Tpointer _) -> + ICstring s + | _, _ -> + ICnone + end + | UnOp (Neg, e1, _) -> + begin match extract_constant e1 with + | ICfloat(n, sz) -> ICfloat(-. n, sz) + | _ -> ICnone + end + | _ -> ICnone + +let init_data_of_string s = + let id = ref [] in + let enter_char c = + let n = coqint_of_camlint(Int32.of_int(Char.code c)) in + id := Init_int8 n :: !id in + enter_char '\000'; + for i = String.length s - 1 downto 0 do enter_char s.[i] done; + !id + +let convertInit init = + let k = ref [] + and pos = ref 0 in + let emit size datum = + k := datum :: !k; + pos := !pos + size in + let emit_space size = + emit size (Init_space (z_of_camlint (Int32.of_int size))) in + let check_align size = + assert (!pos land (size - 1) = 0) in + let align size = + let n = !pos land (size - 1) in + if n > 0 then emit_space (size - n) in + + let rec cvtInit init = + match init with + | SingleInit e -> + begin match extract_constant(Cil.constFold true e) with + | ICint(n, I8) -> + let n' = coqint_of_camlint (Int64.to_int32 n) in + emit 1 (Init_int8 n') + | ICint(n, I16) -> + check_align 2; + let n' = coqint_of_camlint (Int64.to_int32 n) in + emit 2 (Init_int16 n') + | ICint(n, I32) -> + check_align 4; + let n' = coqint_of_camlint (Int64.to_int32 n) in + emit 4 (Init_int32 n') + | ICfloat(n, F32) -> + check_align 4; + emit 4 (Init_float32 n) + | ICfloat(n, F64) -> + check_align 8; + emit 8 (Init_float64 n) + | ICstring s -> + check_align 4; + emit 4 (Init_pointer(init_data_of_string s)) + | ICnone -> + unsupported "this kind of expression is not supported in global initializers" + end + | CompoundInit(ty, data) -> + let ty' = convertTyp ty in + let sz = Int32.to_int (camlint_of_z (Csyntax.sizeof ty')) in + let pos0 = !pos in + Cil.foldLeftCompoundAll + ~doinit: cvtCompoundInit + ~ct: ty + ~initl: data + ~acc: (); + let pos1 = !pos in + assert (pos1 <= pos0 + sz); + if pos1 < pos0 + sz then emit_space (pos0 + sz - pos1) + + and cvtCompoundInit ofs init ty () = + let ty' = convertTyp ty in + let al = Int32.to_int (camlint_of_z (Csyntax.alignof ty')) in + align al; + cvtInit init + + in cvtInit init; CList.rev !k + +(** Convert a [Cil.initinfo] into a list of [AST.init_data] *) + +let convertInitInfo ty info = + match info.init with + | None -> + [ Init_space(Csyntax.sizeof (convertTyp ty)) ] + | Some init -> + convertInit init + +(** Convert a [Cil.GVar] into a global variable definition *) + +let convertGVar v i = + updateLoc(v.vdecl); + let id = intern_string v.vname in + Datatypes.Coq_pair (Datatypes.Coq_pair(id, convertInitInfo v.vtype i), + convertTyp v.vtype) + + +(** Convert a [Cil.GVarDecl] into a global variable declaration *) + +let convertExtVar v = + updateLoc(v.vdecl); + let id = intern_string v.vname in + Datatypes.Coq_pair (Datatypes.Coq_pair(id, []), + convertTyp v.vtype) + +(** Convert a [Cil.GVarDecl] into an external function declaration *) + +let convertExtFun v = + updateLoc(v.vdecl); + match convertTyp v.vtype with + | Tfunction(args, res) -> + let id = intern_string v.vname in + Datatypes.Coq_pair (id, External(id, args, res)) + | _ -> + assert false + +(** Convert a [Cil.global list] into a pair whose first component, + of type [(ident * coq_function) coqlist], represents the definitions of the + functions and the second component, of type [(ident * coq_type) coqlist], + the definitions of the global variables of the program *) +let rec processGlobals = function + | [] -> ([], []) + | g :: l -> + match g with + | GType _ -> processGlobals l (* typedefs are unrolled... *) + | GCompTag _ -> processGlobals l + | GCompTagDecl _ -> processGlobals l + | GEnumTag _ -> processGlobals l (* enum constants are folded... *) + | GEnumTagDecl _ -> processGlobals l + | GVarDecl (v, loc) -> + updateLoc(loc); + (* Functions become external declarations, + variadic and unprototyped functions are skipped, + variables become uninitialized variables *) + begin match Cil.unrollType v.vtype with + | TFun (tres, Some targs, false, _) -> + let fn = convertExtFun v in + let (fList, vList) = processGlobals l in + (fn :: fList, vList) + | TFun (tres, _, _, _) -> + processGlobals l + | _ -> + let var = convertExtVar v in + let (fList, vList) = processGlobals l in + (fList, var :: vList) + end + | GVar (v, init, loc) -> + updateLoc(loc); + let var = convertGVar v init in + let (fList, vList) = processGlobals l in + (fList, var :: vList) + | GFun (fdec, loc) -> + updateLoc(loc); + let fn = convertGFun fdec in + let (fList, vList) = processGlobals l in + (fn :: fList, vList) + | GAsm (_, loc) -> + updateLoc(loc); + unsupported "inline assembly" + | GPragma (_, loc) -> + updateLoc(loc); + warning "#pragma directive ignored"; + processGlobals l + | GText _ -> processGlobals l (* comments are ignored *) + +(** Eliminate forward declarations of globals that are defined later *) + +let cleanupGlobals globs = + let defined = + List.fold_right + (fun g def -> + match g with GVar (v, init, loc) -> v.vname :: def + | GFun (fdec, loc) -> fdec.svar.vname :: def + | _ -> def) + globs [] in + List.filter + (function GVarDecl(v, loc) -> not(List.mem v.vname defined) + | g -> true) + globs + +(** Convert a [Cil.file] into a [CabsCoq.program] *) +let convertFile f = + currentGlobalPrefix := + Filename.chop_extension (Filename.basename f.fileName); + stringNum := 0; + Hashtbl.clear stringTable; + Hashtbl.clear stub_function_table; + let (funList, defList) = processGlobals (cleanupGlobals f.globals) in + let funList' = declare_stub_functions funList in + let funList'' = match f.globinit with + | Some fdec -> convertGFun fdec :: funList' + | None -> funList' in + let defList' = globals_for_strings defList in + { AST.prog_funct = funList''; + AST.prog_vars = defList'; + AST.prog_main = intern_string "main" } + + +(*-----------------------------------------------------------------------*) +end + diff --git a/cfrontend/PrintCsyntax.ml b/cfrontend/PrintCsyntax.ml new file mode 100644 index 0000000..bb25339 --- /dev/null +++ b/cfrontend/PrintCsyntax.ml @@ -0,0 +1,501 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU General Public License as published by *) +(* the Free Software Foundation, either version 2 of the License, or *) +(* (at your option) any later version. This file is also distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Pretty-printer for Csyntax *) + +open Format +open Camlcoq +open CList +open Datatypes +open AST +open Csyntax + +let name_unop = function + | Onotbool -> "!" + | Onotint -> "~" + | Oneg -> "-" + + +let name_binop = function + | Oadd -> "+" + | Osub -> "-" + | Omul -> "*" + | Odiv -> "/" + | Omod -> "%" + | Oand -> "&" + | Oor -> "|" + | Oxor -> "^" + | Oshl -> "<<" + | Oshr -> ">>" + | Oeq -> "==" + | One -> "!=" + | Olt -> "<" + | Ogt -> ">" + | Ole -> "<=" + | Oge -> ">=" + +let name_inttype sz sg = + match sz, sg with + | I8, Signed -> "signed char" + | I8, Unsigned -> "unsigned char" + | I16, Signed -> "short" + | I16, Unsigned -> "unsigned short" + | I32, Signed -> "int" + | I32, Unsigned -> "unsigned int" + +let name_floattype sz = + match sz with + | F32 -> "float" + | F64 -> "double" + +(* Collecting the names and fields of structs and unions *) + +module StructUnionSet = Set.Make(struct + type t = string * fieldlist + let compare (n1, _ : t) (n2, _ : t) = compare n1 n2 +end) + +let struct_unions = ref StructUnionSet.empty + +let register_struct_union id fld = + struct_unions := StructUnionSet.add (extern_atom id, fld) !struct_unions + +(* Declarator (identifier + type) *) + +let name_optid id = + if id = "" then "" else " " ^ id + +let parenthesize_if_pointer id = + if String.length id > 0 && id.[0] = '*' then "(" ^ id ^ ")" else id + +let rec name_cdecl id ty = + match ty with + | Tvoid -> + "void" ^ name_optid id + | Tint(sz, sg) -> + name_inttype sz sg ^ name_optid id + | Tfloat sz -> + name_floattype sz ^ name_optid id + | Tpointer t -> + name_cdecl ("*" ^ id) t + | Tarray(t, n) -> + name_cdecl + (sprintf "%s[%ld]" (parenthesize_if_pointer id) (camlint_of_coqint n)) + t + | Tfunction(args, res) -> + let b = Buffer.create 20 in + if id = "" + then Buffer.add_string b "(*)" + else Buffer.add_string b (parenthesize_if_pointer id); + Buffer.add_char b '('; + begin match args with + | Tnil -> + Buffer.add_string b "void" + | _ -> + let rec add_args first = function + | Tnil -> () + | Tcons(t1, tl) -> + if not first then Buffer.add_string b ", "; + Buffer.add_string b (name_cdecl "" t1); + add_args false tl in + add_args true args + end; + Buffer.add_char b ')'; + name_cdecl (Buffer.contents b) res + | Tstruct(name, fld) -> + extern_atom name ^ name_optid id + | Tunion(name, fld) -> + extern_atom name ^ name_optid id + | Tcomp_ptr name -> + extern_atom name ^ " *" ^ id + +(* Type *) + +let name_type ty = name_cdecl "" ty + +(* Expressions *) + +let parenthesis_level (Expr (e, ty)) = + match e with + | Econst_int _ -> 0 + | Econst_float _ -> 0 + | Evar _ -> 0 + | Eunop(_, _) -> 30 + | Ederef _ -> 20 + | Eaddrof _ -> 30 + | Ebinop(op, _, _) -> + begin match op with + | Oand | Oor | Oxor -> 75 + | Oeq | One | Olt | Ogt | Ole | Oge -> 70 + | Oadd | Osub | Oshl | Oshr -> 60 + | Omul | Odiv | Omod -> 40 + end + | Ecast _ -> 30 + | Econdition(_, _, _) -> 80 + | Eandbool(_, _) -> 80 + | Eorbool(_, _) -> 80 + | Esizeof _ -> 20 + | Efield _ -> 20 + +let rec print_expr p (Expr (eb, ty) as e) = + let level = parenthesis_level e in + match eb with + | Econst_int n -> + fprintf p "%ld" (camlint_of_coqint n) + | Econst_float f -> + fprintf p "%F" f + | Evar id -> + fprintf p "%s" (extern_atom id) + | Eunop(op, e1) -> + fprintf p "%s%a" (name_unop op) print_expr_prec (level, e1) + | Ederef (Expr (Ebinop(Oadd, e1, e2), _)) -> + fprintf p "@[%a@,[%a]@]" + print_expr_prec (level, e1) + print_expr_prec (level, e2) + | Ederef (Expr (Efield(e1, id), _)) -> + fprintf p "%a->%s" print_expr_prec (level, e1) (extern_atom id) + | Ederef e -> + fprintf p "*%a" print_expr_prec (level, e) + | Eaddrof e -> + fprintf p "&%a" print_expr_prec (level, e) + | Ebinop(op, e1, e2) -> + fprintf p "@[%a@ %s %a@]" + print_expr_prec (level, e1) + (name_binop op) + print_expr_prec (level, e2) + | Ecast(ty, e1) -> + fprintf p "@[(%s)@,%a@]" + (name_type ty) + print_expr_prec (level, e1) + | Econdition(e1, e2, e3) -> + fprintf p "@[%a@ ? %a@ : %a@]" + print_expr_prec (level, e1) + print_expr_prec (level, e2) + print_expr_prec (level, e3) + | Eandbool(e1, e2) -> + fprintf p "@[%a@ && %a@]" + print_expr_prec (level, e1) + print_expr_prec (level, e2) + | Eorbool(e1, e2) -> + fprintf p "@[%a@ || %a@]" + print_expr_prec (level, e1) + print_expr_prec (level, e2) + | Esizeof ty -> + fprintf p "sizeof(%s)" (name_type ty) + | Efield(e1, id) -> + fprintf p "%a.%s" print_expr_prec (level, e1) (extern_atom id) + +and print_expr_prec p (context_prec, e) = + let this_prec = parenthesis_level e in + if this_prec >= context_prec + then fprintf p "(%a)" print_expr e + else print_expr p e + +let rec print_expr_list p (first, el) = + match el with + | [] -> () + | e1 :: et -> + if not first then fprintf p ",@ "; + print_expr p e1; + print_expr_list p (false, et) + +let rec print_stmt p s = + match s with + | Sskip -> + fprintf p "/*skip*/;" + | Sassign(e1, e2) -> + fprintf p "@[%a =@ %a;@]" print_expr e1 print_expr e2 + | Scall(None, e1, el) -> + fprintf p "@[%a@,(@[%a@]);@]" + print_expr e1 + print_expr_list (true, el) + | Scall(Some lhs, e1, el) -> + fprintf p "@[%a =@ %a@,(@[%a@]);@]" + print_expr lhs + print_expr e1 + print_expr_list (true, el) + | Ssequence(s1, s2) -> + fprintf p "%a@ %a" print_stmt s1 print_stmt s2 + | Sifthenelse(e, s1, Sskip) -> + fprintf p "@[if (%a) {@ %a@;<0 -2>}@]" + print_expr e + print_stmt s1 + | Sifthenelse(e, s1, s2) -> + fprintf p "@[if (%a) {@ %a@;<0 -2>} else {@ %a@;<0 -2>}@]" + print_expr e + print_stmt s1 + print_stmt s2 + | Swhile(e, s) -> + fprintf p "@[while (%a) {@ %a@;<0 -2>}@]" + print_expr e + print_stmt s + | Sdowhile(e, s) -> + fprintf p "@[do {@ %a@;<0 -2>} while(%a);@]" + print_stmt s + print_expr e + | Sfor(s_init, e, s_iter, s_body) -> + fprintf p "@[for (@[%a;@ %a;@ %a) {@]@ %a@;<0 -2>}@]" + print_stmt_for s_init + print_expr e + print_stmt_for s_iter + print_stmt s_body + | Sbreak -> + fprintf p "break;" + | Scontinue -> + fprintf p "continue;" + | Sswitch(e, cases) -> + fprintf p "@[switch (%a) {@ %a@;<0 -2>}@]" + print_expr e + print_cases cases + | Sreturn None -> + fprintf p "return;" + | Sreturn (Some e) -> + fprintf p "return %a;" print_expr e + +and print_cases p cases = + match cases with + | LSdefault Sskip -> + () + | LSdefault s -> + fprintf p "@[default:@ %a@]" print_stmt s + | LScase(lbl, Sskip, rem) -> + fprintf p "case %ld:@ %a" + (camlint_of_coqint lbl) + print_cases rem + | LScase(lbl, s, rem) -> + fprintf p "@[case %ld:@ %a@]@ %a" + (camlint_of_coqint lbl) + print_stmt s + print_cases rem + +and print_stmt_for p s = + match s with + | Sskip -> + fprintf p "/*nothing*/" + | Sassign(e1, e2) -> + fprintf p "%a = %a" print_expr e1 print_expr e2 + | Ssequence(s1, s2) -> + fprintf p "%a, %a" print_stmt_for s1 print_stmt_for s2 + | Scall(None, e1, el) -> + fprintf p "@[%a@,(@[%a@])@]" + print_expr e1 + print_expr_list (true, el) + | Scall(Some lhs, e1, el) -> + fprintf p "@[%a =@ %a@,(@[%a@])@]" + print_expr lhs + print_expr e1 + print_expr_list (true, el) + | _ -> + fprintf p "({ %a })" print_stmt s + +let name_function_parameters fun_name params = + let b = Buffer.create 20 in + Buffer.add_string b fun_name; + Buffer.add_char b '('; + begin match params with + | [] -> + Buffer.add_string b "void" + | _ -> + let rec add_params first = function + | [] -> () + | Coq_pair(id, ty) :: rem -> + if not first then Buffer.add_string b ", "; + Buffer.add_string b (name_cdecl (extern_atom id) ty); + add_params false rem in + add_params true params + end; + Buffer.add_char b ')'; + Buffer.contents b + +let print_function p id f = + fprintf p "%s@ " + (name_cdecl (name_function_parameters (extern_atom id) + f.fn_params) + f.fn_return); + fprintf p "@[{@ "; + List.iter + (fun (Coq_pair(id, ty)) -> + fprintf p "%s;@ " (name_cdecl (extern_atom id) ty)) + f.fn_vars; + print_stmt p f.fn_body; + fprintf p "@;<0 -2>}@]@ @ " + +let print_fundef p (Coq_pair(id, fd)) = + match fd with + | External(_, args, res) -> + fprintf p "extern %s;@ @ " + (name_cdecl (extern_atom id) (Tfunction(args, res))) + | Internal f -> + print_function p id f + +let string_of_init id = + try + let s = String.create (List.length id) in + let i = ref 0 in + List.iter + (function + | Init_int8 n -> + s.[!i] <- Char.chr(Int32.to_int(camlint_of_coqint n)); + incr i + | _ -> raise Not_found) + id; + Some s + with Not_found -> None + +let print_escaped_string p s = + fprintf p "\""; + for i = 0 to String.length s - 1 do + match s.[i] with + | ('\"' | '\\') as c -> fprintf p "\\%c" c + | '\n' -> fprintf p "\\n" + | '\t' -> fprintf p "\\t" + | '\r' -> fprintf p "\\r" + | c -> if c >= ' ' && c <= '~' + then fprintf p "%c" c + else fprintf p "\\x%02x" (Char.code c) + done; + fprintf p "\"" + +let print_init p = function + | Init_int8 n -> fprintf p "%ld,@ " (camlint_of_coqint n) + | Init_int16 n -> fprintf p "%ld,@ " (camlint_of_coqint n) + | Init_int32 n -> fprintf p "%ld,@ " (camlint_of_coqint n) + | Init_float32 n -> fprintf p "%F,@ " n + | Init_float64 n -> fprintf p "%F,@ " n + | Init_space n -> fprintf p "/* skip %ld, */@ " (camlint_of_coqint n) + | Init_pointer id -> + match string_of_init id with + | None -> fprintf p "/* pointer to other init*/,@ " + | Some s -> fprintf p "%a,@ " print_escaped_string s + +let print_globvar p (Coq_pair(Coq_pair(id, init), ty)) = + match init with + | [] -> + fprintf p "extern %s;@ @ " + (name_cdecl (extern_atom id) ty) + | [Init_space _] -> + fprintf p "%s;@ @ " + (name_cdecl (extern_atom id) ty) + | _ -> + fprintf p "@[%s = {@ " + (name_cdecl (extern_atom id) ty); + List.iter (print_init p) init; + fprintf p "};@]@ @ " + +(* Collect struct and union types *) + +let rec collect_type = function + | Tvoid -> () + | Tint(sz, sg) -> () + | Tfloat sz -> () + | Tpointer t -> collect_type t + | Tarray(t, n) -> collect_type t + | Tfunction(args, res) -> collect_type_list args; collect_type res + | Tstruct(id, fld) -> register_struct_union id fld; collect_fields fld + | Tunion(id, fld) -> register_struct_union id fld; collect_fields fld + | Tcomp_ptr _ -> () + +and collect_type_list = function + | Tnil -> () + | Tcons(hd, tl) -> collect_type hd; collect_type_list tl + +and collect_fields = function + | Fnil -> () + | Fcons(id, hd, tl) -> collect_type hd; collect_fields tl + +let rec collect_expr (Expr(ed, ty)) = + match ed with + | Econst_int n -> () + | Econst_float f -> () + | Evar id -> () + | Eunop(op, e1) -> collect_expr e1 + | Ederef e -> collect_expr e + | Eaddrof e -> collect_expr e + | Ebinop(op, e1, e2) -> collect_expr e1; collect_expr e2 + | Ecast(ty, e1) -> collect_type ty; collect_expr e1 + | Econdition(e1, e2, e3) -> collect_expr e1; collect_expr e2; collect_expr e3 + | Eandbool(e1, e2) -> collect_expr e1; collect_expr e2 + | Eorbool(e1, e2) -> collect_expr e1; collect_expr e2 + | Esizeof ty -> collect_type ty + | Efield(e1, id) -> collect_expr e1 + +let rec collect_expr_list = function + | [] -> () + | hd :: tl -> collect_expr hd; collect_expr_list tl + +let rec collect_stmt = function + | Sskip -> () + | Sassign(e1, e2) -> collect_expr e1; collect_expr e2 + | Scall(None, e1, el) -> collect_expr e1; collect_expr_list el + | Scall(Some lhs, e1, el) -> collect_expr lhs; collect_expr e1; collect_expr_list el + | Ssequence(s1, s2) -> collect_stmt s1; collect_stmt s2 + | Sifthenelse(e, s1, s2) -> collect_expr e; collect_stmt s1; collect_stmt s2 + | Swhile(e, s) -> collect_expr e; collect_stmt s + | Sdowhile(e, s) -> collect_stmt s; collect_expr e + | Sfor(s_init, e, s_iter, s_body) -> + collect_stmt s_init; collect_expr e; + collect_stmt s_iter; collect_stmt s_body + | Sbreak -> () + | Scontinue -> () + | Sswitch(e, cases) -> collect_expr e; collect_cases cases + | Sreturn None -> () + | Sreturn (Some e) -> collect_expr e + +and collect_cases = function + | LSdefault s -> collect_stmt s + | LScase(lbl, s, rem) -> collect_stmt s; collect_cases rem + +let collect_function f = + collect_type f.fn_return; + List.iter (fun (Coq_pair(id, ty)) -> collect_type ty) f.fn_params; + List.iter (fun (Coq_pair(id, ty)) -> collect_type ty) f.fn_vars; + collect_stmt f.fn_body + +let collect_fundef (Coq_pair(id, fd)) = + match fd with + | External(_, args, res) -> collect_type_list args; collect_type res + | Internal f -> collect_function f + +let collect_globvar (Coq_pair(Coq_pair(id, init), ty)) = + collect_type ty + +let collect_program p = + List.iter collect_globvar p.prog_vars; + List.iter collect_fundef p.prog_funct + +let declare_struct_or_union p (name, fld) = + fprintf p "%s;@ @ " name + +let print_struct_or_union p (name, fld) = + fprintf p "@[%s {" name; + let rec print_fields = function + | Fnil -> () + | Fcons(id, ty, rem) -> + fprintf p "@ %s;" (name_cdecl (extern_atom id) ty); + print_fields rem in + print_fields fld; + fprintf p "@;<0 -2>};@]@ " + +let print_program p prog = + struct_unions := StructUnionSet.empty; + collect_program prog; + fprintf p "@["; + StructUnionSet.iter (declare_struct_or_union p) !struct_unions; + StructUnionSet.iter (print_struct_or_union p) !struct_unions; + List.iter (print_globvar p) prog.prog_vars; + List.iter (print_fundef p) prog.prog_funct; + fprintf p "@]@." + + diff --git a/common/Complements.v b/common/Complements.v deleted file mode 100644 index 6df488f..0000000 --- a/common/Complements.v +++ /dev/null @@ -1,651 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** Corollaries of the main semantic preservation theorem. *) - -Require Import Classical. -Require Import Coqlib. -Require Import AST. -Require Import Integers. -Require Import Values. -Require Import Events. -Require Import Globalenvs. -Require Import Smallstep. -Require Import Csyntax. -Require Import Csem. -Require Import PPC. -Require Import Main. -Require Import Errors. - -(** * Determinism of PPC semantics *) - -(** In this section, we show that the semantics for the PPC language - are deterministic, in a sense to be made precise later. - There are two sources of apparent non-determinism: -- The semantics leaves unspecified the results of calls to external - functions. Different results to e.g. a "read" operation can of - course lead to different behaviors for the program. - We address this issue by modeling a notion of deterministic - external world that uniquely determines the results of external calls. -- For diverging executions, the trace of I/O events is not uniquely - determined: it can contain events that will never be performed - because the program diverges earlier. We address this issue - by showing the existence of a minimal trace for diverging executions. - -*) - -(** ** Deterministic worlds *) - -(** An external world is a function that, given the name of an - external call and its arguments, returns either [None], meaning - that this external call gets stuck, or [Some(r,w)], meaning - that this external call succeeds, has result [r], and changes - the world to [w]. *) - -Inductive world: Set := - World: (ident -> list eventval -> option (eventval * world)) -> world. - -Definition nextworld (w: world) (evname: ident) (evargs: list eventval) : - option (eventval * world) := - match w with World f => f evname evargs end. - -(** A trace is possible in a given world if all events correspond - to non-stuck external calls according to the given world. - Two predicates are defined, for finite and infinite traces respectively: -- [possible_trace w t w'], where [w] is the initial state of the - world, [t] the finite trace of interest, and [w'] the state of the - world after performing trace [t]. -- [possible_traceinf w T], where [w] is the initial state of the - world and [T] the possibly infinite trace of interest. -*) - -Inductive possible_trace: world -> trace -> world -> Prop := - | possible_trace_nil: forall w, - possible_trace w E0 w - | possible_trace_cons: forall w0 evname evargs evres w1 t w2, - nextworld w0 evname evargs = Some (evres, w1) -> - possible_trace w1 t w2 -> - possible_trace w0 (mkevent evname evargs evres :: t) w2. - -Lemma possible_trace_app: - forall t2 w2 w0 t1 w1, - possible_trace w0 t1 w1 -> possible_trace w1 t2 w2 -> - possible_trace w0 (t1 ** t2) w2. -Proof. - induction 1; simpl; intros. - auto. - econstructor; eauto. -Qed. - -Lemma possible_trace_app_inv: - forall t2 w2 t1 w0, - possible_trace w0 (t1 ** t2) w2 -> - exists w1, possible_trace w0 t1 w1 /\ possible_trace w1 t2 w2. -Proof. - induction t1; simpl; intros. - exists w0; split. constructor. auto. - inv H. exploit IHt1; eauto. intros [w1 [A B]]. - exists w1; split. econstructor; eauto. auto. -Qed. - -CoInductive possible_traceinf: world -> traceinf -> Prop := - | possible_traceinf_nil: forall w0, - possible_traceinf w0 Enilinf - | possible_traceinf_cons: forall w0 evname evargs evres w1 T, - nextworld w0 evname evargs = Some (evres, w1) -> - possible_traceinf w1 T -> - possible_traceinf w0 (Econsinf (mkevent evname evargs evres) T). - -Lemma possible_traceinf_app: - forall t2 w0 t1 w1, - possible_trace w0 t1 w1 -> possible_traceinf w1 t2 -> - possible_traceinf w0 (t1 *** t2). -Proof. - induction 1; simpl; intros. - auto. - econstructor; eauto. -Qed. - -Lemma possible_traceinf_app_inv: - forall t2 t1 w0, - possible_traceinf w0 (t1 *** t2) -> - exists w1, possible_trace w0 t1 w1 /\ possible_traceinf w1 t2. -Proof. - induction t1; simpl; intros. - exists w0; split. constructor. auto. - inv H. exploit IHt1; eauto. intros [w1 [A B]]. - exists w1; split. econstructor; eauto. auto. -Qed. - -Ltac possibleTraceInv := - match goal with - | [H: possible_trace _ (_ ** _) _ |- _] => - let P1 := fresh "P" in - let w := fresh "w" in - let P2 := fresh "P" in - elim (possible_trace_app_inv _ _ _ _ H); clear H; - intros w [P1 P2]; - possibleTraceInv - | [H: possible_traceinf _ (_ *** _) |- _] => - let P1 := fresh "P" in - let w := fresh "w" in - let P2 := fresh "P" in - elim (possible_traceinf_app_inv _ _ _ H); clear H; - intros w [P1 P2]; - possibleTraceInv - | _ => idtac - end. - -(** Determinism properties of [event_match]. *) - -Remark eventval_match_deterministic: - forall ev1 ev2 ty v1 v2, - eventval_match ev1 ty v1 -> eventval_match ev2 ty v2 -> - (ev1 = ev2 <-> v1 = v2). -Proof. - intros. inv H; inv H0; intuition congruence. -Qed. - -Remark eventval_list_match_deterministic: - forall ev1 ty v, eventval_list_match ev1 ty v -> - forall ev2, eventval_list_match ev2 ty v -> ev1 = ev2. -Proof. - induction 1; intros. - inv H. auto. - inv H1. decEq. - rewrite (eventval_match_deterministic _ _ _ _ _ H H6). auto. - eauto. -Qed. - -Lemma event_match_deterministic: - forall w0 t1 w1 t2 w2 ef vargs vres1 vres2, - possible_trace w0 t1 w1 -> - possible_trace w0 t2 w2 -> - event_match ef vargs t1 vres1 -> - event_match ef vargs t2 vres2 -> - vres1 = vres2 /\ t1 = t2 /\ w1 = w2. -Proof. - intros. inv H1. inv H2. - assert (eargs = eargs0). eapply eventval_list_match_deterministic; eauto. subst eargs0. - inv H. inv H12. inv H0. inv H12. - rewrite H11 in H10. inv H10. intuition. - rewrite <- (eventval_match_deterministic _ _ _ _ _ H4 H5). auto. -Qed. - -(** ** Determinism of PPC transitions. *) - -Remark extcall_arguments_deterministic: - forall rs m sg args args', - extcall_arguments rs m sg args -> - extcall_arguments rs m sg args' -> args = args'. -Proof. - assert ( - forall rs m tyl iregl fregl ofs args, - extcall_args rs m tyl iregl fregl ofs args -> - forall args', extcall_args rs m tyl iregl fregl ofs args' -> args = args'). - induction 1; intros. - inv H. auto. - inv H1. decEq; eauto. - inv H1. decEq. congruence. eauto. - inv H1. decEq; eauto. - inv H1. decEq. congruence. eauto. - - unfold extcall_arguments; intros; eauto. -Qed. - -Lemma step_deterministic: - forall ge s0 t1 s1 t2 s2 w0 w1 w2, - step ge s0 t1 s1 -> step ge s0 t2 s2 -> - possible_trace w0 t1 w1 -> possible_trace w0 t2 w2 -> - s1 = s2 /\ t1 = t2 /\ w1 = w2. -Proof. - intros. inv H; inv H0. - assert (c0 = c) by congruence. subst c0. - assert (i0 = i) by congruence. subst i0. - split. congruence. split. auto. inv H1; inv H2; auto. - congruence. - congruence. - assert (ef0 = ef) by congruence. subst ef0. - assert (args0 = args). eapply extcall_arguments_deterministic; eauto. subst args0. - exploit event_match_deterministic. eexact H1. eexact H2. eauto. eauto. - intros [A [B C]]. intuition congruence. -Qed. - -Lemma initial_state_deterministic: - forall p s1 s2, - initial_state p s1 -> initial_state p s2 -> s1 = s2. -Proof. - intros. inv H; inv H0. reflexivity. -Qed. - -Lemma final_state_not_step: - forall ge st r t st', final_state st r -> step ge st t st' -> False. -Proof. - intros. inv H. inv H0. - unfold Vzero in H1. congruence. - unfold Vzero in H1. congruence. -Qed. - -Lemma final_state_deterministic: - forall st r1 r2, final_state st r1 -> final_state st r2 -> r1 = r2. -Proof. - intros. inv H; inv H0. congruence. -Qed. - -(** ** Determinism for terminating executions. *) - -(* -Lemma star_star_inv: - forall ge s t1 s1, star step ge s t1 s1 -> - forall t2 s2 w w1 w2, star step ge s t2 s2 -> - possible_trace w t1 w1 -> possible_trace w t2 w2 -> - exists t, (star step ge s1 t s2 /\ t2 = t1 ** t) - \/ (star step ge s2 t s1 /\ t1 = t2 ** t). -Proof. - induction 1; intros. - exists t2; left; split; auto. - inv H2. exists (t1 ** t2); right; split. econstructor; eauto. auto. - possibleTraceInv. - exploit step_deterministic. eexact H. eexact H5. eauto. eauto. - intros [U [V W]]. subst s5 t3 w3. - exploit IHstar; eauto. intros [t [ [Q R] | [Q R] ]]. - subst t4. exists t; left; split. auto. traceEq. - subst t2. exists t; right; split. auto. traceEq. -Qed. -*) - -Lemma steps_deterministic: - forall ge s0 t1 s1, star step ge s0 t1 s1 -> - forall r1 r2 t2 s2 w0 w1 w2, star step ge s0 t2 s2 -> - final_state s1 r1 -> final_state s2 r2 -> - possible_trace w0 t1 w1 -> possible_trace w0 t2 w2 -> - t1 = t2 /\ r1 = r2. -Proof. - induction 1; intros. - inv H. split. auto. eapply final_state_deterministic; eauto. - byContradiction. eapply final_state_not_step with (st := s); eauto. - inv H2. byContradiction. eapply final_state_not_step with (st := s0); eauto. - possibleTraceInv. - exploit step_deterministic. eexact H. eexact H7. eauto. eauto. - intros [A [B C]]. subst s5 t3 w3. - exploit IHstar. eexact H8. eauto. eauto. eauto. eauto. - intros [A B]. subst t4 r2. - auto. -Qed. - -(** ** Determinism for infinite transition sequences. *) - -Lemma forever_star_inv: - forall ge s t s', star step ge s t s' -> - forall T w w', forever step ge s T -> - possible_trace w t w' -> possible_traceinf w T -> - exists T', - forever step ge s' T' /\ possible_traceinf w' T' /\ T = t *** T'. -Proof. - induction 1; intros. - inv H0. exists T; auto. - subst t. possibleTraceInv. - inv H2. possibleTraceInv. - exploit step_deterministic. - eexact H. eexact H1. eauto. eauto. intros [A [B C]]; subst s4 t1 w1. - exploit IHstar; eauto. intros [T' [A [B C]]]. - exists T'; split. auto. - split. auto. - rewrite C. rewrite Eappinf_assoc; auto. -Qed. - -Lemma star_final_not_forever: - forall ge s1 t s2 r T w1 w2, - star step ge s1 t s2 -> - final_state s2 r -> forever step ge s1 T -> - possible_trace w1 t w2 -> possible_traceinf w1 T -> - False. -Proof. - intros. exploit forever_star_inv; eauto. intros [T' [A [B C]]]. - inv A. eapply final_state_not_step; eauto. -Qed. - -(** ** Minimal traces for divergence. *) - -(** There are two mutually exclusive way in which a program can diverge. - It can diverge in a reactive fashion: it performs infinitely many - external calls, and the internal computations between two external - calls are always finite. Or it can diverge silently: after a finite - number of external calls, it enters an infinite sequence of internal - computations. *) - -Definition reactive (ge: genv) (s: state) (w: world) := - forall t s1 w1, - star step ge s t s1 -> possible_trace w t w1 -> - exists s2, exists t', exists s3, exists w2, - star step ge s1 E0 s2 - /\ step ge s2 t' s3 - /\ possible_trace w1 t' w2 - /\ t' <> E0. - -Definition diverges_silently (ge: genv) (s: state) := - forall s2, star step ge s E0 s2 -> exists s3, step ge s2 E0 s3. - -Definition diverges_eventually (ge: genv) (s: state) (w: world) := - exists t, exists s1, exists w1, - star step ge s t s1 /\ possible_trace w t w1 /\ diverges_silently ge s1. - -(** Using classical logic, we show that any infinite sequence of transitions - that is possible in a deterministic world is of one of the two forms - described above. *) - -Lemma reactive_or_diverges: - forall ge s T w, - forever step ge s T -> possible_traceinf w T -> - reactive ge s w \/ diverges_eventually ge s w. -Proof. - intros. elim (classic (diverges_eventually ge s w)); intro. - right; auto. - left. red; intros. - generalize (not_ex_all_not trace _ H1 t). - intro. clear H1. - generalize (not_ex_all_not state _ H4 s1). - intro. clear H4. - generalize (not_ex_all_not world _ H1 w1). - intro. clear H1. - elim (not_and_or _ _ H4); clear H4; intro. - contradiction. - elim (not_and_or _ _ H1); clear H1; intro. - contradiction. - generalize (not_all_ex_not state _ H1). intros [s2 A]. clear H1. - destruct (imply_to_and _ _ A). clear A. - exploit forever_star_inv. - eapply star_trans. eexact H2. eexact H1. reflexivity. - eauto. rewrite E0_right. eauto. eauto. - intros [T' [A [B C]]]. - inv A. possibleTraceInv. - exists s2; exists t0; exists s3; exists w4. intuition. - subst t0. apply H4. exists s3; auto. -Qed. - -(** Moreover, a program cannot be both reactive and silently diverging. *) - -Lemma reactive_not_diverges: - forall ge s w, - reactive ge s w -> diverges_eventually ge s w -> False. -Proof. - intros. destruct H0 as [t [s1 [w1 [A [B C]]]]]. - destruct (H _ _ _ A B) as [s2 [t' [s3 [w2 [P [Q [R S]]]]]]]. - destruct (C _ P) as [s4 T]. - assert (s3 = s4 /\ t' = E0 /\ w2 = w1). - eapply step_deterministic; eauto. constructor. - intuition congruence. -Qed. - -(** A program that silently diverges can be given any finite or - infinite trace of events. In particular, taking [T' = Enilinf], - it can be given the empty trace of events. *) - -Lemma diverges_forever: - forall ge s1 T w T', - diverges_silently ge s1 -> - forever step ge s1 T -> - possible_traceinf w T -> - forever step ge s1 T'. -Proof. - cofix COINDHYP; intros. inv H0. possibleTraceInv. - assert (exists s3, step ge s1 E0 s3). apply H. constructor. - destruct H0 as [s3 C]. - assert (s2 = s3 /\ t = E0 /\ w0 = w). eapply step_deterministic; eauto. constructor. - destruct H0 as [Q [R S]]. subst s3 t w0. - change T' with (E0 *** T'). econstructor. eassumption. - eapply COINDHYP; eauto. - red; intros. apply H. eapply star_left; eauto. -Qed. - -(** The trace of I/O events generated by a reactive diverging program - is uniquely determined up to bisimilarity. *) - -Lemma reactive_sim: - forall ge s w T1 T2, - reactive ge s w -> - forever step ge s T1 -> - forever step ge s T2 -> - possible_traceinf w T1 -> - possible_traceinf w T2 -> - traceinf_sim T1 T2. -Proof. - cofix COINDHYP; intros. - elim (H E0 s w); try constructor. - intros s2 [t' [s3 [w2 [A [B [C D]]]]]]. - assert (star step ge s t' s3). eapply star_right; eauto. - destruct (forever_star_inv _ _ _ _ H4 _ _ _ H0 C H2) - as [T1' [P [Q R]]]. - destruct (forever_star_inv _ _ _ _ H4 _ _ _ H1 C H3) - as [T2' [S [T U]]]. - destruct t'. unfold E0 in D. congruence. - assert (t' = nil). inversion B. inversion H7. auto. subst t'. - subst T1 T2. simpl. constructor. - apply COINDHYP with ge s3 w2; auto. - red; intros. eapply H. eapply star_trans; eauto. - eapply possible_trace_app; eauto. -Qed. - -(** A trace is minimal for a program if it is a prefix of all possible - traces. *) - -Definition minimal_trace (ge: genv) (s: state) (w: world) (T: traceinf) := - forall T', - forever step ge s T' -> possible_traceinf w T' -> - traceinf_prefix T T'. - -(** For any program that diverges with some possible trace [T1], - the set of possible traces admits a minimal element [T]. - If the program is reactive, this trace is [T1]. - If the program silently diverges, this trace is the finite trace - of events performed prior to silent divergence. *) - -Lemma forever_minimal_trace: - forall ge s T1 w, - forever step ge s T1 -> possible_traceinf w T1 -> - exists T, - forever step ge s T - /\ possible_traceinf w T - /\ minimal_trace ge s w T. -Proof. - intros. - destruct (reactive_or_diverges _ _ _ _ H H0). - (* reactive *) - exists T1; split. auto. split. auto. red; intros. - elim (reactive_or_diverges _ _ _ _ H2 H3); intro. - apply traceinf_sim_prefix. eapply reactive_sim; eauto. - elimtype False. eapply reactive_not_diverges; eauto. - (* diverges *) - elim H1. intros t [s1 [w1 [A [B C]]]]. - exists (t *** Enilinf); split. - exploit forever_star_inv; eauto. intros [T' [P [Q R]]]. - eapply star_forever. eauto. - eapply diverges_forever; eauto. - split. eapply possible_traceinf_app. eauto. constructor. - red; intros. exploit forever_star_inv. eauto. eexact H2. eauto. eauto. - intros [T2 [P [Q R]]]. - subst T'. apply traceinf_prefix_app. constructor. -Qed. - -(** ** Refined semantics for program executions. *) - -(** We now define the following variant [exec_program'] of the - [exec_program] predicate defined in module [Smallstep]. - In the diverging case [Diverges T], the new predicate imposes that the - finite or infinite trace [T] is minimal. *) - -Inductive exec_program' (p: program) (w: world): program_behavior -> Prop := - | program_terminates': forall s t s' w' r, - initial_state p s -> - star step (Genv.globalenv p) s t s' -> - possible_trace w t w' -> - final_state s' r -> - exec_program' p w (Terminates t r) - | program_diverges': forall s T, - initial_state p s -> - forever step (Genv.globalenv p) s T -> - possible_traceinf w T -> - minimal_trace (Genv.globalenv p) s w T -> - exec_program' p w (Diverges T). - -(** We show that any [exec_program] execution corresponds to - an [exec_program'] execution. *) - -Definition possible_behavior (w: world) (b: program_behavior) : Prop := - match b with - | Terminates t r => exists w', possible_trace w t w' - | Diverges T => possible_traceinf w T - end. - -Inductive matching_behaviors: program_behavior -> program_behavior -> Prop := - | matching_behaviors_terminates: forall t r, - matching_behaviors (Terminates t r) (Terminates t r) - | matching_behaviors_diverges: forall T1 T2, - traceinf_prefix T2 T1 -> - matching_behaviors (Diverges T1) (Diverges T2). - -Theorem exec_program_program': - forall p b w, - exec_program p b -> possible_behavior w b -> - exists b', exec_program' p w b' /\ matching_behaviors b b'. -Proof. - intros. inv H; simpl in H0. - (* termination *) - destruct H0 as [w' A]. - exists (Terminates t r). - split. econstructor; eauto. constructor. - (* divergence *) - exploit forever_minimal_trace; eauto. intros [T0 [A [B C]]]. - exists (Diverges T0); split. - econstructor; eauto. - constructor. apply C; auto. -Qed. - -(** Moreover, [exec_program'] is deterministic, in that the behavior - associated with a given program and external world is uniquely - defined up to bisimilarity between infinite traces. *) - -Inductive same_behaviors: program_behavior -> program_behavior -> Prop := - | same_behaviors_terminates: forall t r, - same_behaviors (Terminates t r) (Terminates t r) - | same_behaviors_diverges: forall T1 T2, - traceinf_sim T2 T1 -> - same_behaviors (Diverges T1) (Diverges T2). - -Theorem exec_program'_deterministic: - forall p b1 b2 w, - exec_program' p w b1 -> exec_program' p w b2 -> - same_behaviors b1 b2. -Proof. - intros. inv H; inv H0; - assert (s0 = s) by (eapply initial_state_deterministic; eauto); subst s0. - (* terminates, terminates *) - exploit steps_deterministic. eexact H2. eexact H5. eauto. eauto. eauto. eauto. - intros [A B]. subst. constructor. - (* terminates, diverges *) - byContradiction. eapply star_final_not_forever; eauto. - (* diverges, terminates *) - byContradiction. eapply star_final_not_forever; eauto. - (* diverges, diverges *) - constructor. apply traceinf_prefix_2_sim; auto. -Qed. - -Lemma matching_behaviors_same: - forall b b1' b2', - matching_behaviors b b1' -> same_behaviors b1' b2' -> - matching_behaviors b b2'. -Proof. - intros. inv H; inv H0. - constructor. - constructor. apply traceinf_prefix_compat with T2 T1. - auto. apply traceinf_sim_sym; auto. apply traceinf_sim_refl. -Qed. - -(** * Additional semantic preservation property *) - -(** Combining the semantic preservation theorem from module [Main] - with the determinism of PPC executions, we easily obtain - additional, stronger semantic preservation properties. - The first property states that, when compiling a Clight - program that has well-defined semantics, all possible executions - of the resulting PPC code correspond to an execution of - the source Clight program, in the sense of the [matching_behaviors] - predicate. *) - -Theorem transf_c_program_correct_strong: - forall p tp b w, - transf_c_program p = OK tp -> - Csem.exec_program p b -> - possible_behavior w b -> - (exists b', exec_program' tp w b') -/\(forall b', exec_program' tp w b' -> - exists b0, Csem.exec_program p b0 /\ matching_behaviors b0 b'). -Proof. - intros. - assert (PPC.exec_program tp b). - eapply transf_c_program_correct; eauto. - exploit exec_program_program'; eauto. - intros [b' [A B]]. - split. exists b'; auto. - intros. exists b. split. auto. - apply matching_behaviors_same with b'. auto. - eapply exec_program'_deterministic; eauto. -Qed. - -Section SPECS_PRESERVED. - -(** The second additional results shows that if one execution - of the source Clight program satisfies a given specification - (a predicate on the observable behavior of the program), - then all executions of the produced PPC program satisfy - this specification as well. *) - -Variable spec: program_behavior -> Prop. - -(* Since the execution trace for a diverging Clight program - is not uniquely defined (the trace can contain events that - the program will never perform because it loops earlier), - this result holds only if the specification is closed under - prefixes in the case of diverging executions. This is the - case for all safety properties (some undesirable event never - occurs), but not for liveness properties (some desirable event - always occurs). *) - -Hypothesis spec_safety: - forall T T', traceinf_prefix T T' -> spec (Diverges T') -> spec (Diverges T). - -Theorem transf_c_program_preserves_spec: - forall p tp b w, - transf_c_program p = OK tp -> - Csem.exec_program p b -> - possible_behavior w b -> - spec b -> - (exists b', exec_program' tp w b') -/\(forall b', exec_program' tp w b' -> spec b'). -Proof. - intros. - assert (PPC.exec_program tp b). - eapply transf_c_program_correct; eauto. - exploit exec_program_program'; eauto. - intros [b' [A B]]. - split. exists b'; auto. - intros b'' EX. - assert (same_behaviors b' b''). eapply exec_program'_deterministic; eauto. - inv B; inv H4. - auto. - apply spec_safety with T1. - eapply traceinf_prefix_compat with T2 T1. - auto. apply traceinf_sim_sym; auto. apply traceinf_sim_refl. - auto. -Qed. - -End SPECS_PRESERVED. diff --git a/common/Main.v b/common/Main.v deleted file mode 100644 index f50640a..0000000 --- a/common/Main.v +++ /dev/null @@ -1,305 +0,0 @@ -(* *********************************************************************) -(* *) -(* The Compcert verified compiler *) -(* *) -(* Xavier Leroy, INRIA Paris-Rocquencourt *) -(* *) -(* Copyright Institut National de Recherche en Informatique et en *) -(* Automatique. All rights reserved. This file is distributed *) -(* under the terms of the INRIA Non-Commercial License Agreement. *) -(* *) -(* *********************************************************************) - -(** 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. -Require Allocproof. -Require Alloctyping. -Require Tunnelingproof. -Require Tunnelingtyping. -Require Linearizeproof. -Require Linearizetyping. -Require Reloadproof. -Require Reloadtyping. -Require Stackingproof. -Require Stackingtyping. -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: 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: 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 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. - 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 an RTL function to a PPC function is as follows. *) - -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_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) : res PPC.program := - match Ctyping.typecheck_program p with - | false => - Error (msg "Ctyping: type error") - | true => - OK p - @@@ Cshmgen.transl_program - @@@ Cminorgen.transl_program - @@@ transf_cminor_program - end. - -(** The following lemmas help reason over compositions of passes. *) - -Lemma map_partial_compose: - forall (X A B C: Set) - (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 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_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. - 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_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 until tp. unfold transform_partial_program. - rewrite map_partial_total. simpl. intros. inv H. auto. -Qed. - -Lemma transform_program_compose: - forall (A B C V: Set) - (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. - 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_partial_program_identity: - forall (A V: Set) (pa pb: program A V), - transform_partial_program (@OK A) pa = OK pb -> - pa = pb. -Proof. - 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. - -(** * Semantic preservation *) - -(** 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! *) - -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_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. - 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. - - 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). - apply Linearizetyping.program_typing_preserved with p4. auto. 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. - - 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. - apply Linearizeproof.transf_program_correct with p4; 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 beh, - transf_cminor_program p = OK tp -> - Cminor.exec_program p beh -> - PPC.exec_program tp beh. -Proof. - 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.transf_program_correct with p2; auto. - rewrite <- P1. apply Selectionproof.transf_program_correct; auto. -Qed. - -Theorem transf_c_program_correct: - forall p tp beh, - transf_c_program p = OK tp -> - Csem.exec_program p beh -> - PPC.exec_program tp beh. -Proof. - intros until beh; unfold transf_c_program; simpl. - caseEq (Ctyping.typecheck_program p); try congruence; intro. - caseEq (Cshmgen.transl_program p); simpl; try congruence; intros p1 EQ1. - caseEq (Cminorgen.transl_program p1); simpl; try congruence; intros p2 EQ2. - intros EQ3 SEM. - eapply transf_cminor_program_correct; eauto. - eapply Cminorgenproof.transl_program_correct; eauto. - eapply Cshmgenproof3.transl_program_correct; eauto. - apply Ctyping.typecheck_program_correct; auto. -Qed. diff --git a/configure b/configure index bd1b7bb..0d71d27 100755 --- a/configure +++ b/configure @@ -16,6 +16,22 @@ cildistrib=cil-1.3.5.tar.gz prefix=/usr/local bindir='$(PREFIX)/bin' libdir='$(PREFIX)/lib/compcert' +target='' + +usage='Usage: ./configure [options] + +Supported targets: + macosx (PowerPC, MacOS X) + ppc-linux (PowerPC, Linux) + ppc-linux-cross (PowerPC, Linux, cross-compilation) + arm-linux (ARM, Linux) + arm-linux-cross (ARM, Linux, cross-compilation) + +Options: + -prefix Install in /bin and /lib/compcert + -bindir Install binaries in + -libdir Install libraries in +' # Parse command-line arguments @@ -28,11 +44,64 @@ while : ; do bindir=$2; shift;; -libdir|--libdir) libdir=$2; shift;; - *) echo "Unknown option \"$1\"." 1>&2; exit 2;; + *) + if test -n "$target"; then echo "$usage" 1>&2; exit 2; fi + target="$1";; esac shift done +if test -z "$target"; then echo "$usage" 1>&2; exit 2; fi + +# Per-target configuration + +case "$target" in + macosx) + arch="powerpc" + variant="macosx" + cc="gcc -arch ppc" + cprepro="gcc -arch ppc -U__GNUC__ -E" + casm="gcc -arch ppc -c" + clinker="gcc -arch ppc" + libmath="";; + ppc-linux) + arch="powerpc" + variant="eabi" + cc="gcc" + cprepro="gcc -U__GNUC__ -E" + casm="gcc -c" + clinker="gcc" + libmath="-lm";; + ppc-linux-cross) + arch="powerpc" + variant="eabi" + cc="ppc-linux-gcc" + cprepro="ppc-linux-gcc -U__GNUC__ -E" + casm="ppc-linux-gcc -c" + clinker="ppc-linux-gcc" + libmath="-lm";; + arm-linux) + arch="arm" + variant="linux" + cc="gcc" + cprepro="gcc -U__GNUC__ -E" + casm="gcc -c" + clinker="gcc" + libmath="-lm";; + arm-linux-cross) + arch="arm" + variant="linux" + cc="arm-linux-gcc" + cprepro="arm-linux-gcc -U__GNUC__ -E" + casm="arm-linux-gcc -c" + clinker="arm-linux-gcc" + libmath="-lm";; + *) + echo "Unsupported configuration '$target'" 1>&2 + echo "$usage" 1>&2 + exit 2;; +esac + # Generate Makefile.config rm -f Makefile.config @@ -40,11 +109,13 @@ cat > Makefile.config < B) : res B := + match x with Error msg => Error msg | OK x1 => OK (f x1) end. + +Definition apply_partial (A B: Set) + (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 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 Asm 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 Asm, 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 Asm, we follow the first approach because it has + lower memory requirements. The translation from Clight to Asm + follows the second approach. + + The translation of an RTL function to an Asm function is as follows. *) + +Definition transf_rtl_fundef (f: RTL.fundef) : res Asm.fundef := + OK f + @@ Constprop.transf_fundef + @@ CSE.transf_fundef + @@@ Allocation.transf_fundef + @@ Tunneling.tunnel_fundef + @@@ Linearize.transf_fundef + @@ Reload.transf_fundef + @@@ Stacking.transf_fundef + @@@ Asmgen.transf_fundef. + +(* Here is the translation of a Cminor function to an Asm function. *) + +Definition transf_cminor_fundef (f: Cminor.fundef) : res Asm.fundef := + OK f + @@ Selection.sel_fundef + @@@ RTLgen.transl_fundef + @@@ transf_rtl_fundef. + +(** The corresponding translations for whole program follow. *) + +Definition transf_rtl_program (p: RTL.program) : res Asm.program := + transform_partial_program transf_rtl_fundef p. + +Definition transf_cminor_program (p: Cminor.program) : res Asm.program := + transform_partial_program transf_cminor_fundef p. + +Definition transf_c_program (p: Csyntax.program) : res Asm.program := + match Ctyping.typecheck_program p with + | false => + Error (msg "Ctyping: type error") + | true => + OK p + @@@ Cshmgen.transl_program + @@@ Cminorgen.transl_program + @@@ transf_cminor_program + end. + +(** The following lemmas help reason over compositions of passes. *) + +Lemma map_partial_compose: + forall (X A B C: Set) + (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 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_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. + 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_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 until tp. unfold transform_partial_program. + rewrite map_partial_total. simpl. intros. inv H. auto. +Qed. + +Lemma transform_program_compose: + forall (A B C V: Set) + (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. + 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_partial_program_identity: + forall (A V: Set) (pa pb: program A V), + transform_partial_program (@OK A) pa = OK pb -> + pa = pb. +Proof. + 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. + +(** * Semantic preservation *) + +(** 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! *) + +Theorem transf_rtl_program_correct: + forall p tp beh, + transf_rtl_program p = OK tp -> + RTL.exec_program p beh -> + Asm.exec_program tp beh. +Proof. + 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. + 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. + + 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). + apply Linearizetyping.program_typing_preserved with p4. auto. 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. + + apply Asmgenproof.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. + apply Linearizeproof.transf_program_correct with p4; 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 beh, + transf_cminor_program p = OK tp -> + Cminor.exec_program p beh -> + Asm.exec_program tp beh. +Proof. + 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.transf_program_correct with p2; auto. + rewrite <- P1. apply Selectionproof.transf_program_correct; auto. +Qed. + +Theorem transf_c_program_correct: + forall p tp beh, + transf_c_program p = OK tp -> + Csem.exec_program p beh -> + Asm.exec_program tp beh. +Proof. + intros until beh; unfold transf_c_program; simpl. + caseEq (Ctyping.typecheck_program p); try congruence; intro. + caseEq (Cshmgen.transl_program p); simpl; try congruence; intros p1 EQ1. + caseEq (Cminorgen.transl_program p1); simpl; try congruence; intros p2 EQ2. + intros EQ3 SEM. + eapply transf_cminor_program_correct; eauto. + eapply Cminorgenproof.transl_program_correct; eauto. + eapply Cshmgenproof3.transl_program_correct; eauto. + apply Ctyping.typecheck_program_correct; auto. +Qed. diff --git a/driver/Complements.v b/driver/Complements.v new file mode 100644 index 0000000..fc2fa53 --- /dev/null +++ b/driver/Complements.v @@ -0,0 +1,648 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Corollaries of the main semantic preservation theorem. *) + +Require Import Classical. +Require Import Coqlib. +Require Import AST. +Require Import Integers. +Require Import Values. +Require Import Events. +Require Import Globalenvs. +Require Import Smallstep. +Require Import Csyntax. +Require Import Csem. +Require Import Asm. +Require Import Compiler. +Require Import Errors. + +(** * Determinism of Asm semantics *) + +(** In this section, we show that the semantics for the Asm language + are deterministic, in a sense to be made precise later. + There are two sources of apparent non-determinism: +- The semantics leaves unspecified the results of calls to external + functions. Different results to e.g. a "read" operation can of + course lead to different behaviors for the program. + We address this issue by modeling a notion of deterministic + external world that uniquely determines the results of external calls. +- For diverging executions, the trace of I/O events is not uniquely + determined: it can contain events that will never be performed + because the program diverges earlier. We address this issue + by showing the existence of a minimal trace for diverging executions. + +*) + +(** ** Deterministic worlds *) + +(** An external world is a function that, given the name of an + external call and its arguments, returns either [None], meaning + that this external call gets stuck, or [Some(r,w)], meaning + that this external call succeeds, has result [r], and changes + the world to [w]. *) + +Inductive world: Set := + World: (ident -> list eventval -> option (eventval * world)) -> world. + +Definition nextworld (w: world) (evname: ident) (evargs: list eventval) : + option (eventval * world) := + match w with World f => f evname evargs end. + +(** A trace is possible in a given world if all events correspond + to non-stuck external calls according to the given world. + Two predicates are defined, for finite and infinite traces respectively: +- [possible_trace w t w'], where [w] is the initial state of the + world, [t] the finite trace of interest, and [w'] the state of the + world after performing trace [t]. +- [possible_traceinf w T], where [w] is the initial state of the + world and [T] the possibly infinite trace of interest. +*) + +Inductive possible_trace: world -> trace -> world -> Prop := + | possible_trace_nil: forall w, + possible_trace w E0 w + | possible_trace_cons: forall w0 evname evargs evres w1 t w2, + nextworld w0 evname evargs = Some (evres, w1) -> + possible_trace w1 t w2 -> + possible_trace w0 (mkevent evname evargs evres :: t) w2. + +Lemma possible_trace_app: + forall t2 w2 w0 t1 w1, + possible_trace w0 t1 w1 -> possible_trace w1 t2 w2 -> + possible_trace w0 (t1 ** t2) w2. +Proof. + induction 1; simpl; intros. + auto. + econstructor; eauto. +Qed. + +Lemma possible_trace_app_inv: + forall t2 w2 t1 w0, + possible_trace w0 (t1 ** t2) w2 -> + exists w1, possible_trace w0 t1 w1 /\ possible_trace w1 t2 w2. +Proof. + induction t1; simpl; intros. + exists w0; split. constructor. auto. + inv H. exploit IHt1; eauto. intros [w1 [A B]]. + exists w1; split. econstructor; eauto. auto. +Qed. + +CoInductive possible_traceinf: world -> traceinf -> Prop := + | possible_traceinf_nil: forall w0, + possible_traceinf w0 Enilinf + | possible_traceinf_cons: forall w0 evname evargs evres w1 T, + nextworld w0 evname evargs = Some (evres, w1) -> + possible_traceinf w1 T -> + possible_traceinf w0 (Econsinf (mkevent evname evargs evres) T). + +Lemma possible_traceinf_app: + forall t2 w0 t1 w1, + possible_trace w0 t1 w1 -> possible_traceinf w1 t2 -> + possible_traceinf w0 (t1 *** t2). +Proof. + induction 1; simpl; intros. + auto. + econstructor; eauto. +Qed. + +Lemma possible_traceinf_app_inv: + forall t2 t1 w0, + possible_traceinf w0 (t1 *** t2) -> + exists w1, possible_trace w0 t1 w1 /\ possible_traceinf w1 t2. +Proof. + induction t1; simpl; intros. + exists w0; split. constructor. auto. + inv H. exploit IHt1; eauto. intros [w1 [A B]]. + exists w1; split. econstructor; eauto. auto. +Qed. + +Ltac possibleTraceInv := + match goal with + | [H: possible_trace _ (_ ** _) _ |- _] => + let P1 := fresh "P" in + let w := fresh "w" in + let P2 := fresh "P" in + elim (possible_trace_app_inv _ _ _ _ H); clear H; + intros w [P1 P2]; + possibleTraceInv + | [H: possible_traceinf _ (_ *** _) |- _] => + let P1 := fresh "P" in + let w := fresh "w" in + let P2 := fresh "P" in + elim (possible_traceinf_app_inv _ _ _ H); clear H; + intros w [P1 P2]; + possibleTraceInv + | _ => idtac + end. + +(** Determinism properties of [event_match]. *) + +Remark eventval_match_deterministic: + forall ev1 ev2 ty v1 v2, + eventval_match ev1 ty v1 -> eventval_match ev2 ty v2 -> + (ev1 = ev2 <-> v1 = v2). +Proof. + intros. inv H; inv H0; intuition congruence. +Qed. + +Remark eventval_list_match_deterministic: + forall ev1 ty v, eventval_list_match ev1 ty v -> + forall ev2, eventval_list_match ev2 ty v -> ev1 = ev2. +Proof. + induction 1; intros. + inv H. auto. + inv H1. decEq. + rewrite (eventval_match_deterministic _ _ _ _ _ H H6). auto. + eauto. +Qed. + +Lemma event_match_deterministic: + forall w0 t1 w1 t2 w2 ef vargs vres1 vres2, + possible_trace w0 t1 w1 -> + possible_trace w0 t2 w2 -> + event_match ef vargs t1 vres1 -> + event_match ef vargs t2 vres2 -> + vres1 = vres2 /\ t1 = t2 /\ w1 = w2. +Proof. + intros. inv H1. inv H2. + assert (eargs = eargs0). eapply eventval_list_match_deterministic; eauto. subst eargs0. + inv H. inv H12. inv H0. inv H12. + rewrite H11 in H10. inv H10. intuition. + rewrite <- (eventval_match_deterministic _ _ _ _ _ H4 H5). auto. +Qed. + +(** ** Determinism of Asm transitions. *) + +Remark extcall_arguments_deterministic: + forall rs m sg args args', + extcall_arguments rs m sg args -> + extcall_arguments rs m sg args' -> args = args'. +Proof. + assert ( + forall rs m ll args, + extcall_args rs m ll args -> + forall args', extcall_args rs m ll args' -> args = args'). + induction 1; intros. + inv H. auto. + inv H1. decEq; eauto. + inv H; inv H4; congruence. + unfold extcall_arguments; intros; eauto. +Qed. + +Lemma step_deterministic: + forall ge s0 t1 s1 t2 s2 w0 w1 w2, + step ge s0 t1 s1 -> step ge s0 t2 s2 -> + possible_trace w0 t1 w1 -> possible_trace w0 t2 w2 -> + s1 = s2 /\ t1 = t2 /\ w1 = w2. +Proof. + intros. inv H; inv H0. + assert (c0 = c) by congruence. subst c0. + assert (i0 = i) by congruence. subst i0. + split. congruence. split. auto. inv H1; inv H2; auto. + congruence. + congruence. + assert (ef0 = ef) by congruence. subst ef0. + assert (args0 = args). eapply extcall_arguments_deterministic; eauto. subst args0. + exploit event_match_deterministic. eexact H1. eexact H2. eauto. eauto. + intros [A [B C]]. intuition congruence. +Qed. + +Lemma initial_state_deterministic: + forall p s1 s2, + initial_state p s1 -> initial_state p s2 -> s1 = s2. +Proof. + intros. inv H; inv H0. reflexivity. +Qed. + +Lemma final_state_not_step: + forall ge st r t st', final_state st r -> step ge st t st' -> False. +Proof. + intros. inv H. inv H0. + unfold Vzero in H1. congruence. + unfold Vzero in H1. congruence. +Qed. + +Lemma final_state_deterministic: + forall st r1 r2, final_state st r1 -> final_state st r2 -> r1 = r2. +Proof. + intros. inv H; inv H0. congruence. +Qed. + +(** ** Determinism for terminating executions. *) + +(* +Lemma star_star_inv: + forall ge s t1 s1, star step ge s t1 s1 -> + forall t2 s2 w w1 w2, star step ge s t2 s2 -> + possible_trace w t1 w1 -> possible_trace w t2 w2 -> + exists t, (star step ge s1 t s2 /\ t2 = t1 ** t) + \/ (star step ge s2 t s1 /\ t1 = t2 ** t). +Proof. + induction 1; intros. + exists t2; left; split; auto. + inv H2. exists (t1 ** t2); right; split. econstructor; eauto. auto. + possibleTraceInv. + exploit step_deterministic. eexact H. eexact H5. eauto. eauto. + intros [U [V W]]. subst s5 t3 w3. + exploit IHstar; eauto. intros [t [ [Q R] | [Q R] ]]. + subst t4. exists t; left; split. auto. traceEq. + subst t2. exists t; right; split. auto. traceEq. +Qed. +*) + +Lemma steps_deterministic: + forall ge s0 t1 s1, star step ge s0 t1 s1 -> + forall r1 r2 t2 s2 w0 w1 w2, star step ge s0 t2 s2 -> + final_state s1 r1 -> final_state s2 r2 -> + possible_trace w0 t1 w1 -> possible_trace w0 t2 w2 -> + t1 = t2 /\ r1 = r2. +Proof. + induction 1; intros. + inv H. split. auto. eapply final_state_deterministic; eauto. + byContradiction. eapply final_state_not_step with (st := s); eauto. + inv H2. byContradiction. eapply final_state_not_step with (st := s0); eauto. + possibleTraceInv. + exploit step_deterministic. eexact H. eexact H7. eauto. eauto. + intros [A [B C]]. subst s5 t3 w3. + exploit IHstar. eexact H8. eauto. eauto. eauto. eauto. + intros [A B]. subst t4 r2. + auto. +Qed. + +(** ** Determinism for infinite transition sequences. *) + +Lemma forever_star_inv: + forall ge s t s', star step ge s t s' -> + forall T w w', forever step ge s T -> + possible_trace w t w' -> possible_traceinf w T -> + exists T', + forever step ge s' T' /\ possible_traceinf w' T' /\ T = t *** T'. +Proof. + induction 1; intros. + inv H0. exists T; auto. + subst t. possibleTraceInv. + inv H2. possibleTraceInv. + exploit step_deterministic. + eexact H. eexact H1. eauto. eauto. intros [A [B C]]; subst s4 t1 w1. + exploit IHstar; eauto. intros [T' [A [B C]]]. + exists T'; split. auto. + split. auto. + rewrite C. rewrite Eappinf_assoc; auto. +Qed. + +Lemma star_final_not_forever: + forall ge s1 t s2 r T w1 w2, + star step ge s1 t s2 -> + final_state s2 r -> forever step ge s1 T -> + possible_trace w1 t w2 -> possible_traceinf w1 T -> + False. +Proof. + intros. exploit forever_star_inv; eauto. intros [T' [A [B C]]]. + inv A. eapply final_state_not_step; eauto. +Qed. + +(** ** Minimal traces for divergence. *) + +(** There are two mutually exclusive way in which a program can diverge. + It can diverge in a reactive fashion: it performs infinitely many + external calls, and the internal computations between two external + calls are always finite. Or it can diverge silently: after a finite + number of external calls, it enters an infinite sequence of internal + computations. *) + +Definition reactive (ge: genv) (s: state) (w: world) := + forall t s1 w1, + star step ge s t s1 -> possible_trace w t w1 -> + exists s2, exists t', exists s3, exists w2, + star step ge s1 E0 s2 + /\ step ge s2 t' s3 + /\ possible_trace w1 t' w2 + /\ t' <> E0. + +Definition diverges_silently (ge: genv) (s: state) := + forall s2, star step ge s E0 s2 -> exists s3, step ge s2 E0 s3. + +Definition diverges_eventually (ge: genv) (s: state) (w: world) := + exists t, exists s1, exists w1, + star step ge s t s1 /\ possible_trace w t w1 /\ diverges_silently ge s1. + +(** Using classical logic, we show that any infinite sequence of transitions + that is possible in a deterministic world is of one of the two forms + described above. *) + +Lemma reactive_or_diverges: + forall ge s T w, + forever step ge s T -> possible_traceinf w T -> + reactive ge s w \/ diverges_eventually ge s w. +Proof. + intros. elim (classic (diverges_eventually ge s w)); intro. + right; auto. + left. red; intros. + generalize (not_ex_all_not trace _ H1 t). + intro. clear H1. + generalize (not_ex_all_not state _ H4 s1). + intro. clear H4. + generalize (not_ex_all_not world _ H1 w1). + intro. clear H1. + elim (not_and_or _ _ H4); clear H4; intro. + contradiction. + elim (not_and_or _ _ H1); clear H1; intro. + contradiction. + generalize (not_all_ex_not state _ H1). intros [s2 A]. clear H1. + destruct (imply_to_and _ _ A). clear A. + exploit forever_star_inv. + eapply star_trans. eexact H2. eexact H1. reflexivity. + eauto. rewrite E0_right. eauto. eauto. + intros [T' [A [B C]]]. + inv A. possibleTraceInv. + exists s2; exists t0; exists s3; exists w4. intuition. + subst t0. apply H4. exists s3; auto. +Qed. + +(** Moreover, a program cannot be both reactive and silently diverging. *) + +Lemma reactive_not_diverges: + forall ge s w, + reactive ge s w -> diverges_eventually ge s w -> False. +Proof. + intros. destruct H0 as [t [s1 [w1 [A [B C]]]]]. + destruct (H _ _ _ A B) as [s2 [t' [s3 [w2 [P [Q [R S]]]]]]]. + destruct (C _ P) as [s4 T]. + assert (s3 = s4 /\ t' = E0 /\ w2 = w1). + eapply step_deterministic; eauto. constructor. + intuition congruence. +Qed. + +(** A program that silently diverges can be given any finite or + infinite trace of events. In particular, taking [T' = Enilinf], + it can be given the empty trace of events. *) + +Lemma diverges_forever: + forall ge s1 T w T', + diverges_silently ge s1 -> + forever step ge s1 T -> + possible_traceinf w T -> + forever step ge s1 T'. +Proof. + cofix COINDHYP; intros. inv H0. possibleTraceInv. + assert (exists s3, step ge s1 E0 s3). apply H. constructor. + destruct H0 as [s3 C]. + assert (s2 = s3 /\ t = E0 /\ w0 = w). eapply step_deterministic; eauto. constructor. + destruct H0 as [Q [R S]]. subst s3 t w0. + change T' with (E0 *** T'). econstructor. eassumption. + eapply COINDHYP; eauto. + red; intros. apply H. eapply star_left; eauto. +Qed. + +(** The trace of I/O events generated by a reactive diverging program + is uniquely determined up to bisimilarity. *) + +Lemma reactive_sim: + forall ge s w T1 T2, + reactive ge s w -> + forever step ge s T1 -> + forever step ge s T2 -> + possible_traceinf w T1 -> + possible_traceinf w T2 -> + traceinf_sim T1 T2. +Proof. + cofix COINDHYP; intros. + elim (H E0 s w); try constructor. + intros s2 [t' [s3 [w2 [A [B [C D]]]]]]. + assert (star step ge s t' s3). eapply star_right; eauto. + destruct (forever_star_inv _ _ _ _ H4 _ _ _ H0 C H2) + as [T1' [P [Q R]]]. + destruct (forever_star_inv _ _ _ _ H4 _ _ _ H1 C H3) + as [T2' [S [T U]]]. + destruct t'. unfold E0 in D. congruence. + assert (t' = nil). inversion B. inversion H7. auto. subst t'. + subst T1 T2. simpl. constructor. + apply COINDHYP with ge s3 w2; auto. + red; intros. eapply H. eapply star_trans; eauto. + eapply possible_trace_app; eauto. +Qed. + +(** A trace is minimal for a program if it is a prefix of all possible + traces. *) + +Definition minimal_trace (ge: genv) (s: state) (w: world) (T: traceinf) := + forall T', + forever step ge s T' -> possible_traceinf w T' -> + traceinf_prefix T T'. + +(** For any program that diverges with some possible trace [T1], + the set of possible traces admits a minimal element [T]. + If the program is reactive, this trace is [T1]. + If the program silently diverges, this trace is the finite trace + of events performed prior to silent divergence. *) + +Lemma forever_minimal_trace: + forall ge s T1 w, + forever step ge s T1 -> possible_traceinf w T1 -> + exists T, + forever step ge s T + /\ possible_traceinf w T + /\ minimal_trace ge s w T. +Proof. + intros. + destruct (reactive_or_diverges _ _ _ _ H H0). + (* reactive *) + exists T1; split. auto. split. auto. red; intros. + elim (reactive_or_diverges _ _ _ _ H2 H3); intro. + apply traceinf_sim_prefix. eapply reactive_sim; eauto. + elimtype False. eapply reactive_not_diverges; eauto. + (* diverges *) + elim H1. intros t [s1 [w1 [A [B C]]]]. + exists (t *** Enilinf); split. + exploit forever_star_inv; eauto. intros [T' [P [Q R]]]. + eapply star_forever. eauto. + eapply diverges_forever; eauto. + split. eapply possible_traceinf_app. eauto. constructor. + red; intros. exploit forever_star_inv. eauto. eexact H2. eauto. eauto. + intros [T2 [P [Q R]]]. + subst T'. apply traceinf_prefix_app. constructor. +Qed. + +(** ** Refined semantics for program executions. *) + +(** We now define the following variant [exec_program'] of the + [exec_program] predicate defined in module [Smallstep]. + In the diverging case [Diverges T], the new predicate imposes that the + finite or infinite trace [T] is minimal. *) + +Inductive exec_program' (p: program) (w: world): program_behavior -> Prop := + | program_terminates': forall s t s' w' r, + initial_state p s -> + star step (Genv.globalenv p) s t s' -> + possible_trace w t w' -> + final_state s' r -> + exec_program' p w (Terminates t r) + | program_diverges': forall s T, + initial_state p s -> + forever step (Genv.globalenv p) s T -> + possible_traceinf w T -> + minimal_trace (Genv.globalenv p) s w T -> + exec_program' p w (Diverges T). + +(** We show that any [exec_program] execution corresponds to + an [exec_program'] execution. *) + +Definition possible_behavior (w: world) (b: program_behavior) : Prop := + match b with + | Terminates t r => exists w', possible_trace w t w' + | Diverges T => possible_traceinf w T + end. + +Inductive matching_behaviors: program_behavior -> program_behavior -> Prop := + | matching_behaviors_terminates: forall t r, + matching_behaviors (Terminates t r) (Terminates t r) + | matching_behaviors_diverges: forall T1 T2, + traceinf_prefix T2 T1 -> + matching_behaviors (Diverges T1) (Diverges T2). + +Theorem exec_program_program': + forall p b w, + exec_program p b -> possible_behavior w b -> + exists b', exec_program' p w b' /\ matching_behaviors b b'. +Proof. + intros. inv H; simpl in H0. + (* termination *) + destruct H0 as [w' A]. + exists (Terminates t r). + split. econstructor; eauto. constructor. + (* divergence *) + exploit forever_minimal_trace; eauto. intros [T0 [A [B C]]]. + exists (Diverges T0); split. + econstructor; eauto. + constructor. apply C; auto. +Qed. + +(** Moreover, [exec_program'] is deterministic, in that the behavior + associated with a given program and external world is uniquely + defined up to bisimilarity between infinite traces. *) + +Inductive same_behaviors: program_behavior -> program_behavior -> Prop := + | same_behaviors_terminates: forall t r, + same_behaviors (Terminates t r) (Terminates t r) + | same_behaviors_diverges: forall T1 T2, + traceinf_sim T2 T1 -> + same_behaviors (Diverges T1) (Diverges T2). + +Theorem exec_program'_deterministic: + forall p b1 b2 w, + exec_program' p w b1 -> exec_program' p w b2 -> + same_behaviors b1 b2. +Proof. + intros. inv H; inv H0; + assert (s0 = s) by (eapply initial_state_deterministic; eauto); subst s0. + (* terminates, terminates *) + exploit steps_deterministic. eexact H2. eexact H5. eauto. eauto. eauto. eauto. + intros [A B]. subst. constructor. + (* terminates, diverges *) + byContradiction. eapply star_final_not_forever; eauto. + (* diverges, terminates *) + byContradiction. eapply star_final_not_forever; eauto. + (* diverges, diverges *) + constructor. apply traceinf_prefix_2_sim; auto. +Qed. + +Lemma matching_behaviors_same: + forall b b1' b2', + matching_behaviors b b1' -> same_behaviors b1' b2' -> + matching_behaviors b b2'. +Proof. + intros. inv H; inv H0. + constructor. + constructor. apply traceinf_prefix_compat with T2 T1. + auto. apply traceinf_sim_sym; auto. apply traceinf_sim_refl. +Qed. + +(** * Additional semantic preservation property *) + +(** Combining the semantic preservation theorem from module [Main] + with the determinism of Asm executions, we easily obtain + additional, stronger semantic preservation properties. + The first property states that, when compiling a Clight + program that has well-defined semantics, all possible executions + of the resulting Asm code correspond to an execution of + the source Clight program, in the sense of the [matching_behaviors] + predicate. *) + +Theorem transf_c_program_correct_strong: + forall p tp b w, + transf_c_program p = OK tp -> + Csem.exec_program p b -> + possible_behavior w b -> + (exists b', exec_program' tp w b') +/\(forall b', exec_program' tp w b' -> + exists b0, Csem.exec_program p b0 /\ matching_behaviors b0 b'). +Proof. + intros. + assert (Asm.exec_program tp b). + eapply transf_c_program_correct; eauto. + exploit exec_program_program'; eauto. + intros [b' [A B]]. + split. exists b'; auto. + intros. exists b. split. auto. + apply matching_behaviors_same with b'. auto. + eapply exec_program'_deterministic; eauto. +Qed. + +Section SPECS_PRESERVED. + +(** The second additional results shows that if one execution + of the source Clight program satisfies a given specification + (a predicate on the observable behavior of the program), + then all executions of the produced Asm program satisfy + this specification as well. *) + +Variable spec: program_behavior -> Prop. + +(* Since the execution trace for a diverging Clight program + is not uniquely defined (the trace can contain events that + the program will never perform because it loops earlier), + this result holds only if the specification is closed under + prefixes in the case of diverging executions. This is the + case for all safety properties (some undesirable event never + occurs), but not for liveness properties (some desirable event + always occurs). *) + +Hypothesis spec_safety: + forall T T', traceinf_prefix T T' -> spec (Diverges T') -> spec (Diverges T). + +Theorem transf_c_program_preserves_spec: + forall p tp b w, + transf_c_program p = OK tp -> + Csem.exec_program p b -> + possible_behavior w b -> + spec b -> + (exists b', exec_program' tp w b') +/\(forall b', exec_program' tp w b' -> spec b'). +Proof. + intros. + assert (Asm.exec_program tp b). + eapply transf_c_program_correct; eauto. + exploit exec_program_program'; eauto. + intros [b' [A B]]. + split. exists b'; auto. + intros b'' EX. + assert (same_behaviors b' b''). eapply exec_program'_deterministic; eauto. + inv B; inv H4. + auto. + apply spec_safety with T1. + eapply traceinf_prefix_compat with T2 T1. + auto. apply traceinf_sim_sym; auto. apply traceinf_sim_refl. + auto. +Qed. + +End SPECS_PRESERVED. diff --git a/driver/Driver.ml b/driver/Driver.ml new file mode 100644 index 0000000..8361829 --- /dev/null +++ b/driver/Driver.ml @@ -0,0 +1,352 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +open Printf +open Clflags + +(* Location of the standard library *) + +let stdlib_path = ref( + try + Sys.getenv "COMPCERT_LIBRARY" + with Not_found -> + Configuration.stdlib_path) + +let command cmd = + if !option_v then begin + prerr_string "+ "; prerr_string cmd; prerr_endline "" + end; + Sys.command cmd + +let quote_options opts = + String.concat " " (List.rev_map Filename.quote opts) + +let safe_remove file = + try Sys.remove file with Sys_error _ -> () + +(* Printing of error messages *) + +let print_error oc msg = + let print_one_error = function + | Errors.MSG s -> output_string oc (Camlcoq.camlstring_of_coqstring s) + | Errors.CTX i -> output_string oc (Camlcoq.extern_atom i) + in List.iter print_one_error msg + +(* For the CIL -> Csyntax translator: + + * The meaning of some type specifiers may depend on compiler options: + the size of an int or the default signedness of char, for instance. + + * Those type conversions may be parameterized thanks to a functor. + + * Remark: [None] means that the type specifier is not supported + (that is, an Unsupported exception will be raised if that type + specifier is encountered in the program). +*) + +module TypeSpecifierTranslator = struct + + open Cil + open Csyntax + + (** Convert a Cil.ikind into an (intsize * signedness) option *) + let convertIkind = function + | IChar -> Some (I8, Unsigned) + | ISChar -> Some (I8, Signed) + | IUChar -> Some (I8, Unsigned) + | IInt -> Some (I32, Signed) + | IUInt -> Some (I32, Unsigned) + | IShort -> Some (I16, Signed) + | IUShort -> Some (I16, Unsigned) + | ILong -> Some (I32, Signed) + | IULong -> Some (I32, Unsigned) + | ILongLong -> if !option_flonglong then Some (I32, Signed) else None + | IULongLong -> if !option_flonglong then Some (I32, Unsigned) else None + + (** Convert a Cil.fkind into an floatsize option *) + let convertFkind = function + | FFloat -> Some F32 + | FDouble -> Some F64 + | FLongDouble -> if !option_flonglong then Some F64 else None + +end + +module Cil2CsyntaxTranslator = Cil2Csyntax.Make(TypeSpecifierTranslator) + +(* From C to preprocessed C *) + +let preprocess ifile ofile = + let cmd = + sprintf "%s -D__COMPCERT__ -I%s %s %s > %s" + Configuration.prepro + !stdlib_path + (quote_options !prepro_options) + ifile ofile in + if command cmd <> 0 then begin + safe_remove ofile; + eprintf "Error during preprocessing.\n"; + exit 2 + end + +(* From preprocessed C to asm *) + +let compile_c_file sourcename ifile ofile = + (* Parsing and production of a CIL.file *) + let cil = + try + Frontc.parse ifile () + with + | Frontc.ParseError msg -> + eprintf "Error during parsing: %s\n" msg; + exit 2 + | Errormsg.Error -> + exit 2 in + (* Remove preprocessed file (always a temp file) *) + safe_remove ifile; + (* Restore original source file name *) + cil.Cil.fileName <- sourcename; + (* Cleanup in the CIL.file *) + Rmtmps.removeUnusedTemps ~isRoot:Rmtmps.isExportedRoot cil; + (* Conversion to Csyntax *) + let csyntax = + try + Cil2CsyntaxTranslator.convertFile cil + with + | Cil2CsyntaxTranslator.Unsupported msg -> + eprintf "%s\n" msg; + exit 2 + | Cil2CsyntaxTranslator.Internal_error msg -> + eprintf "%s\nPlease report it.\n" msg; + exit 2 in + (* Save Csyntax if requested *) + if !option_dclight then begin + let targetname = Filename.chop_suffix sourcename ".c" in + let oc = open_out (targetname ^ ".light.c") in + PrintCsyntax.print_program (Format.formatter_of_out_channel oc) csyntax; + close_out oc + end; + (* Convert to Asm *) + let ppc = + match Compiler.transf_c_program csyntax with + | Errors.OK x -> x + | Errors.Error msg -> + print_error stderr msg; + exit 2 in + (* Save asm *) + let oc = open_out ofile in + PrintAsm.print_program oc ppc; + close_out oc + +(* From Cminor to asm *) + +let compile_cminor_file ifile ofile = + let ic = open_in ifile in + let lb = Lexing.from_channel ic in + try + match Compiler.transf_cminor_program + (CMtypecheck.type_program + (CMparser.prog CMlexer.token lb)) with + | Errors.Error msg -> + print_error stderr msg; + exit 2 + | Errors.OK p -> + let oc = open_out ofile in + PrintAsm.print_program oc p; + close_out oc + with Parsing.Parse_error -> + eprintf "File %s, character %d: Syntax error\n" + ifile (Lexing.lexeme_start lb); + exit 2 + | CMlexer.Error msg -> + eprintf "File %s, character %d: %s\n" + ifile (Lexing.lexeme_start lb) msg; + exit 2 + | CMtypecheck.Error msg -> + eprintf "File %s, type-checking error:\n%s" + ifile msg; + exit 2 + +(* From asm to object file *) + +let assemble ifile ofile = + let cmd = + sprintf "%s -o %s %s" + Configuration.asm ofile ifile in + let retcode = command cmd in + if not !option_dasm then safe_remove ifile; + if retcode <> 0 then begin + safe_remove ofile; + eprintf "Error during assembling.\n"; + exit 2 + end + +(* Linking *) + +let linker exe_name files = + let cmd = + sprintf "%s -o %s %s -L%s -lcompcert" + Configuration.linker + (Filename.quote exe_name) + (quote_options files) + !stdlib_path in + if command cmd <> 0 then exit 2 + +(* Processing of a .c file *) + +let process_c_file sourcename = + let prefixname = Filename.chop_suffix sourcename ".c" in + if !option_E then begin + preprocess sourcename (prefixname ^ ".i") + end else begin + let preproname = Filename.temp_file "compcert" ".i" in + preprocess sourcename preproname; + if !option_S then begin + compile_c_file sourcename preproname (prefixname ^ ".s") + end else begin + let asmname = + if !option_dasm + then prefixname ^ ".s" + else Filename.temp_file "compcert" ".s" in + compile_c_file sourcename preproname asmname; + assemble asmname (prefixname ^ ".o") + end + end; + prefixname ^ ".o" + +(* Processing of a .cm file *) + +let process_cminor_file sourcename = + let prefixname = Filename.chop_suffix sourcename ".cm" in + if !option_S then begin + compile_cminor_file sourcename (prefixname ^ ".s") + end else begin + let asmname = + if !option_dasm + then prefixname ^ ".s" + else Filename.temp_file "compcert" ".s" in + compile_cminor_file sourcename asmname; + assemble asmname (prefixname ^ ".o") + end; + prefixname ^ ".o" + +(* Command-line parsing *) + +let starts_with s1 s2 = + String.length s1 >= String.length s2 && + String.sub s1 0 (String.length s2) = s2 + +let usage_string = +"ccomp [options] +Recognized source files: + .c C source file + .cm Cminor source file + .o Object file + .a Library file +Processing options: + -E Preprocess only, save result in .i + -S Compile to assembler only, save result in .s + -c Compile to object file only (no linking), result in .o +Preprocessing options: + -I Add to search path for #include files + -D= Define preprocessor symbol + -U Undefine preprocessor symbol +Compilation options: + -flonglong Treat 'long long' as 'long' and 'long double' as 'double' + -fmadd Use fused multiply-add and multiply-sub instructions + -dclight Save generated Clight in .light.c + -dasm Save generated assembly in .s +Linking options: + -l Link library + -L Add to search path for libraries + -o Generate executable in (default: a.out) +General options: + -stdlib Set the path of the Compcert run-time library + -v Print external commands before invoking them +" + +let rec parse_cmdline i = + if i < Array.length Sys.argv then begin + let s = Sys.argv.(i) in + if starts_with s "-I" || starts_with s "-D" || starts_with s "-U" + then begin + prepro_options := s :: !prepro_options; + parse_cmdline (i + 1) + end else + if starts_with s "-l" || starts_with s "-L" then begin + linker_options := s :: !linker_options; + parse_cmdline (i + 1) + end else + if s = "-o" && i + 1 < Array.length Sys.argv then begin + exe_name := Sys.argv.(i + 1); + parse_cmdline (i + 2) + end else + if s = "-stdlib" && i + 1 < Array.length Sys.argv then begin + stdlib_path := Sys.argv.(i + 1); + parse_cmdline (i + 2) + end else + if s = "-flonglong" then begin + option_flonglong := true; + parse_cmdline (i + 1) + end else + if s = "-fmadd" then begin + option_fmadd := true; + parse_cmdline (i + 1) + end else + if s = "-dclight" then begin + option_dclight := true; + parse_cmdline (i + 1) + end else + if s = "-dasm" then begin + option_dasm := true; + parse_cmdline (i + 1) + end else + if s = "-E" then begin + option_E := true; + parse_cmdline (i + 1) + end else + if s = "-S" then begin + option_S := true; + parse_cmdline (i + 1) + end else + if s = "-c" then begin + option_c := true; + parse_cmdline (i + 1) + end else + if s = "-v" then begin + option_v := true; + parse_cmdline (i + 1) + end else + if Filename.check_suffix s ".c" then begin + let objfile = process_c_file s in + linker_options := objfile :: !linker_options; + parse_cmdline (i + 1) + end else + if Filename.check_suffix s ".cm" then begin + let objfile = process_cminor_file s in + linker_options := objfile :: !linker_options; + parse_cmdline (i + 1) + end else + if Filename.check_suffix s ".o" || Filename.check_suffix s ".a" then begin + linker_options := s :: !linker_options; + parse_cmdline (i + 1) + end else begin + eprintf "Unknown argument `%s'\n" s; + eprintf "Usage: %s" usage_string; + exit 2 + end + end + +let _ = + parse_cmdline 1; + if not (!option_c || !option_S || !option_E) then begin + linker !exe_name !linker_options + end diff --git a/extraction/.depend b/extraction/.depend deleted file mode 100644 index a8ae227..0000000 --- a/extraction/.depend +++ /dev/null @@ -1,529 +0,0 @@ -../caml/CMlexer.cmi: ../caml/CMparser.cmi -../caml/CMparser.cmi: Cminor.cmi AST.cmi -../caml/CMtypecheck.cmi: Cminor.cmi -../caml/Coloringaux.cmi: Registers.cmi RTLtyping.cmi RTL.cmi Locations.cmi \ - InterfGraph.cmi -../caml/PrintPPC.cmi: PPC.cmi -../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 \ - CList.cmx AST.cmx -../caml/CMlexer.cmo: ../caml/Camlcoq.cmo ../caml/CMparser.cmi \ - ../caml/CMlexer.cmi -../caml/CMlexer.cmx: ../caml/Camlcoq.cmx ../caml/CMparser.cmx \ - ../caml/CMlexer.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: Integers.cmx Datatypes.cmx Cminor.cmx \ - ../caml/Camlcoq.cmx CList.cmx BinPos.cmx BinInt.cmx AST.cmx \ - ../caml/CMparser.cmi -../caml/CMtypecheck.cmo: Integers.cmi Datatypes.cmi Cminor.cmi \ - ../caml/Camlcoq.cmo CList.cmi AST.cmi ../caml/CMtypecheck.cmi -../caml/CMtypecheck.cmx: Integers.cmx Datatypes.cmx Cminor.cmx \ - ../caml/Camlcoq.cmx CList.cmx AST.cmx ../caml/CMtypecheck.cmi -../caml/Coloringaux.cmo: Registers.cmi RTLtyping.cmi RTL.cmi Maps.cmi \ - Locations.cmi InterfGraph.cmi Datatypes.cmi Conventions.cmi \ - ../caml/Camlcoq.cmo BinPos.cmi BinInt.cmi AST.cmi ../caml/Coloringaux.cmi -../caml/Coloringaux.cmx: Registers.cmx RTLtyping.cmx RTL.cmx Maps.cmx \ - Locations.cmx InterfGraph.cmx Datatypes.cmx Conventions.cmx \ - ../caml/Camlcoq.cmx BinPos.cmx BinInt.cmx AST.cmx ../caml/Coloringaux.cmi -../caml/Driver.cmo: ../caml/PrintPPC.cmi ../caml/PrintCsyntax.cmo Main.cmi \ - Errors.cmi Csyntax.cmi ../caml/Configuration.cmo ../caml/Clflags.cmo \ - ../caml/Cil2Csyntax.cmo ../caml/Camlcoq.cmo ../caml/CMtypecheck.cmi \ - ../caml/CMparser.cmi ../caml/CMlexer.cmi -../caml/Driver.cmx: ../caml/PrintPPC.cmx ../caml/PrintCsyntax.cmx Main.cmx \ - Errors.cmx Csyntax.cmx ../caml/Configuration.cmx ../caml/Clflags.cmx \ - ../caml/Cil2Csyntax.cmx ../caml/Camlcoq.cmx ../caml/CMtypecheck.cmx \ - ../caml/CMparser.cmx ../caml/CMlexer.cmx -../caml/Floataux.cmo: Integers.cmi ../caml/Camlcoq.cmo -../caml/Floataux.cmx: Integers.cmx ../caml/Camlcoq.cmx -../caml/Linearizeaux.cmo: Maps.cmi Lattice.cmi LTL.cmi Datatypes.cmi \ - Coqlib.cmi ../caml/Camlcoq.cmo CList.cmi BinPos.cmi -../caml/Linearizeaux.cmx: Maps.cmx Lattice.cmx LTL.cmx Datatypes.cmx \ - Coqlib.cmx ../caml/Camlcoq.cmx CList.cmx BinPos.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 \ - CList.cmx AST.cmx -../caml/PrintPPC.cmo: PPC.cmi Datatypes.cmi ../caml/Camlcoq.cmo CList.cmi \ - 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: Switch.cmi Integers.cmi Datatypes.cmi CminorSel.cmi \ - ../caml/Camlcoq.cmo -../caml/RTLgenaux.cmx: Switch.cmx Integers.cmx Datatypes.cmx CminorSel.cmx \ - ../caml/Camlcoq.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 -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 -AST.cmi: Specif.cmi Integers.cmi Floats.cmi Errors.cmi Datatypes.cmi \ - Coqlib.cmi CString.cmi CList.cmi BinPos.cmi BinInt.cmi Ascii.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 -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 -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: Values.cmi Specif.cmi Op.cmi Mem.cmi Integers.cmi \ - Globalenvs.cmi Datatypes.cmi Cminor.cmi CList.cmi BinInt.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 -Compare_dec.cmi: Specif.cmi Datatypes.cmi -Constprop.cmi: Specif.cmi Registers.cmi RTL.cmi Op.cmi Maps.cmi Integers.cmi \ - Floats.cmi Datatypes.cmi CList.cmi Bool.cmi BinPos.cmi BinInt.cmi AST.cmi -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 -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 -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: Specif.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 -CString.cmi: Specif.cmi Datatypes.cmi Ascii.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 -Floats.cmi: Specif.cmi Integers.cmi Datatypes.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 -FSetInterface.cmi: Specif.cmi OrderedType.cmi Datatypes.cmi CList.cmi -FSetList.cmi: Specif.cmi OrderedType.cmi Datatypes.cmi CList.cmi -Globalenvs.cmi: Values.cmi Mem.cmi Maps.cmi Integers.cmi Datatypes.cmi \ - CList.cmi BinPos.cmi BinInt.cmi AST.cmi -Integers.cmi: Zpower.cmi Zdiv.cmi Specif.cmi Datatypes.cmi Coqlib.cmi \ - CList.cmi Bool.cmi BinPos.cmi BinInt.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 Ordered.cmi Maps.cmi \ - Lattice.cmi Iteration.cmi Datatypes.cmi Coqlib.cmi CList.cmi CInt.cmi \ - BinPos.cmi BinInt.cmi -Lattice.cmi: Specif.cmi Maps.cmi FSetInterface.cmi Datatypes.cmi Bool.cmi \ - BinPos.cmi -Linearize.cmi: Specif.cmi OrderedType.cmi Ordered.cmi Op.cmi Maps.cmi \ - Lattice.cmi LTLin.cmi LTL.cmi Errors.cmi Datatypes.cmi Coqlib.cmi \ - CString.cmi CList.cmi CInt.cmi BinPos.cmi BinInt.cmi Ascii.cmi AST.cmi -Linear.cmi: Values.cmi Specif.cmi Op.cmi Mem.cmi Locations.cmi Integers.cmi \ - Globalenvs.cmi Datatypes.cmi Coqlib.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 -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 -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 -Mach.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 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 -OrderedType.cmi: Specif.cmi Datatypes.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 -PPCgen.cmi: Specif.cmi PPC.cmi Op.cmi Mach.cmi Locations.cmi Integers.cmi \ - Errors.cmi Datatypes.cmi Coqlib.cmi CString.cmi CList.cmi Bool.cmi \ - BinPos.cmi BinInt.cmi Ascii.cmi AST.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 -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 Integers.cmi Datatypes.cmi Conventions.cmi CList.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 Cminor.cmi \ - CString.cmi CList.cmi BinPos.cmi Ascii.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 -RTLtyping.cmi: Specif.cmi Registers.cmi RTL.cmi Op.cmi Maps.cmi Errors.cmi \ - Datatypes.cmi Coqlib.cmi Conventions.cmi CString.cmi CList.cmi Ascii.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 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: Specif.cmi Integers.cmi EqNat.cmi Datatypes.cmi Coqlib.cmi \ - CList.cmi BinPos.cmi BinInt.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 -ZArith_dec.cmi: Sumbool.cmi Specif.cmi Datatypes.cmi BinInt.cmi -Zbool.cmi: Zeven.cmi ZArith_dec.cmi Sumbool.cmi Specif.cmi Datatypes.cmi \ - BinInt.cmi -Zdiv.cmi: Zbool.cmi ZArith_dec.cmi Specif.cmi Datatypes.cmi BinPos.cmi \ - BinInt.cmi -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 -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 -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 -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 -BinNat.cmx: Specif.cmx Datatypes.cmx BinPos.cmx BinNat.cmi -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 -CList.cmx: Specif.cmx Datatypes.cmx CList.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 -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: Values.cmi Specif.cmi Op.cmi Mem.cmi Integers.cmi \ - Globalenvs.cmi Datatypes.cmi Cminor.cmi CList.cmi BinInt.cmi AST.cmi \ - CminorSel.cmi -CminorSel.cmx: Values.cmx Specif.cmx Op.cmx Mem.cmx Integers.cmx \ - Globalenvs.cmx Datatypes.cmx Cminor.cmx CList.cmx BinInt.cmx AST.cmx \ - CminorSel.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 -Coloring.cmx: Specif.cmx Registers.cmx RTLtyping.cmx RTL.cmx Op.cmx Maps.cmx \ - Locations.cmx InterfGraph.cmx Datatypes.cmx Coqlib.cmx Conventions.cmx \ - ../caml/Coloringaux.cmx CList.cmx BinInt.cmx AST.cmx Coloring.cmi -Compare_dec.cmo: Specif.cmi Datatypes.cmi Compare_dec.cmi -Compare_dec.cmx: Specif.cmx Datatypes.cmx Compare_dec.cmi -Constprop.cmo: Specif.cmi Registers.cmi RTL.cmi Op.cmi Maps.cmi Lattice.cmi \ - Kildall.cmi Integers.cmi Floats.cmi Datatypes.cmi CList.cmi Bool.cmi \ - BinPos.cmi BinInt.cmi AST.cmi Constprop.cmi -Constprop.cmx: Specif.cmx Registers.cmx RTL.cmx Op.cmx Maps.cmx Lattice.cmx \ - Kildall.cmx Integers.cmx Floats.cmx Datatypes.cmx CList.cmx Bool.cmx \ - BinPos.cmx BinInt.cmx AST.cmx Constprop.cmi -Conventions.cmo: Locations.cmi Datatypes.cmi Coqlib.cmi CList.cmi BinPos.cmi \ - BinInt.cmi AST.cmi Conventions.cmi -Conventions.cmx: Locations.cmx Datatypes.cmx Coqlib.cmx CList.cmx BinPos.cmx \ - BinInt.cmx AST.cmx Conventions.cmi -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 -CSE.cmo: Specif.cmi Registers.cmi RTL.cmi Op.cmi Maps.cmi Kildall.cmi \ - Integers.cmi Floats.cmi Datatypes.cmi Coqlib.cmi CList.cmi BinPos.cmi \ - AST.cmi CSE.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 -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 Mem.cmx Maps.cmx Integers.cmx \ - Globalenvs.cmx Floats.cmx Datatypes.cmx Cminor.cmx CList.cmx BinInt.cmx \ - AST.cmx Csharpminor.cmi -Cshmgen.cmo: Specif.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 Cshmgen.cmi -Cshmgen.cmx: Specif.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 -CString.cmo: Specif.cmi Datatypes.cmi Ascii.cmi CString.cmi -CString.cmx: Specif.cmx Datatypes.cmx Ascii.cmx CString.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 -Floats.cmo: Specif.cmi Integers.cmi ../caml/Floataux.cmo Datatypes.cmi \ - Floats.cmi -Floats.cmx: Specif.cmx Integers.cmx ../caml/Floataux.cmx Datatypes.cmx \ - Floats.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 \ - Datatypes.cmx CList.cmx CInt.cmx BinPos.cmx BinInt.cmx FSetAVL.cmi -FSetFacts.cmo: Specif.cmi Setoid.cmi OrderedType.cmi FSetInterface.cmi \ - Datatypes.cmi FSetFacts.cmi -FSetFacts.cmx: Specif.cmx Setoid.cmx OrderedType.cmx FSetInterface.cmx \ - Datatypes.cmx FSetFacts.cmi -FSetInterface.cmo: Specif.cmi OrderedType.cmi Datatypes.cmi CList.cmi \ - FSetInterface.cmi -FSetInterface.cmx: Specif.cmx OrderedType.cmx Datatypes.cmx CList.cmx \ - FSetInterface.cmi -FSetList.cmo: Specif.cmi OrderedType.cmi Datatypes.cmi CList.cmi FSetList.cmi -FSetList.cmx: Specif.cmx OrderedType.cmx Datatypes.cmx CList.cmx FSetList.cmi -Globalenvs.cmo: Values.cmi Mem.cmi Maps.cmi Integers.cmi Datatypes.cmi \ - CList.cmi BinPos.cmi BinInt.cmi AST.cmi Globalenvs.cmi -Globalenvs.cmx: Values.cmx Mem.cmx Maps.cmx Integers.cmx Datatypes.cmx \ - CList.cmx BinPos.cmx BinInt.cmx AST.cmx Globalenvs.cmi -Integers.cmo: Zpower.cmi Zdiv.cmi Specif.cmi Datatypes.cmi Coqlib.cmi \ - CList.cmi Bool.cmi BinPos.cmi BinInt.cmi Integers.cmi -Integers.cmx: Zpower.cmx Zdiv.cmx Specif.cmx Datatypes.cmx Coqlib.cmx \ - CList.cmx Bool.cmx BinPos.cmx BinInt.cmx Integers.cmi -InterfGraph.cmo: Specif.cmi Registers.cmi OrderedType.cmi Ordered.cmi \ - Locations.cmi FSetAVL.cmi Datatypes.cmi Coqlib.cmi CList.cmi BinPos.cmi \ - BinInt.cmi InterfGraph.cmi -InterfGraph.cmx: Specif.cmx Registers.cmx OrderedType.cmx Ordered.cmx \ - Locations.cmx FSetAVL.cmx Datatypes.cmx Coqlib.cmx CList.cmx BinPos.cmx \ - BinInt.cmx InterfGraph.cmi -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 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 -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 -Linearize.cmo: Specif.cmi OrderedType.cmi Ordered.cmi Op.cmi Maps.cmi \ - ../caml/Linearizeaux.cmo Lattice.cmi LTLin.cmi LTL.cmi Kildall.cmi \ - FSetAVL.cmi Errors.cmi Datatypes.cmi Coqlib.cmi CString.cmi CList.cmi \ - BinPos.cmi BinInt.cmi Ascii.cmi AST.cmi Linearize.cmi -Linearize.cmx: Specif.cmx OrderedType.cmx Ordered.cmx Op.cmx Maps.cmx \ - ../caml/Linearizeaux.cmx Lattice.cmx LTLin.cmx LTL.cmx Kildall.cmx \ - FSetAVL.cmx Errors.cmx Datatypes.cmx Coqlib.cmx CString.cmx CList.cmx \ - BinPos.cmx BinInt.cmx Ascii.cmx AST.cmx Linearize.cmi -Linear.cmo: Values.cmi Specif.cmi Op.cmi Mem.cmi Locations.cmi Integers.cmi \ - Globalenvs.cmi Datatypes.cmi Coqlib.cmi Conventions.cmi CList.cmi \ - BinPos.cmi BinInt.cmi AST.cmi Linear.cmi -Linear.cmx: Values.cmx Specif.cmx Op.cmx Mem.cmx Locations.cmx Integers.cmx \ - Globalenvs.cmx Datatypes.cmx Coqlib.cmx Conventions.cmx CList.cmx \ - BinPos.cmx BinInt.cmx AST.cmx Linear.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 -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 -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 -Mach.cmo: 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: 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 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 \ - BinInt.cmx Maps.cmi -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 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 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 -Ordered.cmx: Specif.cmx OrderedType.cmx Maps.cmx Datatypes.cmx Coqlib.cmx \ - BinPos.cmx Ordered.cmi -OrderedType.cmo: Specif.cmi Datatypes.cmi OrderedType.cmi -OrderedType.cmx: Specif.cmx Datatypes.cmx OrderedType.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 \ - Parallelmove.cmi -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 -PPCgen.cmo: Specif.cmi PPC.cmi Op.cmi Mach.cmi Locations.cmi Integers.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 \ - Errors.cmx Datatypes.cmx Coqlib.cmx CString.cmx CList.cmx Bool.cmx \ - BinPos.cmx BinInt.cmx Ascii.cmx AST.cmx PPCgen.cmi -PPC.cmo: Values.cmi Specif.cmi Mem.cmi Maps.cmi Integers.cmi Globalenvs.cmi \ - Floats.cmi Datatypes.cmi Coqlib.cmi CList.cmi BinPos.cmi BinInt.cmi \ - AST.cmi PPC.cmi -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 -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 Integers.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 Integers.cmx Datatypes.cmx Conventions.cmx CList.cmx AST.cmx \ - Reload.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 Cminor.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 Cminor.cmx CString.cmx CList.cmx BinPos.cmx Ascii.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 -RTLtyping.cmo: Specif.cmi Registers.cmi ../caml/RTLtypingaux.cmo RTL.cmi \ - Op.cmi Maps.cmi Errors.cmi Datatypes.cmi Coqlib.cmi Conventions.cmi \ - CString.cmi CList.cmi Ascii.cmi AST.cmi RTLtyping.cmi -RTLtyping.cmx: Specif.cmx Registers.cmx ../caml/RTLtypingaux.cmx RTL.cmx \ - Op.cmx Maps.cmx Errors.cmx Datatypes.cmx Coqlib.cmx Conventions.cmx \ - CString.cmx CList.cmx Ascii.cmx AST.cmx RTLtyping.cmi -Selection.cmo: Specif.cmi Op.cmi Integers.cmi Datatypes.cmi Compare_dec.cmi \ - CminorSel.cmi Cminor.cmi ../caml/Clflags.cmo 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 ../caml/Clflags.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 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: Specif.cmi Integers.cmi EqNat.cmi Datatypes.cmi Coqlib.cmi \ - CList.cmi BinPos.cmi BinInt.cmi Switch.cmi -Switch.cmx: Specif.cmx Integers.cmx EqNat.cmx Datatypes.cmx Coqlib.cmx \ - CList.cmx BinPos.cmx BinInt.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 \ - BinPos.cmi BinInt.cmi AST.cmi Values.cmi -Values.cmx: Specif.cmx Integers.cmx Floats.cmx Datatypes.cmx Coqlib.cmx \ - BinPos.cmx BinInt.cmx AST.cmx Values.cmi -Wf.cmo: Wf.cmi -Wf.cmx: Wf.cmi -ZArith_dec.cmo: Sumbool.cmi Specif.cmi Datatypes.cmi BinInt.cmi \ - ZArith_dec.cmi -ZArith_dec.cmx: Sumbool.cmx Specif.cmx Datatypes.cmx BinInt.cmx \ - ZArith_dec.cmi -Zbool.cmo: Zeven.cmi ZArith_dec.cmi Sumbool.cmi Specif.cmi Datatypes.cmi \ - BinInt.cmi Zbool.cmi -Zbool.cmx: Zeven.cmx ZArith_dec.cmx Sumbool.cmx Specif.cmx Datatypes.cmx \ - BinInt.cmx Zbool.cmi -Zdiv.cmo: Zbool.cmi ZArith_dec.cmi Specif.cmi Datatypes.cmi BinPos.cmi \ - BinInt.cmi Zdiv.cmi -Zdiv.cmx: Zbool.cmx ZArith_dec.cmx Specif.cmx Datatypes.cmx BinPos.cmx \ - BinInt.cmx Zdiv.cmi -Zeven.cmo: Specif.cmi Datatypes.cmi BinPos.cmi BinInt.cmi Zeven.cmi -Zeven.cmx: Specif.cmx Datatypes.cmx BinPos.cmx BinInt.cmx Zeven.cmi -Zmax.cmo: Datatypes.cmi BinInt.cmi Zmax.cmi -Zmax.cmx: Datatypes.cmx BinInt.cmx Zmax.cmi -Zmisc.cmo: Datatypes.cmi BinPos.cmi BinInt.cmi Zmisc.cmi -Zmisc.cmx: Datatypes.cmx BinPos.cmx BinInt.cmx Zmisc.cmi -Zpower.cmo: Zmisc.cmi Datatypes.cmi BinPos.cmi BinInt.cmi Zpower.cmi -Zpower.cmx: Zmisc.cmx Datatypes.cmx BinPos.cmx BinInt.cmx Zpower.cmi diff --git a/extraction/Kildall.ml.patch b/extraction/Kildall.ml.patch index a5b7bc9..453d40c 100644 --- a/extraction/Kildall.ml.patch +++ b/extraction/Kildall.ml.patch @@ -1,5 +1,5 @@ -*** Kildall.ml.orig 2006-09-11 13:50:56.266682206 +0200 ---- Kildall.ml 2006-09-11 14:29:50.392200227 +0200 +*** kildall.ml.orig 2006-09-11 13:50:56.266682206 +0200 +--- kildall.ml 2006-09-11 14:29:50.392200227 +0200 *************** *** 163,171 **** Maps.PMap.t option **) diff --git a/extraction/Makefile b/extraction/Makefile index 044f89f..d4163bb 100644 --- a/extraction/Makefile +++ b/extraction/Makefile @@ -12,66 +12,15 @@ include ../Makefile.config -FILES=\ - 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 Errors.ml AST.ml Iteration.ml Integers.ml \ - ../caml/Camlcoq.ml ../caml/Floataux.ml Floats.ml Parmov.ml Values.ml \ - Mem.ml Globalenvs.ml \ - ../caml/Clflags.ml \ - Csyntax.ml Ctyping.ml Cminor.ml Csharpminor.ml Cshmgen.ml \ - Cminorgen.ml \ - Op.ml CminorSel.ml \ - Selection.ml \ - Registers.ml RTL.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 LTLin.ml \ - InterfGraph.ml ../caml/Coloringaux.ml Coloring.ml \ - Allocation.ml \ - Tunneling.ml Linear.ml ../caml/Linearizeaux.ml Linearize.ml \ - Parallelmove.ml Reload.ml \ - Mach.ml Bounds.ml Stacking.ml \ - PPC.ml PPCgen.ml \ - Main.ml \ - ../caml/PrintCsyntax.ml ../caml/Cil2Csyntax.ml \ - ../caml/CMparser.ml ../caml/CMlexer.ml ../caml/CMtypecheck.ml \ - ../caml/PrintPPC.ml \ - ../caml/Configuration.ml ../caml/Driver.ml +DIRS=lib common $(ARCH)/$(VARIANT) $(ARCH) backend cfrontend driver -EXTRACTEDFILES:=$(filter-out ../caml/%, $(FILES)) -GENFILES:=$(EXTRACTEDFILES) $(EXTRACTEDFILES:.ml=.mli) - -CAMLINCL=-I ../caml -I ../cil/obj/$(ARCHOS) -OCAMLC=ocamlc -g $(CAMLINCL) -OCAMLOPT=ocamlopt $(CAMLINCL) -OCAMLDEP=ocamldep $(CAMLINCL) -OCAMLLIBS=unix.cma str.cma cil.cma - -COQINCL=-I ../lib -I ../common -I ../backend -I ../cfrontend +COQINCL=$(patsubst %,-I ../%,$(DIRS)) COQEXEC=coqtop $(COQINCL) -batch -load-vernac-source -executables: ../ccomp ../ccomp.byt - -../ccomp.byt: $(FILES:.ml=.cmo) - $(OCAMLC) -o ../ccomp.byt $(OCAMLLIBS) $(FILES:.ml=.cmo) -clean:: - rm -f ../ccomp.byt - -../ccomp: $(FILES:.ml=.cmx) - $(OCAMLOPT) -o ../ccomp $(OCAMLLIBS:.cma=.cmxa) $(FILES:.ml=.cmx) -clean:: - rm -f ../ccomp +all: Configuration.ml extraction extraction: - @rm -f $(GENFILES) + rm -f [:lower:]*.mli [:lower:]*.ml $(COQEXEC) extraction.v @echo "Fixing file names..." @mv list.ml CList.ml @@ -80,61 +29,19 @@ extraction: @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, String -> CString, Int -> CInt..." - @./convert $(GENFILES) + @./convert *.mli *.ml @echo "Patching files..." @for i in *.patch; do patch < $$i; done -../caml/CMparser.ml ../caml/CMparser.mli: ../caml/CMparser.mly - ocamlyacc -v ../caml/CMparser.mly - -beforedepend:: ../caml/CMparser.ml ../caml/CMparser.mli -clean:: - rm -f ../caml/CMparser.ml ../caml/CMparser.mli ../caml/CMparser.output - -../caml/CMlexer.ml: ../caml/CMlexer.mll - ocamllex ../caml/CMlexer.mll - -beforedepend:: ../caml/CMlexer.ml -clean:: - rm -f ../caml/CMlexer.ml - -../caml/Configuration.ml: ../Makefile.config +Configuration.ml: ../Makefile.config (echo 'let stdlib_path = "$(LIBDIR)"'; \ echo 'let prepro = "$(CPREPRO)"'; \ echo 'let asm = "$(CASM)"'; \ - echo 'let linker = "$(CLINKER)"') \ - > ../caml/Configuration.ml - -beforedepend:: ../caml/Configuration.ml -clean:: - rm -f ../caml/Configuration.ml - -.SUFFIXES: .ml .mli .cmo .cmi .cmx - -.mli.cmi: - $(OCAMLC) -c $*.mli -.ml.cmo: - $(OCAMLC) -c $*.ml -.ml.cmx: - $(OCAMLOPT) -c $*.ml - -clean:: - rm -f $(GENFILES) - rm -f *.cm? *.o - cd ../caml && rm -f *.cm? *.o - -depend: beforedepend - $(OCAMLDEP) ../caml/*.mli ../caml/*.ml *.mli *.ml > .depend - -install: - install -d $(BINDIR) - install ../ccomp ../ccomp.byt $(BINDIR) - -include .depend - + echo 'let linker = "$(CLINKER)"'; \ + echo 'let arch = "$(ARCH)"'; \ + echo 'let variant = "$(VARIANT)"') \ + > Configuration.ml +clean: + rm -f *.mli *.ml diff --git a/extraction/extraction.v b/extraction/extraction.v index cdb1fd6..58da9c0 100644 --- a/extraction/extraction.v +++ b/extraction/extraction.v @@ -16,7 +16,7 @@ Require Floats. Require RTLgen. Require Coloring. Require Allocation. -Require Main. +Require Compiler. (* Standard lib *) Extract Inductive unit => "unit" [ "()" ]. @@ -68,16 +68,18 @@ Extract Constant Coloring.graph_coloring => "Coloringaux.graph_coloring". (* Linearize *) Extract Constant Linearize.enumerate_aux => "Linearizeaux.enumerate_aux". -(* PPC *) -Extract Constant PPC.low_half => "fun _ -> assert false". -Extract Constant PPC.high_half => "fun _ -> assert false". +(* Asm *) +Extract Constant Asm.low_half => "fun _ -> assert false". +Extract Constant Asm.high_half => "fun _ -> assert false". (* Suppression of stupidly big equality functions *) -Extract Constant CSE.eq_rhs => "fun (x: rhs) (y: rhs) -> x = y". -Extract Constant Locations.mreg_eq => "fun (x: mreg) (y: mreg) -> x = y". -Extract Constant PPC.ireg_eq => "fun (x: ireg) (y: ireg) -> x = y". -Extract Constant PPC.freg_eq => "fun (x: freg) (y: freg) -> x = y". -Extract Constant PPC.preg_eq => "fun (x: preg) (y: preg) -> x = y". +Extract Constant Op.eq_operation => "fun (x: operation) (y: operation) -> x = y". +Extract Constant Op.eq_addressing => "fun (x: addressing) (y: addressing) -> x = y". +(*Extract Constant CSE.eq_rhs => "fun (x: rhs) (y: rhs) -> x = y".*) +Extract Constant Machregs.mreg_eq => "fun (x: mreg) (y: mreg) -> x = y". +Extract Constant Asm.ireg_eq => "fun (x: ireg) (y: ireg) -> x = y". +Extract Constant Asm.freg_eq => "fun (x: freg) (y: freg) -> x = y". +Extract Constant Asm.preg_eq => "fun (x: preg) (y: preg) -> x = y". (* Go! *) -Recursive Extraction Library Main. +Recursive Extraction Library Compiler. diff --git a/lib/Camlcoq.ml b/lib/Camlcoq.ml new file mode 100644 index 0000000..98fd79c --- /dev/null +++ b/lib/Camlcoq.ml @@ -0,0 +1,130 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(* Library of useful Caml <-> Coq conversions *) + +open Datatypes +open CList +open BinPos +open BinInt + +(* Integers *) + +let rec camlint_of_positive = function + | Coq_xI p -> Int32.add (Int32.shift_left (camlint_of_positive p) 1) 1l + | Coq_xO p -> Int32.shift_left (camlint_of_positive p) 1 + | Coq_xH -> 1l + +let camlint_of_z = function + | Z0 -> 0l + | Zpos p -> camlint_of_positive p + | Zneg p -> Int32.neg (camlint_of_positive p) + +let camlint_of_coqint : Integers.int -> int32 = camlint_of_z + +let rec camlint_of_nat = function + | O -> 0 + | S n -> camlint_of_nat n + 1 + +let rec nat_of_camlint n = + assert (n >= 0l); + if n = 0l then O else S (nat_of_camlint (Int32.sub n 1l)) + +let rec positive_of_camlint n = + if n = 0l then assert false else + if n = 1l then Coq_xH else + if Int32.logand n 1l = 0l + then Coq_xO (positive_of_camlint (Int32.shift_right_logical n 1)) + else Coq_xI (positive_of_camlint (Int32.shift_right_logical n 1)) + +let z_of_camlint n = + if n = 0l then Z0 else + if n > 0l then Zpos (positive_of_camlint n) + else Zneg (positive_of_camlint (Int32.neg n)) + +let coqint_of_camlint (n: int32) : Integers.int = + (* Interpret n as unsigned so that resulting Z is in range *) + if n = 0l then Z0 else Zpos (positive_of_camlint n) + +(* 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) +let next_atom = ref Coq_xH + +let intern_string s = + try + Hashtbl.find atom_of_string s + with Not_found -> + let a = !next_atom in + next_atom := coq_Psucc !next_atom; + Hashtbl.add atom_of_string s a; + Hashtbl.add string_of_atom a s; + a + +let extern_atom a = + try + Hashtbl.find string_of_atom a + with Not_found -> + Printf.sprintf "" (camlint_of_positive a) + +(* 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 *) + +(* +let timers = (Hashtbl.create 9 : (string, float) Hashtbl.t) + +let add_to_timer name time = + let old = try Hashtbl.find timers name with Not_found -> 0.0 in + Hashtbl.replace timers name (old +. time) + +let time name fn arg = + let start = Unix.gettimeofday() in + try + let res = fn arg in + add_to_timer name (Unix.gettimeofday() -. start); + res + with x -> + add_to_timer name (Unix.gettimeofday() -. start); + raise x + +let print_timers () = + Hashtbl.iter + (fun name time -> Printf.printf "%-20s %.3f\n" name time) + timers + +let _ = at_exit print_timers +*) diff --git a/lib/Floataux.ml b/lib/Floataux.ml new file mode 100644 index 0000000..6b3b825 --- /dev/null +++ b/lib/Floataux.ml @@ -0,0 +1,39 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +open Camlcoq +open Integers + +let singleoffloat f = + Int32.float_of_bits (Int32.bits_of_float f) + +let intoffloat f = + coqint_of_camlint (Int32.of_float f) + +let intuoffloat f = + coqint_of_camlint (Int64.to_int32 (Int64.of_float f)) + +let floatofint i = + Int32.to_float (camlint_of_coqint i) + +let floatofintu i = + Int64.to_float (Int64.logand (Int64.of_int32 (camlint_of_coqint i)) + 0xFFFFFFFFL) + +let cmp c (x: float) (y: float) = + match c with + | Ceq -> x = y + | Cne -> x <> y + | Clt -> x < y + | Cle -> x <= y + | Cgt -> x > y + | Cge -> x >= y diff --git a/powerpc/Asm.v b/powerpc/Asm.v new file mode 100644 index 0000000..7be155b --- /dev/null +++ b/powerpc/Asm.v @@ -0,0 +1,880 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Abstract syntax and semantics for PowerPC assembly language *) + +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 Smallstep. +Require Import Locations. +Require Stacklayout. +Require Conventions. + +(** * Abstract syntax *) + +(** Integer registers, floating-point registers. *) + +Inductive ireg: Set := + | GPR0: ireg | GPR1: ireg | GPR2: ireg | GPR3: ireg + | GPR4: ireg | GPR5: ireg | GPR6: ireg | GPR7: ireg + | GPR8: ireg | GPR9: ireg | GPR10: ireg | GPR11: ireg + | GPR12: ireg | GPR13: ireg | GPR14: ireg | GPR15: ireg + | GPR16: ireg | GPR17: ireg | GPR18: ireg | GPR19: ireg + | GPR20: ireg | GPR21: ireg | GPR22: ireg | GPR23: ireg + | GPR24: ireg | GPR25: ireg | GPR26: ireg | GPR27: ireg + | GPR28: ireg | GPR29: ireg | GPR30: ireg | GPR31: ireg. + +Inductive freg: Set := + | FPR0: freg | FPR1: freg | FPR2: freg | FPR3: freg + | FPR4: freg | FPR5: freg | FPR6: freg | FPR7: freg + | FPR8: freg | FPR9: freg | FPR10: freg | FPR11: freg + | FPR12: freg | FPR13: freg | FPR14: freg | FPR15: freg + | FPR16: freg | FPR17: freg | FPR18: freg | FPR19: freg + | FPR20: freg | FPR21: freg | FPR22: freg | FPR23: freg + | FPR24: freg | FPR25: freg | FPR26: freg | FPR27: freg + | FPR28: freg | FPR29: freg | FPR30: freg | FPR31: freg. + +Lemma ireg_eq: forall (x y: ireg), {x=y} + {x<>y}. +Proof. decide equality. Defined. + +Lemma freg_eq: forall (x y: freg), {x=y} + {x<>y}. +Proof. decide equality. Defined. + +(** Symbolic constants. Immediate operands to an arithmetic instruction + or an indexed memory access can be either integer literals + or the low or high 16 bits of a symbolic reference (the address + of a symbol plus a displacement). These symbolic references are + resolved later by the linker. +*) + +Inductive constant: Set := + | Cint: int -> constant + | Csymbol_low: ident -> int -> constant + | Csymbol_high: ident -> int -> constant. + +(** A note on constants: while immediate operands to PowerPC + instructions must be representable in 16 bits (with + sign extension or left shift by 16 positions for some instructions), + we do not attempt to capture these restrictions in the + abstract syntax nor in the semantics. The assembler will + emit an error if immediate operands exceed the representable + range. Of course, our PPC generator (file [PPCgen]) is + careful to respect this range. *) + +(** Bits in the condition register. We are only interested in the + first 4 bits. *) + +Inductive crbit: Set := + | CRbit_0: crbit + | CRbit_1: crbit + | CRbit_2: crbit + | CRbit_3: crbit. + +(** The instruction set. Most instructions correspond exactly to + actual instructions of the PowerPC processor. See the PowerPC + reference manuals for more details. Some instructions, + described below, are pseudo-instructions: they expand to + canned instruction sequences during the printing of the assembly + code. *) + +Definition label := positive. + +Inductive instruction : Set := + | Padd: ireg -> ireg -> ireg -> instruction (**r integer addition *) + | Paddi: ireg -> ireg -> constant -> instruction (**r add immediate *) + | Paddis: ireg -> ireg -> constant -> instruction (**r add immediate high *) + | Paddze: ireg -> ireg -> instruction (**r add Carry bit *) + | Pallocblock: instruction (**r allocate new heap block *) + | Pallocframe: Z -> Z -> int -> instruction (**r allocate new stack frame *) + | Pand_: ireg -> ireg -> ireg -> instruction (**r bitwise and *) + | Pandc: ireg -> ireg -> ireg -> instruction (**r bitwise and-complement *) + | Pandi_: ireg -> ireg -> constant -> instruction (**r and immediate and set conditions *) + | Pandis_: ireg -> ireg -> constant -> instruction (**r and immediate high and set conditions *) + | Pb: label -> instruction (**r unconditional branch *) + | Pbctr: instruction (**r branch to contents of register CTR *) + | 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 *) + | 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 *) + | Pcmpw: ireg -> ireg -> instruction (**r signed integer comparison *) + | Pcmpwi: ireg -> constant -> instruction (**r same, with immediate argument *) + | Pcror: crbit -> crbit -> crbit -> instruction (**r or between condition bits *) + | Pdivw: ireg -> ireg -> ireg -> instruction (**r signed division *) + | Pdivwu: ireg -> ireg -> ireg -> instruction (**r unsigned division *) + | Peqv: ireg -> ireg -> ireg -> instruction (**r bitwise not-xor *) + | Pextsb: ireg -> ireg -> instruction (**r 8-bit sign extension *) + | Pextsh: ireg -> ireg -> instruction (**r 16-bit sign extension *) + | Pfreeframe: int -> instruction (**r deallocate stack frame and restore previous frame *) + | Pfabs: freg -> freg -> instruction (**r float absolute value *) + | Pfadd: freg -> freg -> freg -> instruction (**r float addition *) + | Pfcmpu: freg -> freg -> instruction (**r float comparison *) + | Pfcti: ireg -> freg -> instruction (**r float-to-signed-int conversion *) + | Pfctiu: ireg -> freg -> instruction (**r float-to-unsigned-int conversion *) + | Pfdiv: freg -> freg -> freg -> instruction (**r float division *) + | Pfmadd: freg -> freg -> freg -> freg -> instruction (**r float multiply-add *) + | Pfmr: freg -> freg -> instruction (**r float move *) + | Pfmsub: freg -> freg -> freg -> freg -> instruction (**r float multiply-sub *) + | Pfmul: freg -> freg -> freg -> instruction (**r float multiply *) + | Pfneg: freg -> freg -> instruction (**r float negation *) + | Pfrsp: freg -> freg -> instruction (**r float round to single precision *) + | Pfsub: freg -> freg -> freg -> instruction (**r float subtraction *) + | Pictf: freg -> ireg -> instruction (**r int-to-float conversion *) + | Piuctf: freg -> ireg -> instruction (**r unsigned int-to-float conversion *) + | Plbz: ireg -> constant -> ireg -> instruction (**r load 8-bit unsigned int *) + | Plbzx: ireg -> ireg -> ireg -> instruction (**r same, with 2 index regs *) + | Plfd: freg -> constant -> ireg -> instruction (**r load 64-bit float *) + | Plfdx: freg -> ireg -> ireg -> instruction (**r same, with 2 index regs *) + | Plfs: freg -> constant -> ireg -> instruction (**r load 32-bit float *) + | Plfsx: freg -> ireg -> ireg -> instruction (**r same, with 2 index regs *) + | Plha: ireg -> constant -> ireg -> instruction (**r load 16-bit signed int *) + | Plhax: ireg -> ireg -> ireg -> instruction (**r same, with 2 index regs *) + | Plhz: ireg -> constant -> ireg -> instruction (**r load 16-bit unsigned int *) + | Plhzx: ireg -> ireg -> ireg -> instruction (**r same, with 2 index regs *) + | Plfi: freg -> float -> instruction (**r load float constant *) + | Plwz: ireg -> constant -> ireg -> instruction (**r load 32-bit int *) + | Plwzx: ireg -> ireg -> ireg -> instruction (**r same, with 2 index regs *) + | Pmfcrbit: ireg -> crbit -> instruction (**r move condition bit to reg *) + | Pmflr: ireg -> instruction (**r move LR to reg *) + | Pmr: ireg -> ireg -> instruction (**r integer move *) + | Pmtctr: ireg -> instruction (**r move ireg to CTR *) + | Pmtlr: ireg -> instruction (**r move ireg to LR *) + | Pmulli: ireg -> ireg -> constant -> instruction (**r integer multiply immediate *) + | Pmullw: ireg -> ireg -> ireg -> instruction (**r integer multiply *) + | Pnand: ireg -> ireg -> ireg -> instruction (**r bitwise not-and *) + | Pnor: ireg -> ireg -> ireg -> instruction (**r bitwise not-or *) + | Por: ireg -> ireg -> ireg -> instruction (**r bitwise or *) + | Porc: ireg -> ireg -> ireg -> instruction (**r bitwise or-complement *) + | Pori: ireg -> ireg -> constant -> instruction (**r or with immediate *) + | Poris: ireg -> ireg -> constant -> instruction (**r or with immediate high *) + | Prlwinm: ireg -> ireg -> int -> int -> instruction (**r rotate and mask *) + | Pslw: ireg -> ireg -> ireg -> instruction (**r shift left *) + | Psraw: ireg -> ireg -> ireg -> instruction (**r shift right signed *) + | Psrawi: ireg -> ireg -> int -> instruction (**r shift right signed immediate *) + | Psrw: ireg -> ireg -> ireg -> instruction (**r shift right unsigned *) + | Pstb: ireg -> constant -> ireg -> instruction (**r store 8-bit int *) + | Pstbx: ireg -> ireg -> ireg -> instruction (**r same, with 2 index regs *) + | Pstfd: freg -> constant -> ireg -> instruction (**r store 64-bit float *) + | Pstfdx: freg -> ireg -> ireg -> instruction (**r same, with 2 index regs *) + | Pstfs: freg -> constant -> ireg -> instruction (**r store 32-bit float *) + | Pstfsx: freg -> ireg -> ireg -> instruction (**r same, with 2 index regs *) + | Psth: ireg -> constant -> ireg -> instruction (**r store 16-bit int *) + | Psthx: ireg -> ireg -> ireg -> instruction (**r same, with 2 index regs *) + | Pstw: ireg -> constant -> ireg -> instruction (**r store 32-bit int *) + | Pstwx: ireg -> ireg -> ireg -> instruction (**r same, with 2 index regs *) + | Psubfc: ireg -> ireg -> ireg -> instruction (**r reversed integer subtraction *) + | Psubfic: ireg -> ireg -> constant -> instruction (**r integer subtraction from immediate *) + | 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 *) + | 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: +<< + addis r2, 0, ha16(lbl) + lfd rdst, lo16(lbl)(r2) + .const_data +lbl: .double floatcst + .text +>> + 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 a signed 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: +<< + fctiwz f13, rsrc + stfdu f13, -8(r1) + lwz rdst, 4(r1) + addi r1, r1, 8 +>> +- [Pfctiu]: convert a float to an unsigned integer. The PowerPC way + to do this is to compare the argument against the floating-point + constant [2^31], subtract [2^31] if bigger, then convert to a signed + integer as above, then add back [2^31] if needed. Expands to: +<< + addis r2, 0, ha16(lbl1) + lfd f13, lo16(lbl1)(r2) + fcmpu cr7, rsrc, f13 + cror 30, 29, 30 + beq cr7, lbl2 + fctiwz f13, rsrc + stfdu f13, -8(r1) + lwz rdst, 4(r1) + b lbl3 +lbl2: fsub f13, rsrc, f13 + fctiwz f13, f13 + stfdu f13, -8(r1) + lwz rdst, 4(r1) + addis rdst, rdst, 0x8000 +lbl3: addi r1, r1, 8 + .const_data +lbl1: .long 0x41e00000, 0x00000000 # 2^31 in double precision + .text +>> +- [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 + of floats cannot express. Expands to: +<< + addis r2, 0, 0x4330 + stwu r2, -8(r1) + addis r2, rsrc, 0x8000 + stw r2, 4(r1) + addis r2, 0, ha16(lbl) + lfd f13, lo16(lbl)(r2) + lfd rdst, 0(r1) + addi r1, r1, 8 + fsub rdst, rdst, f13 + .const_data +lbl: .long 0x43300000, 0x80000000 + .text +>> + (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. +<< + addis r2, 0, 0x4330 + stwu r2, -8(r1) + stw rsrc, 4(r1) + addis r2, 0, ha16(lbl) + lfd f13, lo16(lbl)(r2) + lfd rdst, 0(r1) + addi r1, r1, 8 + fsub rdst, rdst, f13 + .const_data +lbl: .long 0x43300000, 0x00000000 + .text +>> +- [Pallocframe lo hi ofs]: 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 offset [ofs] + in this block, and sets [r1] to a pointer to the bottom of this + block. In the printed PowerPC assembly code, this allocation + is just a store-decrement of register [r1], assuming that [ofs = 0]: +<< + stwu r1, (lo - hi)(r1) +>> + This cannot be expressed in our memory model, which does not reflect + the fact that stack frames are adjacent and allocated/freed + following a stack discipline. +- [Pfreeframe ofs]: in the formal semantics, this pseudo-instruction + reads the word at offset [ofs] in the block pointed by [r1] (the + stack pointer), frees this block, and sets [r1] to the value of the + word at offset [ofs]. In the printed PowerPC assembly code, this + freeing is just a load of register [r1] relative to [r1] itself: +<< + lwz r1, ofs(r1) +>> + 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. +*) + +Definition code := list instruction. +Definition fundef := AST.fundef code. +Definition program := AST.program fundef unit. + +(** * Operational semantics *) + +(** The PowerPC has a great many registers, some general-purpose, some very + specific. We model only the following registers: *) + +Inductive preg: Set := + | IR: ireg -> preg (**r integer registers *) + | FR: freg -> preg (**r float registers *) + | PC: preg (**r program counter *) + | LR: preg (**r link register (return address) *) + | CTR: preg (**r count register, used for some branches *) + | CARRY: preg (**r carry bit of the status register *) + | CR0_0: preg (**r bit 0 of the condition register *) + | CR0_1: preg (**r bit 1 of the condition register *) + | CR0_2: preg (**r bit 2 of the condition register *) + | CR0_3: preg. (**r bit 3 of the condition register *) + +Coercion IR: ireg >-> preg. +Coercion FR: freg >-> preg. + +Lemma preg_eq: forall (x y: preg), {x=y} + {x<>y}. +Proof. decide equality. apply ireg_eq. apply freg_eq. Defined. + +Module PregEq. + Definition t := preg. + Definition eq := preg_eq. +End PregEq. + +Module Pregmap := EMap(PregEq). + +(** The semantics operates over a single mapping from registers + (type [preg]) to values. We maintain (but do not enforce) + the convention that integer registers are mapped to values of + type [Tint], float registers to values of type [Tfloat], + and boolean registers ([CARRY], [CR0_0], etc) to either + [Vzero] or [Vone]. *) + +Definition regset := Pregmap.t val. +Definition genv := Genv.t fundef. + +Notation "a # b" := (a b) (at level 1, only parsing). +Notation "a # b <- c" := (Pregmap.set b c a) (at level 1, b at next level). + +Section RELSEM. + +(** Looking up instructions in a code sequence by position. *) + +Fixpoint find_instr (pos: Z) (c: code) {struct c} : option instruction := + match c with + | nil => None + | i :: il => if zeq pos 0 then Some i else find_instr (pos - 1) il + end. + +(** Position corresponding to a label *) + +Definition is_label (lbl: label) (instr: instruction) : bool := + match instr with + | Plabel 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 = Plabel lbl else instr <> Plabel lbl. +Proof. + intros. destruct instr; simpl; try discriminate. + case (peq lbl l); intro; congruence. +Qed. + +Fixpoint label_pos (lbl: label) (pos: Z) (c: code) {struct c} : option Z := + match c with + | nil => None + | instr :: c' => + if is_label lbl instr then Some (pos + 1) else label_pos lbl (pos + 1) c' + end. + +(** Some PowerPC instructions treat register GPR0 as the integer literal 0 + when that register is used in argument position. *) + +Definition gpr_or_zero (rs: regset) (r: ireg) := + if ireg_eq r GPR0 then Vzero else rs#r. + +Variable ge: genv. + +Definition symbol_offset (id: ident) (ofs: int) : val := + match Genv.find_symbol ge id with + | Some b => Vptr b ofs + | None => Vundef + end. + +(** The four functions below axiomatize how the linker processes + symbolic references [symbol + offset] and splits their + actual values into two 16-bit halves. *) + +Parameter low_half: val -> val. +Parameter high_half: val -> val. + +(** The fundamental property of these operations is that, when applied + to the address of a symbol, their results can be recombined by + addition, rebuilding the original address. *) + +Axiom low_high_half: + forall id ofs, + Val.add (low_half (symbol_offset id ofs)) (high_half (symbol_offset id ofs)) + = symbol_offset id ofs. + +(** The other axioms we take is that the results of + the [low_half] and [high_half] functions are of type [Tint], + i.e. either integers, pointers or undefined values. *) + +Axiom low_half_type: + forall v, Val.has_type (low_half v) Tint. +Axiom high_half_type: + forall v, Val.has_type (high_half v) Tint. + +(** Armed with the [low_half] and [high_half] functions, + we can define the evaluation of a symbolic constant. + Note that for [const_high], integer constants + are shifted left by 16 bits, but not symbol addresses: + we assume (as in the [low_high_half] axioms above) + that the results of [high_half] are already shifted + (their 16 low bits are equal to 0). *) + +Definition const_low (c: constant) := + match c with + | Cint n => Vint n + | Csymbol_low id ofs => low_half (symbol_offset id ofs) + | Csymbol_high id ofs => Vundef + end. + +Definition const_high (c: constant) := + match c with + | Cint n => Vint (Int.shl n (Int.repr 16)) + | Csymbol_low id ofs => Vundef + | Csymbol_high id ofs => high_half (symbol_offset id ofs) + end. + +(** The semantics is purely small-step and defined as a function + from the current state (a register set + a memory state) + to either [OK rs' m'] where [rs'] and [m'] are the updated register + set and memory state after execution of the instruction at [rs#PC], + or [Error] if the processor is stuck. *) + +Inductive outcome: Set := + | OK: regset -> mem -> outcome + | Error: outcome. + +(** Manipulations over the [PC] register: continuing with the next + instruction ([nextinstr]) or branching to a label ([goto_label]). *) + +Definition nextinstr (rs: regset) := + rs#PC <- (Val.add rs#PC Vone). + +Definition goto_label (c: code) (lbl: label) (rs: regset) (m: mem) := + match label_pos lbl 0 c with + | None => Error + | Some pos => + match rs#PC with + | Vptr b ofs => OK (rs#PC <- (Vptr b (Int.repr pos))) m + | _ => Error + end + end. + +(** Auxiliaries for memory accesses, in two forms: one operand + (plus constant offset) or two operands. *) + +Definition load1 (chunk: memory_chunk) (rd: preg) + (cst: constant) (r1: ireg) (rs: regset) (m: mem) := + match Mem.loadv chunk m (Val.add (gpr_or_zero rs r1) (const_low cst)) with + | None => Error + | Some v => OK (nextinstr (rs#rd <- v)) m + end. + +Definition load2 (chunk: memory_chunk) (rd: preg) (r1 r2: ireg) + (rs: regset) (m: mem) := + match Mem.loadv chunk m (Val.add rs#r1 rs#r2) with + | None => Error + | Some v => OK (nextinstr (rs#rd <- v)) m + end. + +Definition store1 (chunk: memory_chunk) (r: preg) + (cst: constant) (r1: ireg) (rs: regset) (m: mem) := + match Mem.storev chunk m (Val.add (gpr_or_zero rs r1) (const_low cst)) (rs#r) with + | None => Error + | Some m' => OK (nextinstr rs) m' + end. + +Definition store2 (chunk: memory_chunk) (r: preg) (r1 r2: ireg) + (rs: regset) (m: mem) := + match Mem.storev chunk m (Val.add rs#r1 rs#r2) (rs#r) with + | None => Error + | Some m' => OK (nextinstr rs) m' + end. + +(** Operations over condition bits. *) + +Definition reg_of_crbit (bit: crbit) := + match bit with + | CRbit_0 => CR0_0 + | CRbit_1 => CR0_1 + | CRbit_2 => CR0_2 + | CRbit_3 => CR0_3 + end. + +Definition compare_sint (rs: regset) (v1 v2: val) := + rs#CR0_0 <- (Val.cmp Clt v1 v2) + #CR0_1 <- (Val.cmp Cgt v1 v2) + #CR0_2 <- (Val.cmp Ceq v1 v2) + #CR0_3 <- Vundef. + +Definition compare_uint (rs: regset) (v1 v2: val) := + rs#CR0_0 <- (Val.cmpu Clt v1 v2) + #CR0_1 <- (Val.cmpu Cgt v1 v2) + #CR0_2 <- (Val.cmpu Ceq v1 v2) + #CR0_3 <- Vundef. + +Definition compare_float (rs: regset) (v1 v2: val) := + rs#CR0_0 <- (Val.cmpf Clt v1 v2) + #CR0_1 <- (Val.cmpf Cgt v1 v2) + #CR0_2 <- (Val.cmpf Ceq v1 v2) + #CR0_3 <- Vundef. + +Definition val_cond_reg (rs: regset) := + Val.or (Val.shl rs#CR0_0 (Vint (Int.repr 31))) + (Val.or (Val.shl rs#CR0_1 (Vint (Int.repr 30))) + (Val.or (Val.shl rs#CR0_2 (Vint (Int.repr 29))) + (Val.shl rs#CR0_3 (Vint (Int.repr 28))))). + +(** Execution of a single instruction [i] in initial state + [rs] and [m]. Return updated state. For instructions + that correspond to actual PowerPC instructions, the cases are + straightforward transliterations of the informal descriptions + given in the PowerPC reference manuals. For pseudo-instructions, + refer to the informal descriptions given above. Note that + we set to [Vundef] the registers used as temporaries by the + expansions of the pseudo-instructions, so that the PPC code + we generate cannot use those registers to hold values that + must survive the execution of the pseudo-instruction. +*) + +Definition exec_instr (c: code) (i: instruction) (rs: regset) (m: mem) : outcome := + match i with + | Padd rd r1 r2 => + OK (nextinstr (rs#rd <- (Val.add rs#r1 rs#r2))) m + | Paddi rd r1 cst => + OK (nextinstr (rs#rd <- (Val.add (gpr_or_zero rs r1) (const_low cst)))) m + | Paddis rd r1 cst => + OK (nextinstr (rs#rd <- (Val.add (gpr_or_zero rs r1) (const_high cst)))) m + | Paddze rd r1 => + OK (nextinstr (rs#rd <- (Val.add rs#r1 rs#CARRY))) m + | Pallocblock => + match rs#GPR3 with + | Vint n => + let (m', b) := Mem.alloc m 0 (Int.signed n) in + OK (nextinstr (rs#GPR3 <- (Vptr b Int.zero) + #LR <- (Val.add rs#PC Vone))) m' + | _ => Error + end + | Pallocframe lo hi ofs => + let (m1, stk) := Mem.alloc m lo hi in + let sp := Vptr stk (Int.repr lo) in + match Mem.storev Mint32 m1 (Val.add sp (Vint ofs)) rs#GPR1 with + | None => Error + | Some m2 => OK (nextinstr (rs#GPR1 <- sp #GPR12 <- Vundef)) m2 + end + | Pand_ rd r1 r2 => + let v := Val.and rs#r1 rs#r2 in + OK (nextinstr (compare_sint (rs#rd <- v) v Vzero)) m + | Pandc rd r1 r2 => + OK (nextinstr (rs#rd <- (Val.and rs#r1 (Val.notint rs#r2)))) m + | Pandi_ rd r1 cst => + let v := Val.and rs#r1 (const_low cst) in + OK (nextinstr (compare_sint (rs#rd <- v) v Vzero)) m + | Pandis_ rd r1 cst => + let v := Val.and rs#r1 (const_high cst) in + OK (nextinstr (compare_sint (rs#rd <- v) v Vzero)) m + | Pb lbl => + goto_label c lbl rs m + | Pbctr => + OK (rs#PC <- (rs#CTR)) m + | Pbctrl => + OK (rs#LR <- (Val.add rs#PC Vone) #PC <- (rs#CTR)) m + | Pbf bit lbl => + match rs#(reg_of_crbit bit) with + | Vint n => if Int.eq n Int.zero then goto_label c lbl rs m else OK (nextinstr rs) m + | _ => Error + 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 => + match rs#(reg_of_crbit bit) with + | Vint n => if Int.eq n Int.zero then OK (nextinstr rs) m else goto_label c lbl rs m + | _ => Error + end + | Pcmplw r1 r2 => + OK (nextinstr (compare_uint rs rs#r1 rs#r2)) m + | Pcmplwi r1 cst => + OK (nextinstr (compare_uint rs rs#r1 (const_low cst))) m + | Pcmpw r1 r2 => + OK (nextinstr (compare_sint rs rs#r1 rs#r2)) m + | Pcmpwi r1 cst => + OK (nextinstr (compare_sint rs rs#r1 (const_low cst))) m + | Pcror bd b1 b2 => + OK (nextinstr (rs#(reg_of_crbit bd) <- (Val.or rs#(reg_of_crbit b1) rs#(reg_of_crbit b2)))) m + | Pdivw rd r1 r2 => + OK (nextinstr (rs#rd <- (Val.divs rs#r1 rs#r2))) m + | Pdivwu rd r1 r2 => + OK (nextinstr (rs#rd <- (Val.divu rs#r1 rs#r2))) m + | Peqv rd r1 r2 => + OK (nextinstr (rs#rd <- (Val.notint (Val.xor rs#r1 rs#r2)))) m + | Pextsb rd r1 => + OK (nextinstr (rs#rd <- (Val.sign_ext 8 rs#r1))) m + | Pextsh rd r1 => + OK (nextinstr (rs#rd <- (Val.sign_ext 16 rs#r1))) m + | Pfreeframe ofs => + match Mem.loadv Mint32 m (Val.add rs#GPR1 (Vint ofs)) with + | None => Error + | Some v => + match rs#GPR1 with + | Vptr stk ofs => OK (nextinstr (rs#GPR1 <- v)) (Mem.free m stk) + | _ => Error + end + end + | Pfabs rd r1 => + OK (nextinstr (rs#rd <- (Val.absf rs#r1))) m + | Pfadd rd r1 r2 => + OK (nextinstr (rs#rd <- (Val.addf rs#r1 rs#r2))) m + | Pfcmpu r1 r2 => + OK (nextinstr (compare_float rs rs#r1 rs#r2)) m + | Pfcti rd r1 => + OK (nextinstr (rs#rd <- (Val.intoffloat rs#r1) #FPR13 <- Vundef)) m + | Pfctiu rd r1 => + OK (nextinstr (rs#rd <- (Val.intuoffloat rs#r1) #FPR13 <- Vundef)) m + | Pfdiv rd r1 r2 => + OK (nextinstr (rs#rd <- (Val.divf rs#r1 rs#r2))) m + | Pfmadd rd r1 r2 r3 => + OK (nextinstr (rs#rd <- (Val.addf (Val.mulf rs#r1 rs#r2) rs#r3))) m + | Pfmr rd r1 => + OK (nextinstr (rs#rd <- (rs#r1))) m + | Pfmsub rd r1 r2 r3 => + OK (nextinstr (rs#rd <- (Val.subf (Val.mulf rs#r1 rs#r2) rs#r3))) m + | Pfmul rd r1 r2 => + OK (nextinstr (rs#rd <- (Val.mulf rs#r1 rs#r2))) m + | Pfneg rd r1 => + OK (nextinstr (rs#rd <- (Val.negf rs#r1))) m + | Pfrsp rd r1 => + OK (nextinstr (rs#rd <- (Val.singleoffloat rs#r1))) m + | Pfsub rd r1 r2 => + OK (nextinstr (rs#rd <- (Val.subf rs#r1 rs#r2))) m + | Pictf rd r1 => + OK (nextinstr (rs#rd <- (Val.floatofint rs#r1) #GPR12 <- Vundef #FPR13 <- Vundef)) m + | Piuctf rd r1 => + OK (nextinstr (rs#rd <- (Val.floatofintu rs#r1) #GPR12 <- Vundef #FPR13 <- Vundef)) m + | Plbz rd cst r1 => + load1 Mint8unsigned rd cst r1 rs m + | Plbzx rd r1 r2 => + load2 Mint8unsigned rd r1 r2 rs m + | Plfd rd cst r1 => + load1 Mfloat64 rd cst r1 rs m + | Plfdx rd r1 r2 => + load2 Mfloat64 rd r1 r2 rs m + | Plfs rd cst r1 => + load1 Mfloat32 rd cst r1 rs m + | Plfsx rd r1 r2 => + load2 Mfloat32 rd r1 r2 rs m + | Plha rd cst r1 => + load1 Mint16signed rd cst r1 rs m + | Plhax rd r1 r2 => + load2 Mint16signed rd r1 r2 rs m + | Plhz rd cst r1 => + load1 Mint16unsigned rd cst r1 rs m + | Plhzx rd r1 r2 => + load2 Mint16unsigned rd r1 r2 rs m + | Plfi rd f => + OK (nextinstr (rs#rd <- (Vfloat f) #GPR12 <- Vundef)) m + | Plwz rd cst r1 => + load1 Mint32 rd cst r1 rs m + | Plwzx rd r1 r2 => + load2 Mint32 rd r1 r2 rs m + | Pmfcrbit rd bit => + OK (nextinstr (rs#rd <- (rs#(reg_of_crbit bit)))) m + | Pmflr rd => + OK (nextinstr (rs#rd <- (rs#LR))) m + | Pmr rd r1 => + OK (nextinstr (rs#rd <- (rs#r1))) m + | Pmtctr r1 => + OK (nextinstr (rs#CTR <- (rs#r1))) m + | Pmtlr r1 => + OK (nextinstr (rs#LR <- (rs#r1))) m + | Pmulli rd r1 cst => + OK (nextinstr (rs#rd <- (Val.mul rs#r1 (const_low cst)))) m + | Pmullw rd r1 r2 => + OK (nextinstr (rs#rd <- (Val.mul rs#r1 rs#r2))) m + | Pnand rd r1 r2 => + OK (nextinstr (rs#rd <- (Val.notint (Val.and rs#r1 rs#r2)))) m + | Pnor rd r1 r2 => + OK (nextinstr (rs#rd <- (Val.notint (Val.or rs#r1 rs#r2)))) m + | Por rd r1 r2 => + OK (nextinstr (rs#rd <- (Val.or rs#r1 rs#r2))) m + | Porc rd r1 r2 => + OK (nextinstr (rs#rd <- (Val.or rs#r1 (Val.notint rs#r2)))) m + | Pori rd r1 cst => + OK (nextinstr (rs#rd <- (Val.or rs#r1 (const_low cst)))) m + | Poris rd r1 cst => + OK (nextinstr (rs#rd <- (Val.or rs#r1 (const_high cst)))) m + | Prlwinm rd r1 amount mask => + OK (nextinstr (rs#rd <- (Val.rolm rs#r1 amount mask))) m + | Pslw rd r1 r2 => + OK (nextinstr (rs#rd <- (Val.shl rs#r1 rs#r2))) m + | Psraw rd r1 r2 => + OK (nextinstr (rs#rd <- (Val.shr rs#r1 rs#r2) #CARRY <- (Val.shr_carry rs#r1 rs#r2))) m + | Psrawi rd r1 n => + OK (nextinstr (rs#rd <- (Val.shr rs#r1 (Vint n)) #CARRY <- (Val.shr_carry rs#r1 (Vint n)))) m + | Psrw rd r1 r2 => + OK (nextinstr (rs#rd <- (Val.shru rs#r1 rs#r2))) m + | Pstb rd cst r1 => + store1 Mint8unsigned rd cst r1 rs m + | Pstbx rd r1 r2 => + store2 Mint8unsigned rd r1 r2 rs m + | Pstfd rd cst r1 => + store1 Mfloat64 rd cst r1 rs m + | Pstfdx rd r1 r2 => + store2 Mfloat64 rd r1 r2 rs m + | Pstfs rd cst r1 => + store1 Mfloat32 rd cst r1 rs m + | Pstfsx rd r1 r2 => + store2 Mfloat32 rd r1 r2 rs m + | Psth rd cst r1 => + store1 Mint16unsigned rd cst r1 rs m + | Psthx rd r1 r2 => + store2 Mint16unsigned rd r1 r2 rs m + | Pstw rd cst r1 => + store1 Mint32 rd cst r1 rs m + | Pstwx rd r1 r2 => + store2 Mint32 rd r1 r2 rs m + | Psubfc rd r1 r2 => + OK (nextinstr (rs#rd <- (Val.sub rs#r2 rs#r1) #CARRY <- Vundef)) m + | Psubfic rd r1 cst => + OK (nextinstr (rs#rd <- (Val.sub (const_low cst) rs#r1) #CARRY <- Vundef)) m + | Pxor rd r1 r2 => + OK (nextinstr (rs#rd <- (Val.xor rs#r1 rs#r2))) m + | Pxori rd r1 cst => + 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 + | Plabel lbl => + OK (nextinstr rs) m + end. + +(** Translation of the LTL/Linear/Mach view of machine registers + to the PPC view. PPC has two different types for registers + (integer and float) while LTL et al have only one. The + [ireg_of] and [freg_of] are therefore partial in principle. + To keep things simpler, we make them return nonsensical + results when applied to a LTL register of the wrong type. + The proof in [Asmgenproof] will show that this never happens. + + Note that no LTL register maps to [GPR12] nor [FPR13]. + These two registers are reserved as temporaries, to be used + by the generated PPC code. *) + +Definition ireg_of (r: mreg) : ireg := + match r with + | R3 => GPR3 | R4 => GPR4 | R5 => GPR5 | R6 => GPR6 + | R7 => GPR7 | R8 => GPR8 | R9 => GPR9 | R10 => GPR10 + | R13 => GPR13 | R14 => GPR14 | R15 => GPR15 | R16 => GPR16 + | R17 => GPR17 | R18 => GPR18 | R19 => GPR19 | R20 => GPR20 + | R21 => GPR21 | R22 => GPR22 | R23 => GPR23 | R24 => GPR24 + | R25 => GPR25 | R26 => GPR26 | R27 => GPR27 | R28 => GPR28 + | R29 => GPR29 | R30 => GPR30 | R31 => GPR31 + | IT1 => GPR11 | IT2 => GPR0 + | _ => GPR0 (* should not happen *) + end. + +Definition freg_of (r: mreg) : freg := + match r with + | F1 => FPR1 | F2 => FPR2 | F3 => FPR3 | F4 => FPR4 + | F5 => FPR5 | F6 => FPR6 | F7 => FPR7 | F8 => FPR8 + | F9 => FPR9 | F10 => FPR10 | F14 => FPR14 | F15 => FPR15 + | F16 => FPR16 | F17 => FPR17 | F18 => FPR18 | F19 => FPR19 + | F20 => FPR20 | F21 => FPR21 | F22 => FPR22 | F23 => FPR23 + | F24 => FPR24 | F25 => FPR25 | F26 => FPR26 | F27 => FPR27 + | F28 => FPR28 | F29 => FPR29 | F30 => FPR30 | F31 => FPR31 + | FT1 => FPR0 | FT2 => FPR11 | FT3 => FPR12 + | _ => FPR0 (* should not happen *) + end. + +Definition preg_of (r: mreg) := + match mreg_type r with + | Tint => IR (ireg_of r) + | Tfloat => FR (freg_of r) + end. + +(** Extract the values of the arguments of an external call. + We exploit the calling conventions from module [Conventions], except that + we use PPC registers instead of locations. *) + +Inductive extcall_arg (rs: regset) (m: mem): loc -> val -> Prop := + | extcall_arg_reg: forall r, + extcall_arg rs m (R r) (rs (preg_of r)) + | extcall_arg_int_stack: forall ofs bofs v, + bofs = Stacklayout.fe_ofs_arg + 4 * ofs -> + Mem.loadv Mint32 m (Val.add (rs (IR GPR1)) (Vint (Int.repr bofs))) = Some v -> + extcall_arg rs m (S (Outgoing ofs Tint)) v + | extcall_arg_float_stack: forall ofs bofs v, + bofs = Stacklayout.fe_ofs_arg + 4 * ofs -> + Mem.loadv Mfloat64 m (Val.add (rs (IR GPR1)) (Vint (Int.repr bofs))) = Some v -> + extcall_arg rs m (S (Outgoing ofs Tfloat)) v. + +Inductive extcall_args (rs: regset) (m: mem): list loc -> list val -> Prop := + | extcall_args_nil: + extcall_args rs m nil nil + | extcall_args_cons: forall l1 ll v1 vl, + extcall_arg rs m l1 v1 -> extcall_args rs m ll vl -> + extcall_args rs m (l1 :: ll) (v1 :: vl). + +Definition extcall_arguments + (rs: regset) (m: mem) (sg: signature) (args: list val) : Prop := + extcall_args rs m (Conventions.loc_arguments sg) args. + +Definition loc_external_result (sg: signature) : preg := + preg_of (Conventions.loc_result sg). + +(** Execution of the instruction at [rs#PC]. *) + +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' -> + 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 -> + Genv.find_funct_ptr ge b = Some (External ef) -> + event_match ef args t res -> + extcall_arguments rs m ef.(ef_sig) args -> + rs' = (rs#(loc_external_result ef.(ef_sig)) <- res + #PC <- (rs LR)) -> + step (State rs m) t (State rs' m). + +End RELSEM. + +(** Execution of whole programs. *) + +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/powerpc/Asmgen.v b/powerpc/Asmgen.v new file mode 100644 index 0000000..2ddaa6d --- /dev/null +++ b/powerpc/Asmgen.v @@ -0,0 +1,510 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Translation from Mach to PPC. *) + +Require Import Coqlib. +Require Import Maps. +Require Import Errors. +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 Asm. + +(** Decomposition of integer constants. As noted in file [Asm], + immediate arguments to PowerPC instructions must fit into 16 bits, + and are interpreted after zero extension, sign extension, or + left shift by 16 bits, depending on the instruction. Integer + constants that do not fit must be synthesized using two + processor instructions. The following functions decompose + arbitrary 32-bit integers into two 16-bit halves (high and low + halves). They satisfy the following properties: +- [low_u n] is an unsigned 16-bit integer; +- [low_s n] is a signed 16-bit integer; +- [(high_u n) << 16 | low_u n] equals [n]; +- [(high_s n) << 16 + low_s n] equals [n]. +*) + +Definition low_u (n: int) := Int.and n (Int.repr 65535). +Definition high_u (n: int) := Int.shru n (Int.repr 16). +Definition low_s (n: int) := Int.sign_ext 16 n. +Definition high_s (n: int) := Int.shru (Int.sub n (low_s n)) (Int.repr 16). + +(** Smart constructors for arithmetic operations involving + a 32-bit integer constant. Depending on whether the + constant fits in 16 bits or not, one or several instructions + are generated as required to perform the operation + and prepended to the given instruction sequence [k]. *) + +Definition loadimm (r: ireg) (n: int) (k: code) := + if Int.eq (high_s n) Int.zero then + Paddi r GPR0 (Cint n) :: k + else if Int.eq (low_s n) Int.zero then + Paddis r GPR0 (Cint (high_s n)) :: k + else + Paddis r GPR0 (Cint (high_u n)) :: + Pori r r (Cint (low_u n)) :: k. + +Definition addimm_1 (r1 r2: ireg) (n: int) (k: code) := + if Int.eq (high_s n) Int.zero then + Paddi r1 r2 (Cint n) :: k + else if Int.eq (low_s n) Int.zero then + Paddis r1 r2 (Cint (high_s n)) :: k + else + Paddis r1 r2 (Cint (high_s n)) :: + Paddi r1 r1 (Cint (low_s n)) :: k. + +Definition addimm_2 (r1 r2: ireg) (n: int) (k: code) := + loadimm GPR12 n (Padd r1 r2 GPR12 :: k). + +Definition addimm (r1 r2: ireg) (n: int) (k: code) := + if ireg_eq r1 GPR0 then + addimm_2 r1 r2 n k + else if ireg_eq r2 GPR0 then + addimm_2 r1 r2 n k + else + addimm_1 r1 r2 n k. + +Definition andimm (r1 r2: ireg) (n: int) (k: code) := + if Int.eq (high_u n) Int.zero then + Pandi_ r1 r2 (Cint n) :: k + else if Int.eq (low_u n) Int.zero then + Pandis_ r1 r2 (Cint (high_u n)) :: k + else + loadimm GPR12 n (Pand_ r1 r2 GPR12 :: k). + +Definition orimm (r1 r2: ireg) (n: int) (k: code) := + if Int.eq (high_u n) Int.zero then + Pori r1 r2 (Cint n) :: k + else if Int.eq (low_u n) Int.zero then + Poris r1 r2 (Cint (high_u n)) :: k + else + Poris r1 r2 (Cint (high_u n)) :: + Pori r1 r1 (Cint (low_u n)) :: k. + +Definition xorimm (r1 r2: ireg) (n: int) (k: code) := + if Int.eq (high_u n) Int.zero then + Pxori r1 r2 (Cint n) :: k + else if Int.eq (low_u n) Int.zero then + Pxoris r1 r2 (Cint (high_u n)) :: k + else + Pxoris r1 r2 (Cint (high_u n)) :: + Pxori r1 r1 (Cint (low_u n)) :: k. + +(** Smart constructors for indexed loads and stores, + where the address is the contents of a register plus + an integer literal. *) + +Definition loadind_aux (base: ireg) (ofs: int) (ty: typ) (dst: mreg) := + match ty with + | Tint => Plwz (ireg_of dst) (Cint ofs) base + | Tfloat => Plfd (freg_of dst) (Cint ofs) base + end. + +Definition loadind (base: ireg) (ofs: int) (ty: typ) (dst: mreg) (k: code) := + if Int.eq (high_s ofs) Int.zero then + loadind_aux base ofs ty dst :: k + else + Paddis GPR12 base (Cint (high_s ofs)) :: + loadind_aux GPR12 (low_s ofs) ty dst :: k. + +Definition storeind_aux (src: mreg) (base: ireg) (ofs: int) (ty: typ) := + match ty with + | Tint => Pstw (ireg_of src) (Cint ofs) base + | Tfloat => Pstfd (freg_of src) (Cint ofs) base + end. + +Definition storeind (src: mreg) (base: ireg) (ofs: int) (ty: typ) (k: code) := + if Int.eq (high_s ofs) Int.zero then + storeind_aux src base ofs ty :: k + else + Paddis GPR12 base (Cint (high_s ofs)) :: + storeind_aux src GPR12 (low_s ofs) ty :: k. + +(** Constructor for a floating-point comparison. The PowerPC has + a single [fcmpu] instruction to compare floats, which sets + bits 0, 1 and 2 of the condition register to reflect ``less'', + ``greater'' and ``equal'' conditions, respectively. + The ``less or equal'' and ``greater or equal'' conditions must be + synthesized by a [cror] instruction that computes the logical ``or'' + of the corresponding two conditions. *) + +Definition floatcomp (cmp: comparison) (r1 r2: freg) (k: code) := + Pfcmpu r1 r2 :: + match cmp with + | Cle => Pcror CRbit_3 CRbit_2 CRbit_0 :: k + | Cge => Pcror CRbit_3 CRbit_2 CRbit_1 :: k + | _ => k + end. + +(** Translation of a condition. Prepends to [k] the instructions + that evaluate the condition and leave its boolean result in one of + the bits of the condition register. The bit in question is + determined by the [crbit_for_cond] function. *) + +Definition transl_cond + (cond: condition) (args: list mreg) (k: code) := + match cond, args with + | Ccomp c, a1 :: a2 :: nil => + Pcmpw (ireg_of a1) (ireg_of a2) :: k + | Ccompu c, a1 :: a2 :: nil => + Pcmplw (ireg_of a1) (ireg_of a2) :: k + | Ccompimm c n, a1 :: nil => + if Int.eq (high_s n) Int.zero then + Pcmpwi (ireg_of a1) (Cint n) :: k + else + loadimm GPR12 n (Pcmpw (ireg_of a1) GPR12 :: k) + | Ccompuimm c n, a1 :: nil => + if Int.eq (high_u n) Int.zero then + Pcmplwi (ireg_of a1) (Cint n) :: k + else + loadimm GPR12 n (Pcmplw (ireg_of a1) GPR12 :: k) + | Ccompf cmp, a1 :: a2 :: nil => + floatcomp cmp (freg_of a1) (freg_of a2) k + | Cnotcompf cmp, a1 :: a2 :: nil => + floatcomp cmp (freg_of a1) (freg_of a2) k + | Cmaskzero n, a1 :: nil => + andimm GPR12 (ireg_of a1) n k + | Cmasknotzero n, a1 :: nil => + andimm GPR12 (ireg_of a1) n k + | _, _ => + k (**r never happens for well-typed code *) + end. + +(* CRbit_0 = Less + CRbit_1 = Greater + CRbit_2 = Equal + CRbit_3 = Other *) + +Definition crbit_for_icmp (cmp: comparison) := + match cmp with + | Ceq => (CRbit_2, true) + | Cne => (CRbit_2, false) + | Clt => (CRbit_0, true) + | Cle => (CRbit_1, false) + | Cgt => (CRbit_1, true) + | Cge => (CRbit_0, false) + end. + +Definition crbit_for_fcmp (cmp: comparison) := + match cmp with + | Ceq => (CRbit_2, true) + | Cne => (CRbit_2, false) + | Clt => (CRbit_0, true) + | Cle => (CRbit_3, true) + | Cgt => (CRbit_1, true) + | Cge => (CRbit_3, true) + end. + +Definition crbit_for_cond (cond: condition) := + match cond with + | Ccomp cmp => crbit_for_icmp cmp + | Ccompu cmp => crbit_for_icmp cmp + | Ccompimm cmp n => crbit_for_icmp cmp + | Ccompuimm cmp n => crbit_for_icmp cmp + | Ccompf cmp => crbit_for_fcmp cmp + | Cnotcompf cmp => let p := crbit_for_fcmp cmp in (fst p, negb (snd p)) + | Cmaskzero n => (CRbit_2, true) + | Cmasknotzero n => (CRbit_2, false) + end. + +(** Translation of the arithmetic operation [r <- op(args)]. + The corresponding instructions are prepended to [k]. *) + +Definition transl_op + (op: operation) (args: list mreg) (r: mreg) (k: code) := + match op, args with + | Omove, a1 :: nil => + match mreg_type a1 with + | Tint => Pmr (ireg_of r) (ireg_of a1) :: k + | Tfloat => Pfmr (freg_of r) (freg_of a1) :: k + end + | Ointconst n, nil => + loadimm (ireg_of r) n k + | Ofloatconst f, nil => + Plfi (freg_of r) f :: k + | Oaddrsymbol s ofs, nil => + Paddis GPR12 GPR0 (Csymbol_high s ofs) :: + Paddi (ireg_of r) GPR12 (Csymbol_low s ofs) :: k + | Oaddrstack n, nil => + addimm (ireg_of r) GPR1 n k + | Ocast8signed, a1 :: nil => + Pextsb (ireg_of r) (ireg_of a1) :: k + | Ocast8unsigned, a1 :: nil => + Prlwinm (ireg_of r) (ireg_of a1) Int.zero (Int.repr 255) :: k + | Ocast16signed, a1 :: nil => + Pextsh (ireg_of r) (ireg_of a1) :: k + | Ocast16unsigned, a1 :: nil => + Prlwinm (ireg_of r) (ireg_of a1) Int.zero (Int.repr 65535) :: k + | Oadd, a1 :: a2 :: nil => + Padd (ireg_of r) (ireg_of a1) (ireg_of a2) :: k + | Oaddimm n, a1 :: nil => + addimm (ireg_of r) (ireg_of a1) n k + | Osub, a1 :: a2 :: nil => + Psubfc (ireg_of r) (ireg_of a2) (ireg_of a1) :: k + | Osubimm n, a1 :: nil => + if Int.eq (high_s n) Int.zero then + Psubfic (ireg_of r) (ireg_of a1) (Cint n) :: k + else + loadimm GPR12 n (Psubfc (ireg_of r) (ireg_of a1) GPR12 :: k) + | Omul, a1 :: a2 :: nil => + Pmullw (ireg_of r) (ireg_of a1) (ireg_of a2) :: k + | Omulimm n, a1 :: nil => + if Int.eq (high_s n) Int.zero then + Pmulli (ireg_of r) (ireg_of a1) (Cint n) :: k + else + loadimm GPR12 n (Pmullw (ireg_of r) (ireg_of a1) GPR12 :: k) + | Odiv, a1 :: a2 :: nil => + Pdivw (ireg_of r) (ireg_of a1) (ireg_of a2) :: k + | Odivu, a1 :: a2 :: nil => + Pdivwu (ireg_of r) (ireg_of a1) (ireg_of a2) :: k + | Oand, a1 :: a2 :: nil => + Pand_ (ireg_of r) (ireg_of a1) (ireg_of a2) :: k + | Oandimm n, a1 :: nil => + andimm (ireg_of r) (ireg_of a1) n k + | Oor, a1 :: a2 :: nil => + Por (ireg_of r) (ireg_of a1) (ireg_of a2) :: k + | Oorimm n, a1 :: nil => + orimm (ireg_of r) (ireg_of a1) n k + | Oxor, a1 :: a2 :: nil => + Pxor (ireg_of r) (ireg_of a1) (ireg_of a2) :: k + | Oxorimm n, a1 :: nil => + xorimm (ireg_of r) (ireg_of a1) n k + | Onand, a1 :: a2 :: nil => + Pnand (ireg_of r) (ireg_of a1) (ireg_of a2) :: k + | Onor, a1 :: a2 :: nil => + Pnor (ireg_of r) (ireg_of a1) (ireg_of a2) :: k + | Onxor, a1 :: a2 :: nil => + Peqv (ireg_of r) (ireg_of a1) (ireg_of a2) :: k + | Oshl, a1 :: a2 :: nil => + Pslw (ireg_of r) (ireg_of a1) (ireg_of a2) :: k + | Oshr, a1 :: a2 :: nil => + Psraw (ireg_of r) (ireg_of a1) (ireg_of a2) :: k + | Oshrimm n, a1 :: nil => + Psrawi (ireg_of r) (ireg_of a1) n :: k + | Oshrximm n, a1 :: nil => + Psrawi (ireg_of r) (ireg_of a1) n :: + Paddze (ireg_of r) (ireg_of r) :: k + | Oshru, a1 :: a2 :: nil => + Psrw (ireg_of r) (ireg_of a1) (ireg_of a2) :: k + | Orolm amount mask, a1 :: nil => + Prlwinm (ireg_of r) (ireg_of a1) amount mask :: k + | Onegf, a1 :: nil => + Pfneg (freg_of r) (freg_of a1) :: k + | Oabsf, a1 :: nil => + Pfabs (freg_of r) (freg_of a1) :: k + | Oaddf, a1 :: a2 :: nil => + Pfadd (freg_of r) (freg_of a1) (freg_of a2) :: k + | Osubf, a1 :: a2 :: nil => + Pfsub (freg_of r) (freg_of a1) (freg_of a2) :: k + | Omulf, a1 :: a2 :: nil => + Pfmul (freg_of r) (freg_of a1) (freg_of a2) :: k + | Odivf, a1 :: a2 :: nil => + Pfdiv (freg_of r) (freg_of a1) (freg_of a2) :: k + | Omuladdf, a1 :: a2 :: a3 :: nil => + Pfmadd (freg_of r) (freg_of a1) (freg_of a2) (freg_of a3) :: k + | Omulsubf, a1 :: a2 :: a3 :: nil => + Pfmsub (freg_of r) (freg_of a1) (freg_of a2) (freg_of a3) :: k + | Osingleoffloat, a1 :: nil => + Pfrsp (freg_of r) (freg_of a1) :: k + | Ointoffloat, a1 :: nil => + Pfcti (ireg_of r) (freg_of a1) :: k + | Ointuoffloat, a1 :: nil => + Pfctiu (ireg_of r) (freg_of a1) :: k + | Ofloatofint, a1 :: nil => + Pictf (freg_of r) (ireg_of a1) :: k + | Ofloatofintu, a1 :: nil => + Piuctf (freg_of r) (ireg_of a1) :: k + | Ocmp cmp, _ => + let p := crbit_for_cond cmp in + transl_cond cmp args + (Pmfcrbit (ireg_of r) (fst p) :: + if snd p + then k + else Pxori (ireg_of r) (ireg_of r) (Cint Int.one) :: k) + | _, _ => + k (**r never happens for well-typed code *) + end. + +(** Common code to translate [Mload] and [Mstore] instructions. *) + +Definition transl_load_store + (mk1: constant -> ireg -> instruction) + (mk2: ireg -> ireg -> instruction) + (addr: addressing) (args: list mreg) (k: code) := + match addr, args with + | Aindexed ofs, a1 :: nil => + if ireg_eq (ireg_of a1) GPR0 then + Pmr GPR12 (ireg_of a1) :: + Paddis GPR12 GPR12 (Cint (high_s ofs)) :: + mk1 (Cint (low_s ofs)) GPR12 :: k + else if Int.eq (high_s ofs) Int.zero then + mk1 (Cint ofs) (ireg_of a1) :: k + else + Paddis GPR12 (ireg_of a1) (Cint (high_s ofs)) :: + mk1 (Cint (low_s ofs)) GPR12 :: k + | Aindexed2, a1 :: a2 :: nil => + mk2 (ireg_of a1) (ireg_of a2) :: k + | Aglobal symb ofs, nil => + Paddis GPR12 GPR0 (Csymbol_high symb ofs) :: + mk1 (Csymbol_low symb ofs) GPR12 :: k + | Abased symb ofs, a1 :: nil => + if ireg_eq (ireg_of a1) GPR0 then + Pmr GPR12 (ireg_of a1) :: + Paddis GPR12 GPR12 (Csymbol_high symb ofs) :: + mk1 (Csymbol_low symb ofs) GPR12 :: k + else + Paddis GPR12 (ireg_of a1) (Csymbol_high symb ofs) :: + mk1 (Csymbol_low symb ofs) GPR12 :: k + | Ainstack ofs, nil => + if Int.eq (high_s ofs) Int.zero then + mk1 (Cint ofs) GPR1 :: k + else + Paddis GPR12 GPR1 (Cint (high_s ofs)) :: + mk1 (Cint (low_s ofs)) GPR12 :: k + | _, _ => + (* should not happen *) k + end. + +(** Translation of a Mach instruction. *) + +Definition transl_instr (f: Mach.function) (i: Mach.instruction) (k: code) := + match i with + | Mgetstack ofs ty dst => + loadind GPR1 ofs ty dst k + | Msetstack src ofs ty => + storeind src GPR1 ofs ty k + | Mgetparam ofs ty dst => + Plwz GPR12 (Cint f.(fn_link_ofs)) GPR1 :: loadind GPR12 ofs ty dst k + | Mop op args res => + transl_op op args res k + | Mload chunk addr args dst => + match chunk with + | Mint8signed => + transl_load_store + (Plbz (ireg_of dst)) (Plbzx (ireg_of dst)) addr args + (Pextsb (ireg_of dst) (ireg_of dst) :: k) + | Mint8unsigned => + transl_load_store + (Plbz (ireg_of dst)) (Plbzx (ireg_of dst)) addr args k + | Mint16signed => + transl_load_store + (Plha (ireg_of dst)) (Plhax (ireg_of dst)) addr args k + | Mint16unsigned => + transl_load_store + (Plhz (ireg_of dst)) (Plhzx (ireg_of dst)) addr args k + | Mint32 => + transl_load_store + (Plwz (ireg_of dst)) (Plwzx (ireg_of dst)) addr args k + | Mfloat32 => + transl_load_store + (Plfs (freg_of dst)) (Plfsx (freg_of dst)) addr args k + | Mfloat64 => + transl_load_store + (Plfd (freg_of dst)) (Plfdx (freg_of dst)) addr args k + end + | Mstore chunk addr args src => + match chunk with + | Mint8signed => + transl_load_store + (Pstb (ireg_of src)) (Pstbx (ireg_of src)) addr args k + | Mint8unsigned => + transl_load_store + (Pstb (ireg_of src)) (Pstbx (ireg_of src)) addr args k + | Mint16signed => + transl_load_store + (Psth (ireg_of src)) (Psthx (ireg_of src)) addr args k + | Mint16unsigned => + transl_load_store + (Psth (ireg_of src)) (Psthx (ireg_of src)) addr args k + | Mint32 => + transl_load_store + (Pstw (ireg_of src)) (Pstwx (ireg_of src)) addr args k + | Mfloat32 => + transl_load_store + (Pstfs (freg_of src)) (Pstfsx (freg_of src)) addr args k + | Mfloat64 => + transl_load_store + (Pstfd (freg_of src)) (Pstfdx (freg_of src)) addr args k + end + | Mcall sig (inl r) => + Pmtctr (ireg_of r) :: Pbctrl :: k + | Mcall sig (inr symb) => + Pbl symb :: k + | Mtailcall sig (inl r) => + Pmtctr (ireg_of r) :: + Plwz GPR12 (Cint f.(fn_retaddr_ofs)) GPR1 :: + Pmtlr GPR12 :: + Pfreeframe f.(fn_link_ofs) :: + Pbctr :: k + | Mtailcall sig (inr symb) => + Plwz GPR12 (Cint f.(fn_retaddr_ofs)) GPR1 :: + Pmtlr GPR12 :: + Pfreeframe f.(fn_link_ofs) :: + Pbs symb :: k + | Malloc => + Pallocblock :: k + | Mlabel lbl => + Plabel lbl :: k + | Mgoto lbl => + Pb lbl :: k + | Mcond cond args lbl => + let p := crbit_for_cond cond in + transl_cond cond args + (if (snd p) then Pbt (fst p) lbl :: k else Pbf (fst p) lbl :: k) + | Mreturn => + Plwz GPR12 (Cint f.(fn_retaddr_ofs)) GPR1 :: + Pmtlr GPR12 :: + Pfreeframe f.(fn_link_ofs) :: + Pblr :: k + end. + +Definition transl_code (f: Mach.function) (il: list Mach.instruction) := + List.fold_right (transl_instr f) nil il. + +(** Translation of a whole function. Note that we must check + that the generated code contains less than [2^32] instructions, + otherwise the offset part of the [PC] code pointer could wrap + around, leading to incorrect executions. *) + +Definition transl_function (f: Mach.function) := + Pallocframe (- f.(fn_framesize)) f.(fn_stacksize) f.(fn_link_ofs) :: + Pmflr GPR12 :: + Pstw GPR12 (Cint f.(fn_retaddr_ofs)) GPR1 :: + transl_code f f.(fn_code). + +Fixpoint code_size (c: code) : Z := + match c with + | nil => 0 + | instr :: c' => code_size c' + 1 + end. + +Open Local Scope string_scope. + +Definition transf_function (f: Mach.function) : res Asm.code := + let c := transl_function f in + if zlt Int.max_unsigned (code_size c) + then Errors.Error (msg "code size exceeded") + else Errors.OK c. + +Definition transf_fundef (f: Mach.fundef) : res Asm.fundef := + transf_partial_fundef transf_function f. + +Definition transf_program (p: Mach.program) : res Asm.program := + transform_partial_program transf_fundef p. + diff --git a/powerpc/Asmgenproof.v b/powerpc/Asmgenproof.v new file mode 100644 index 0000000..980925b --- /dev/null +++ b/powerpc/Asmgenproof.v @@ -0,0 +1,1394 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Correctness proof for PPC generation: main proof. *) + +Require Import Coqlib. +Require Import Maps. +Require Import Errors. +Require Import AST. +Require Import Integers. +Require Import Floats. +Require Import Values. +Require Import 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 Asm. +Require Import Asmgen. +Require Import Asmgenretaddr. +Require Import Asmgenproof1. + +Section PRESERVATION. + +Variable prog: Mach.program. +Variable tprog: Asm.program. +Hypothesis TRANSF: transf_program prog = Errors.OK tprog. + +Let ge := Genv.globalenv prog. +Let tge := Genv.globalenv tprog. + +Lemma symbols_preserved: + forall id, Genv.find_symbol tge id = Genv.find_symbol ge id. +Proof. + intros. unfold ge, tge. + apply Genv.find_symbol_transf_partial with transf_fundef. + exact TRANSF. +Qed. + +Lemma functions_translated: + forall b f, + Genv.find_funct_ptr ge b = Some f -> + exists tf, Genv.find_funct_ptr tge b = Some tf /\ transf_fundef f = Errors.OK tf. +Proof + (Genv.find_funct_ptr_transf_partial transf_fundef TRANSF). + +Lemma functions_transl: + forall f b, + Genv.find_funct_ptr ge b = Some (Internal f) -> + Genv.find_funct_ptr tge b = Some (Internal (transl_function f)). +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))); simpl; intro. + congruence. intro. inv B0. auto. +Qed. + +Lemma functions_transl_no_overflow: + forall b f, + Genv.find_funct_ptr ge b = Some (Internal f) -> + code_size (transl_function f) <= Int.max_unsigned. +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))); simpl; intro. + congruence. intro; omega. +Qed. + +(** * Properties of control flow *) + +Lemma find_instr_in: + forall c pos i, + find_instr pos c = Some i -> In i c. +Proof. + induction c; simpl. intros; discriminate. + intros until i. case (zeq pos 0); intros. + left; congruence. right; eauto. +Qed. + +Lemma find_instr_tail: + forall c1 i c2 pos, + code_tail pos c1 (i :: c2) -> + find_instr pos c1 = Some i. +Proof. + 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: + forall fn, code_size fn >= 0. +Proof. + induction fn; simpl; omega. +Qed. + +Remark code_tail_bounds: + forall fn ofs i c, + code_tail ofs fn (i :: c) -> 0 <= ofs < code_size fn. +Proof. + 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. +Proof. + 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. +Proof. + 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. +Qed. + +(** [transl_code_at_pc pc fn c] holds if the code pointer [pc] points + within the PPC code generated by translating Mach function [fn], + and [c] is the tail of the generated code at the position corresponding + to the code pointer [pc]. *) + +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 f 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 + (predicate [exec_steps]) under adequate [transl_code_at_pc] hypotheses. *) + +Lemma exec_straight_steps_1: + forall fn c rs m c' rs' m', + exec_straight tge fn c rs m c' rs' m' -> + code_size fn <= Int.max_unsigned -> + forall b ofs, + rs#PC = Vptr b ofs -> + Genv.find_funct_ptr tge b = Some (Internal fn) -> + code_tail (Int.unsigned ofs) fn c -> + plus step tge (State rs m) E0 (State rs' m'). +Proof. + 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. + apply code_tail_next_int with i; auto. + traceEq. +Qed. + +Lemma exec_straight_steps_2: + forall fn c rs m c' rs' m', + exec_straight tge fn c rs m c' rs' m' -> + code_size fn <= Int.max_unsigned -> + forall b ofs, + rs#PC = Vptr b ofs -> + Genv.find_funct_ptr tge b = Some (Internal fn) -> + code_tail (Int.unsigned ofs) fn c -> + exists ofs', + rs'#PC = Vptr b ofs' + /\ code_tail (Int.unsigned ofs') fn c'. +Proof. + induction 1; intros. + 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_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 f 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 f c) rs m (transl_code f c') rs' m' -> + transl_code_at_pc (rs' PC) fb f c'. +Proof. + intros. inversion H. subst. + generalize (functions_transl_no_overflow _ _ H2). intro. + generalize (functions_transl _ _ H2). intro. + generalize (exec_straight_steps_2 _ _ _ _ _ _ _ + 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. *) + +Fixpoint find_label (lbl: label) (c: code) {struct c} : option code := + match c with + | nil => None + | instr :: c' => + if is_label lbl instr then Some c' else find_label lbl c' + end. + +Lemma label_pos_code_tail: + forall lbl c pos c', + find_label lbl c = Some c' -> + exists pos', + label_pos lbl pos c = Some pos' + /\ code_tail (pos' - pos) c c' + /\ pos < pos' <= pos + code_size c. +Proof. + induction c. + simpl; intros. discriminate. + simpl; intros until c'. + case (is_label lbl a). + intro EQ; injection EQ; intro; subst c'. + exists (pos + 1). split. auto. split. + 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. + 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 + preserves labels, in the sense that the following diagram commutes: +<< + translation + Mach code ------------------------ PPC instr sequence + | | + | Mach.find_label lbl find_label lbl | + | | + v v + Mach code tail ------------------- PPC instr seq tail + translation +>> + The proof demands many boring lemmas showing that PPC constructor + functions do not introduce new labels. +*) + +Section TRANSL_LABEL. + +Variable lbl: label. + +Remark loadimm_label: + forall r n k, find_label lbl (loadimm r n k) = find_label lbl k. +Proof. + intros. unfold loadimm. + case (Int.eq (high_s n) Int.zero). reflexivity. + case (Int.eq (low_s n) Int.zero). reflexivity. + reflexivity. +Qed. +Hint Rewrite loadimm_label: labels. + +Remark addimm_1_label: + forall r1 r2 n k, find_label lbl (addimm_1 r1 r2 n k) = find_label lbl k. +Proof. + intros; unfold addimm_1. + case (Int.eq (high_s n) Int.zero). reflexivity. + case (Int.eq (low_s n) Int.zero). reflexivity. reflexivity. +Qed. +Remark addimm_2_label: + forall r1 r2 n k, find_label lbl (addimm_2 r1 r2 n k) = find_label lbl k. +Proof. + intros; unfold addimm_2. autorewrite with labels. reflexivity. +Qed. +Remark addimm_label: + forall r1 r2 n k, find_label lbl (addimm r1 r2 n k) = find_label lbl k. +Proof. + intros; unfold addimm. + case (ireg_eq r1 GPR0); intro. apply addimm_2_label. + case (ireg_eq r2 GPR0); intro. apply addimm_2_label. + apply addimm_1_label. +Qed. +Hint Rewrite addimm_label: labels. + +Remark andimm_label: + forall r1 r2 n k, find_label lbl (andimm r1 r2 n k) = find_label lbl k. +Proof. + intros; unfold andimm. + case (Int.eq (high_u n) Int.zero). reflexivity. + case (Int.eq (low_u n) Int.zero). reflexivity. + autorewrite with labels. reflexivity. +Qed. +Hint Rewrite andimm_label: labels. + +Remark orimm_label: + forall r1 r2 n k, find_label lbl (orimm r1 r2 n k) = find_label lbl k. +Proof. + intros; unfold orimm. + case (Int.eq (high_u n) Int.zero). reflexivity. + case (Int.eq (low_u n) Int.zero). reflexivity. reflexivity. +Qed. +Hint Rewrite orimm_label: labels. + +Remark xorimm_label: + forall r1 r2 n k, find_label lbl (xorimm r1 r2 n k) = find_label lbl k. +Proof. + intros; unfold xorimm. + case (Int.eq (high_u n) Int.zero). reflexivity. + case (Int.eq (low_u n) Int.zero). reflexivity. reflexivity. +Qed. +Hint Rewrite xorimm_label: labels. + +Remark loadind_aux_label: + forall base ofs ty dst k, find_label lbl (loadind_aux base ofs ty dst :: k) = find_label lbl k. +Proof. + intros; unfold loadind_aux. + case ty; reflexivity. +Qed. +Remark loadind_label: + forall base ofs ty dst k, find_label lbl (loadind base ofs ty dst k) = find_label lbl k. +Proof. + intros; unfold loadind. + case (Int.eq (high_s ofs) Int.zero). apply loadind_aux_label. + transitivity (find_label lbl (loadind_aux GPR12 (low_s ofs) ty dst :: k)). + reflexivity. apply loadind_aux_label. +Qed. +Hint Rewrite loadind_label: labels. +Remark storeind_aux_label: + forall base ofs ty dst k, find_label lbl (storeind_aux base ofs ty dst :: k) = find_label lbl k. +Proof. + intros; unfold storeind_aux. + case dst; reflexivity. +Qed. +Remark storeind_label: + forall base ofs ty src k, find_label lbl (storeind base src ofs ty k) = find_label lbl k. +Proof. + intros; unfold storeind. + case (Int.eq (high_s ofs) Int.zero). apply storeind_aux_label. + transitivity (find_label lbl (storeind_aux base GPR12 (low_s ofs) ty :: k)). + reflexivity. apply storeind_aux_label. +Qed. +Hint Rewrite storeind_label: labels. +Remark floatcomp_label: + forall cmp r1 r2 k, find_label lbl (floatcomp cmp r1 r2 k) = find_label lbl k. +Proof. + intros; unfold floatcomp. destruct cmp; reflexivity. +Qed. + +Remark transl_cond_label: + forall cond args k, find_label lbl (transl_cond cond args k) = find_label lbl k. +Proof. + intros; unfold transl_cond. + destruct cond; (destruct args; + [try reflexivity | destruct args; + [try reflexivity | destruct args; try reflexivity]]). + case (Int.eq (high_s i) Int.zero). reflexivity. + autorewrite with labels; reflexivity. + case (Int.eq (high_u i) Int.zero). reflexivity. + autorewrite with labels; reflexivity. + apply floatcomp_label. apply floatcomp_label. + apply andimm_label. apply andimm_label. +Qed. +Hint Rewrite transl_cond_label: labels. +Remark transl_op_label: + forall op args r k, find_label lbl (transl_op op args r k) = find_label lbl k. +Proof. + intros; unfold transl_op; + 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 (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. + case (snd (crbit_for_cond c)); reflexivity. + case (snd (crbit_for_cond c)); reflexivity. + case (snd (crbit_for_cond c)); reflexivity. + case (snd (crbit_for_cond c)); reflexivity. +Qed. +Hint Rewrite transl_op_label: labels. + +Remark transl_load_store_label: + forall (mk1: constant -> ireg -> instruction) (mk2: ireg -> ireg -> instruction) + addr args k, + (forall c r, is_label lbl (mk1 c r) = false) -> + (forall r1 r2, is_label lbl (mk2 r1 r2) = false) -> + find_label lbl (transl_load_store mk1 mk2 addr args k) = find_label lbl k. +Proof. + intros; unfold transl_load_store. + destruct addr; destruct args; try (destruct args); try (destruct args); + try reflexivity. + case (ireg_eq (ireg_of m) GPR0); intro. + simpl. rewrite H. auto. + case (Int.eq (high_s i) Int.zero). simpl; rewrite H; auto. + simpl; rewrite H; auto. + simpl; rewrite H0; auto. + simpl; rewrite H; auto. + case (ireg_eq (ireg_of m) GPR0); intro; simpl; rewrite H; auto. + case (Int.eq (high_s i) Int.zero); simpl; rewrite H; auto. +Qed. +Hint Rewrite transl_load_store_label: labels. + +Lemma transl_instr_label: + forall f i k, + find_label lbl (transl_instr f i k) = + if Mach.is_label lbl i then Some k else find_label lbl k. +Proof. + intros. generalize (Mach.is_label_correct lbl i). + case (Mach.is_label lbl i); intro. + subst i. simpl. rewrite peq_true. auto. + destruct i; simpl; autorewrite with labels; try reflexivity. + 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. + +Lemma transl_code_label: + forall f c, + find_label lbl (transl_code f c) = + option_map (transl_code f) (Mach.find_label lbl c). +Proof. + induction c; simpl; intros. + auto. rewrite transl_instr_label. + case (Mach.is_label lbl a). reflexivity. + auto. +Qed. + +Lemma transl_find_label: + forall f, + find_label lbl (transl_function f) = + option_map (transl_code f) (Mach.find_label lbl f.(fn_code)). +Proof. + intros. unfold transl_function. simpl. apply transl_code_label. +Qed. + +End TRANSL_LABEL. + +(** A valid branch in a piece of Mach code translates to a valid ``go to'' + transition in the generated PPC code. *) + +Lemma find_label_goto_label: + forall f lbl rs m c' b ofs, + Genv.find_funct_ptr ge b = Some (Internal f) -> + rs PC = Vptr b ofs -> + 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) b f c' + /\ forall r, r <> PC -> rs'#r = rs#r. +Proof. + intros. + generalize (transl_find_label lbl f). + rewrite H1; simpl. intro. + generalize (label_pos_code_tail lbl (transl_function f) 0 + (transl_code f c') H2). + 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. + 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. + +(** * Memory properties *) + +(** The PowerPC has no instruction for ``load 8-bit signed integer''. + 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.sign_ext 8) (Mem.loadv Mint8unsigned m a). +Proof. + intros. unfold Mem.loadv. destruct a; try reflexivity. + unfold load. rewrite (in_bounds_equiv Mint8signed Mint8unsigned). + destruct (in_bounds m Mint8unsigned b (Int.signed i)); auto. + simpl. + destruct (getN 0 (Int.signed i) (contents (blocks m b))); auto. + simpl. rewrite Int.sign_ext_zero_ext. auto. compute; auto. + auto. +Qed. + +(** Similarly, we show that signed 8- and 16-bit stores can be performed + like unsigned stores. *) + +Lemma storev_8_signed_unsigned: + forall m a v, + Mem.storev Mint8signed m a v = Mem.storev Mint8unsigned m a v. +Proof. + intros. unfold storev. destruct a; auto. + unfold store. rewrite (in_bounds_equiv Mint8signed Mint8unsigned). + auto. auto. +Qed. + +Lemma storev_16_signed_unsigned: + forall m a v, + Mem.storev Mint16signed m a v = Mem.storev Mint16unsigned m a v. +Proof. + intros. unfold storev. destruct a; auto. + unfold store. rewrite (in_bounds_equiv Mint16signed Mint16unsigned). + auto. auto. +Qed. + +(** * Proof of semantic preservation *) + +(** Semantic preservation is proved using simulation diagrams + of the following form. +<< + st1 --------------- st2 + | | + t| *|t + | | + v v + st1'--------------- st2' +>> + 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. +*) + +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 -> Asm.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) + (Asm.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) + (Asm.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) + (Asm.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 f c1) rs1 m1 (transl_code f 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 (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; inv MS. + left; eapply exec_straight_steps; eauto with coqlib. + exists (nextinstr rs); split. + simpl. apply exec_straight_one. reflexivity. reflexivity. + apply agree_nextinstr; auto. +Qed. + +Lemma exec_Mgetstack_prop: + 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; 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 f c) rs m v H H1 NOTE). + intros [rs2 [EX [RES OTH]]]. + 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. +Qed. + +Lemma exec_Msetstack_prop: + 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; 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 rs) in H; auto. + assert (NOTE: GPR1 <> GPR0). congruence. + generalize (storeind_correct tge (transl_function f) GPR1 ofs ty + src (transl_code f c) rs m m' H H1 NOTE). + intros [rs2 [EX OTH]]. + 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 (s : list stackframe) (fb : block) (f: Mach.function) (sp parent : val) + (ofs : int) (ty : typ) (dst : mreg) (c : list Mach.instruction) + (ms : Mach.regset) (m : mem) (v : val), + Genv.find_funct_ptr ge fb = Some (Internal f) -> + load_stack m sp Tint f.(fn_link_ofs) = 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; inv MS. + assert (f0 = f) by congruence. subst f0. + set (rs2 := nextinstr (rs#GPR12 <- parent)). + assert (EX1: exec_straight tge (transl_function f) + (transl_code f (Mgetparam ofs ty dst :: c)) rs m + (loadind GPR12 ofs ty dst (transl_code f 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 rs); auto. + unfold load_stack in H0. simpl chunk_of_type in H0. + rewrite H0. reflexivity. reflexivity. + generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). + intro WTI. inversion WTI. + unfold load_stack in H1. change parent with rs2#GPR12 in H1. + assert (NOTE: GPR12 <> GPR0). congruence. + generalize (loadind_correct tge (transl_function f) GPR12 ofs ty + dst (transl_code f c) rs2 m v H1 H3 NOTE). + intros [rs3 [EX2 [RES OTH]]]. + 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. +Qed. + +Lemma exec_Mop_prop: + 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; inv MS. + generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). + 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 (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; 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. + left; eapply exec_straight_steps; eauto with coqlib; + destruct chunk; simpl; simpl in H6; + (* all cases but Mint8signed *) + try (eapply transl_load_correct; eauto; + intros; simpl; unfold preg_of; rewrite H6; auto). + (* Mint8signed *) + generalize (loadv_8_signed_unsigned m a). + rewrite H0. + caseEq (loadv Mint8unsigned m a); + [idtac | simpl;intros;discriminate]. + intros v' LOAD' EQ. simpl in EQ. injection EQ. intro EQ1. clear EQ. + assert (X1: forall (cst : constant) (r1 : ireg) (rs1 : regset), + exec_instr tge (transl_function f) (Plbz (ireg_of dst) cst r1) rs1 m = + load1 tge Mint8unsigned (preg_of dst) cst r1 rs1 m). + intros. unfold preg_of; rewrite H6. reflexivity. + assert (X2: forall (r1 r2 : ireg) (rs1 : regset), + exec_instr tge (transl_function f) (Plbzx (ireg_of dst) r1 r2) rs1 m = + load2 Mint8unsigned (preg_of dst) r1 r2 rs1 m). + intros. unfold preg_of; rewrite H6. reflexivity. + generalize (transl_load_correct tge (transl_function f) + (Plbz (ireg_of dst)) (Plbzx (ireg_of dst)) + Mint8unsigned addr args + (Pextsb (ireg_of dst) (ireg_of dst) :: transl_code f c) + ms sp rs m dst a v' + X1 X2 AG H3 H7 LOAD'). + intros [rs2 [EX1 AG1]]. + exists (nextinstr (rs2#(ireg_of dst) <- v)). + split. eapply exec_straight_trans. eexact EX1. + apply exec_straight_one. simpl. + rewrite <- (ireg_val _ _ _ dst AG1);auto. rewrite Regmap.gss. + rewrite EQ1. reflexivity. reflexivity. + eauto with ppcgen. +Qed. + +Lemma exec_Mstore_prop: + forall (s : list stackframe) (fb : block) (sp : val) + (chunk : memory_chunk) (addr : addressing) (args : list mreg) + (src : mreg) (c : list Mach.instruction) (ms : mreg -> val) + (m m' : mem) (a : val), + eval_addressing ge sp addr ms ## args = Some a -> + storev chunk m a (ms src) = Some m' -> + exec_instr_prop (Machconcr.State s fb sp (Mstore chunk addr args src :: c) ms m) E0 + (Machconcr.State s fb sp c ms m'). +Proof. + intros; red; intros; inv MS. + generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). + intro WTI; inversion WTI. + rewrite <- (eval_addressing_preserved symbols_preserved) in H. + left; eapply exec_straight_steps; eauto with coqlib. + destruct chunk; simpl; simpl in H6; + 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. + +Lemma exec_Mcall_prop: + 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; inv MS. + assert (f0 = f) by congruence. subst f0. + generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). + intro WTI. inversion WTI. + inv AT. + assert (NOOV: code_size (transl_function f) <= Int.max_unsigned). + eapply functions_transl_no_overflow; eauto. + 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 (rs#CTR <- (ms m0))). + set (rs3 := rs2 #LR <- (Val.add rs2#PC Vone) #PC <- (ms m0)). + 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. + 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 *) + generalize (code_tail_next_int _ _ _ _ NOOV H7). intro CT1. + 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. + 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: Mach.function) (f' : block), + find_function_ptr ge ros ms = Some f' -> + Genv.find_funct_ptr ge fb = Some (Internal f) -> + load_stack m (Vptr stk soff) Tint f.(fn_link_ofs) = Some (parent_sp s) -> + load_stack m (Vptr stk soff) Tint f.(fn_retaddr_ofs) = Some (parent_ra s) -> + 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. + assert (f0 = f) by congruence. subst f0. + 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 H9. + (* Indirect call *) + set (rs2 := nextinstr (rs#CTR <- (ms m0))). + set (rs3 := nextinstr (rs2#GPR12 <- (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 f (Mtailcall sig (inl ident m0) :: c)) rs m + (Pbctr :: transl_code f c) rs5 (free m stk)). + simpl. apply exec_straight_step with rs2 m. + simpl. rewrite <- (ireg_val _ _ _ _ AG H6). 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 H2. simpl in H2. rewrite H2. + 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 H1; simpl in H1. + simpl. rewrite H1. 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 <- H7; 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 H12. + 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#GPR12 <- (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 f (Mtailcall sig (inr mreg i) :: c)) rs m + (Pbs i :: transl_code f 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 H2. simpl in H2. rewrite H2. + 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 H1; simpl in H1. + simpl. rewrite H1. 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 <- H7; 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 H12. + rewrite Pregmap.gso; auto with ppcgen. + unfold rs5; auto with ppcgen. +Qed. + +Lemma exec_Malloc_prop: + 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 -> + 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; inv MS. + left; eapply exec_straight_steps; eauto with coqlib. + simpl. eapply transl_alloc_correct; eauto. +Qed. + +Lemma exec_Mgoto_prop: + 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; 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]]]. + 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 (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; inv MS. assert (f0 = f) by congruence. subst f0. + generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). + intro WTI. inv WTI. + pose (k1 := + if snd (crbit_for_cond cond) + then Pbt (fst (crbit_for_cond cond)) lbl :: transl_code f c + else Pbf (fst (crbit_for_cond cond)) lbl :: transl_code f c). + generalize (transl_cond_correct tge (transl_function f) + cond args k1 ms sp rs m true H3 AG H). + simpl. intros [rs2 [EX [RES AG2]]]. + 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 _ _ _ FIND PC2 H1). + intros [rs3 [GOTO [AT3 INV3]]]. + 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. + econstructor; eauto. + eapply find_instr_tail. unfold k1 in CT2; rewrite ISSET in CT2. eauto. + simpl. rewrite RES. simpl. auto. + econstructor; eauto. + eapply find_instr_tail. unfold k1 in CT2; rewrite ISSET in CT2. eauto. + simpl. rewrite RES. simpl. auto. + traceEq. + econstructor; eauto. + eapply Mach.find_label_incl; eauto. + apply agree_exten_2 with rs2; auto. +Qed. + +Lemma exec_Mcond_false_prop: + 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; inv MS. + generalize (wt_function_instrs _ WTF _ (INCL _ (in_eq _ _))). + intro WTI. inversion WTI. + pose (k1 := + if snd (crbit_for_cond cond) + then Pbt (fst (crbit_for_cond cond)) lbl :: transl_code f c + else Pbf (fst (crbit_for_cond cond)) lbl :: transl_code f c). + generalize (transl_cond_correct tge (transl_function f) + cond args k1 ms sp rs m false H1 AG H). + simpl. intros [rs2 [EX [RES AG2]]]. + 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. + reflexivity. + unfold k1; rewrite ISSET; apply exec_straight_one. + simpl. rewrite RES. reflexivity. + reflexivity. + auto with ppcgen. +Qed. + +Lemma exec_Mreturn_prop: + forall (s : list stackframe) (fb stk : block) (soff : int) + (c : list Mach.instruction) (ms : Mach.regset) (m : mem) (f: Mach.function), + Genv.find_funct_ptr ge fb = Some (Internal f) -> + load_stack m (Vptr stk soff) Tint f.(fn_link_ofs) = Some (parent_sp s) -> + load_stack m (Vptr stk soff) Tint f.(fn_retaddr_ofs) = Some (parent_ra s) -> + exec_instr_prop (Machconcr.State s fb (Vptr stk soff) (Mreturn :: c) ms m) E0 + (Returnstate s ms (free m stk)). +Proof. + intros; red; intros; inv MS. + assert (f0 = f) by congruence. subst f0. + set (rs2 := nextinstr (rs#GPR12 <- (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 f (Mreturn :: c)) rs m + (Pblr :: transl_code f 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 H1. simpl in H1. + rewrite <- (sp_val _ _ _ AG). simpl. rewrite H1. + reflexivity. discriminate. + unfold rs3. change (parent_ra s) with rs2#GPR12. reflexivity. + simpl. change (rs3 GPR1) with (rs GPR1). rewrite <- (sp_val _ _ _ AG). + simpl. + unfold load_stack in H0. simpl in H0. + rewrite H0. 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 <- H3. simpl. eauto. + apply functions_transl; eauto. + generalize (functions_transl_no_overflow _ _ H4); intro NOOV. + simpl in H5. 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. + +Hypothesis wt_prog: wt_program prog. + +Lemma exec_function_internal_prop: + forall (s : list stackframe) (fb : block) (ms : Mach.regset) + (m : mem) (f : function) (m1 m2 m3 : mem) (stk : block), + Genv.find_funct_ptr ge fb = Some (Internal f) -> + alloc m (- fn_framesize f) (fn_stacksize f) = (m1, stk) -> + let sp := Vptr stk (Int.repr (- fn_framesize f)) in + store_stack m1 sp Tint f.(fn_link_ofs) (parent_sp s) = Some m2 -> + store_stack m2 sp Tint f.(fn_retaddr_ofs) (parent_ra s) = Some m3 -> + exec_instr_prop (Machconcr.Callstate s fb ms m) E0 + (Machconcr.State s fb sp (fn_code f) ms m3). +Proof. + 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 #GPR12 <- Vundef)). + set (rs3 := nextinstr (rs2#GPR12 <- (parent_ra s))). + set (rs4 := nextinstr rs3). + (* Execution of function prologue *) + assert (EXEC_PROLOGUE: + exec_straight tge (transl_function f) + (transl_function f) rs m + (transl_code f (fn_code f)) rs4 m3). + unfold transl_function at 2. + apply exec_straight_three with rs2 m2 rs3 m2. + unfold exec_instr. rewrite H0. fold sp. + unfold store_stack in H1. simpl chunk_of_type in H1. + rewrite <- (sp_val _ _ _ AG). rewrite H1. reflexivity. + simpl. change (rs2 LR) with (rs LR). rewrite ATLR. reflexivity. + simpl. unfold store1. rewrite gpr_or_zero_not_zero. + unfold const_low. change (rs3 GPR1) with sp. change (rs3 GPR12) 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. + 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. + repeat (rewrite Pregmap.gso). elim AG; auto. + auto with ppcgen. auto with ppcgen. auto with ppcgen. + assert (AG4: agree ms sp rs4). + unfold rs4, rs3; auto with ppcgen. + left; exists (State rs4 m3); split. + (* execution *) + eapply exec_straight_steps_1; eauto. + change (Int.unsigned Int.zero) with 0. constructor. + (* match states *) + econstructor; eauto with coqlib. +Qed. + +Lemma exec_function_external_prop: + forall (s : list stackframe) (fb : block) (ms : Mach.regset) + (m : mem) (t0 : trace) (ms' : RegEq.t -> val) + (ef : external_function) (args : list val) (res : val), + 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; 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. + unfold loc_external_result. auto with ppcgen. +Qed. + +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; inv MS. inv STACKS. simpl in *. + right. split. omega. split. auto. + econstructor; eauto. rewrite ATPC; auto. +Qed. + +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 + exec_Mgetparam_prop + exec_Mop_prop + 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_Mreturn_prop + exec_function_internal_prop + exec_function_external_prop + exec_return_prop). + +Lemma transf_initial_states: + forall st1, Machconcr.initial_state prog st1 -> + exists st2, Asm.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 -> Asm.final_state st2 r. +Proof. + intros. inv H0. inv H. constructor. auto. + compute in H1. + rewrite (ireg_val _ _ _ R3 AG) in H1. auto. auto. +Qed. + +Theorem transf_program_correct: + forall (beh: program_behavior), + Machconcr.exec_program prog beh -> Asm.exec_program tprog beh. +Proof. + unfold Machconcr.exec_program, Asm.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/powerpc/Asmgenproof1.v b/powerpc/Asmgenproof1.v new file mode 100644 index 0000000..c17cb73 --- /dev/null +++ b/powerpc/Asmgenproof1.v @@ -0,0 +1,1632 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Correctness proof for PPC generation: auxiliary results. *) + +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 Machconcr. +Require Import Machtyping. +Require Import Asm. +Require Import Asmgen. +Require Conventions. + +(** * Properties of low half/high half decomposition *) + +Lemma high_half_zero: + forall v, Val.add (high_half v) Vzero = high_half v. +Proof. + intros. generalize (high_half_type v). + rewrite Val.add_commut. + case (high_half v); simpl; intros; try contradiction. + auto. + rewrite Int.add_commut; rewrite Int.add_zero; auto. + rewrite Int.add_zero; auto. +Qed. + +Lemma low_high_u: + forall n, Int.or (Int.shl (high_u n) (Int.repr 16)) (low_u n) = n. +Proof. + intros. unfold high_u, low_u. + rewrite Int.shl_rolm. rewrite Int.shru_rolm. + rewrite Int.rolm_rolm. + change (Int.modu (Int.add (Int.sub (Int.repr (Z_of_nat wordsize)) (Int.repr 16)) + (Int.repr 16)) + (Int.repr (Z_of_nat wordsize))) + with (Int.zero). + rewrite Int.rolm_zero. rewrite <- Int.and_or_distrib. + exact (Int.and_mone n). + reflexivity. reflexivity. +Qed. + +Lemma low_high_u_xor: + forall n, Int.xor (Int.shl (high_u n) (Int.repr 16)) (low_u n) = n. +Proof. + intros. unfold high_u, low_u. + rewrite Int.shl_rolm. rewrite Int.shru_rolm. + rewrite Int.rolm_rolm. + change (Int.modu (Int.add (Int.sub (Int.repr (Z_of_nat wordsize)) (Int.repr 16)) + (Int.repr 16)) + (Int.repr (Z_of_nat wordsize))) + with (Int.zero). + rewrite Int.rolm_zero. rewrite <- Int.and_xor_distrib. + exact (Int.and_mone n). + reflexivity. reflexivity. +Qed. + +Lemma low_high_s: + forall n, Int.add (Int.shl (high_s n) (Int.repr 16)) (low_s n) = n. +Proof. + intros. rewrite Int.shl_mul_two_p. + unfold high_s. + rewrite <- (Int.divu_pow2 (Int.sub n (low_s n)) (Int.repr 65536) (Int.repr 16)). + change (two_p (Int.unsigned (Int.repr 16))) with 65536. + + assert (forall x y, y > 0 -> (x - x mod y) mod y = 0). + intros. apply Zmod_unique with (x / y). + generalize (Z_div_mod_eq x y H). intro. rewrite Zmult_comm. omega. + omega. + + assert (Int.modu (Int.sub n (low_s n)) (Int.repr 65536) = Int.zero). + unfold Int.modu, Int.zero. decEq. + change (Int.unsigned (Int.repr 65536)) with 65536. + unfold Int.sub. + assert (forall a b, Int.eqm a b -> b mod 65536 = 0 -> a mod 65536 = 0). + intros a b [k EQ] H1. rewrite EQ. + change modulus with (65536 * 65536). + rewrite Zmult_assoc. rewrite Zplus_comm. rewrite Z_mod_plus. auto. + omega. + eapply H0. apply Int.eqm_sym. apply Int.eqm_unsigned_repr. + unfold low_s. unfold Int.sign_ext. + change (two_p 16) with 65536. change (two_p (16-1)) with 32768. + set (N := Int.unsigned n). + case (zlt (N mod 65536) 32768); intro. + apply H0 with (N - N mod 65536). auto with ints. + apply H. omega. + apply H0 with (N - (N mod 65536 - 65536)). auto with ints. + replace (N - (N mod 65536 - 65536)) + with ((N - N mod 65536) + 1 * 65536). + rewrite Z_mod_plus. apply H. omega. omega. ring. + + assert (Int.repr 65536 <> Int.zero). compute. congruence. + generalize (Int.modu_divu_Euclid (Int.sub n (low_s n)) (Int.repr 65536) H1). + rewrite H0. rewrite Int.add_zero. intro. rewrite <- H2. + rewrite Int.sub_add_opp. rewrite Int.add_assoc. + replace (Int.add (Int.neg (low_s n)) (low_s n)) with Int.zero. + apply Int.add_zero. symmetry. rewrite Int.add_commut. + rewrite <- Int.sub_add_opp. apply Int.sub_idem. + + reflexivity. +Qed. + +(** * Correspondence between Mach registers and PPC registers *) + +Hint Extern 2 (_ <> _) => discriminate: ppcgen. + +(** Mapping from Mach registers to PPC registers. *) + +Lemma preg_of_injective: + forall r1 r2, preg_of r1 = preg_of r2 -> r1 = r2. +Proof. + destruct r1; destruct r2; simpl; intros; reflexivity || discriminate. +Qed. + +(** Characterization of PPC registers that correspond to Mach registers. *) + +Definition is_data_reg (r: preg) : Prop := + match r with + | IR GPR12 => False + | FR FPR13 => False + | PC => False | LR => False | CTR => False + | CR0_0 => False | CR0_1 => False | CR0_2 => False | CR0_3 => False + | CARRY => False + | _ => True + end. + +Lemma ireg_of_is_data_reg: + forall (r: mreg), is_data_reg (ireg_of r). +Proof. + destruct r; exact I. +Qed. + +Lemma freg_of_is_data_reg: + forall (r: mreg), is_data_reg (ireg_of r). +Proof. + destruct r; exact I. +Qed. + +Lemma preg_of_is_data_reg: + forall (r: mreg), is_data_reg (preg_of r). +Proof. + destruct r; exact I. +Qed. + +Lemma ireg_of_not_GPR1: + forall r, ireg_of r <> GPR1. +Proof. + intro. case r; discriminate. +Qed. +Lemma ireg_of_not_GPR12: + forall r, ireg_of r <> GPR12. +Proof. + intro. case r; discriminate. +Qed. +Lemma freg_of_not_FPR13: + forall r, freg_of r <> FPR13. +Proof. + intro. case r; discriminate. +Qed. +Hint Resolve ireg_of_not_GPR1 ireg_of_not_GPR12 freg_of_not_FPR13: ppcgen. + +Lemma preg_of_not: + forall r1 r2, ~(is_data_reg r2) -> preg_of r1 <> r2. +Proof. + intros; red; intro. subst r2. elim H. apply preg_of_is_data_reg. +Qed. +Hint Resolve preg_of_not: ppcgen. + +Lemma preg_of_not_GPR1: + forall r, preg_of r <> GPR1. +Proof. + intro. case r; discriminate. +Qed. +Hint Resolve preg_of_not_GPR1: ppcgen. + +(** Agreement between Mach register sets and PPC register sets. *) + +Definition agree (ms: Mach.regset) (sp: val) (rs: Asm.regset) := + rs#GPR1 = sp /\ forall r: mreg, ms r = rs#(preg_of r). + +Lemma preg_val: + forall ms sp rs r, + agree ms sp rs -> ms r = rs#(preg_of r). +Proof. + intros. elim H. auto. +Qed. + +Lemma ireg_val: + forall ms sp rs r, + agree ms sp rs -> + mreg_type r = Tint -> + ms r = rs#(ireg_of r). +Proof. + intros. elim H; intros. + generalize (H2 r). unfold preg_of. rewrite H0. auto. +Qed. + +Lemma freg_val: + forall ms sp rs r, + agree ms sp rs -> + mreg_type r = Tfloat -> + ms r = rs#(freg_of r). +Proof. + intros. elim H; intros. + generalize (H2 r). unfold preg_of. rewrite H0. auto. +Qed. + +Lemma sp_val: + forall ms sp rs, + agree ms sp rs -> + sp = rs#GPR1. +Proof. + intros. elim H; auto. +Qed. + +Lemma agree_exten_1: + forall ms sp rs rs', + agree ms sp rs -> + (forall r, is_data_reg r -> rs'#r = rs#r) -> + agree ms sp rs'. +Proof. + unfold agree; intros. elim H; intros. + split. rewrite H0. auto. exact I. + intros. rewrite H0. auto. apply preg_of_is_data_reg. +Qed. + +Lemma agree_exten_2: + forall ms sp rs rs', + agree ms sp rs -> + (forall r, + r <> IR GPR12 -> r <> FR FPR13 -> + r <> PC -> r <> LR -> r <> CTR -> + r <> CR0_0 -> r <> CR0_1 -> r <> CR0_2 -> r <> CR0_3 -> + r <> CARRY -> + rs'#r = rs#r) -> + agree ms sp rs'. +Proof. + intros. apply agree_exten_1 with rs. auto. + intros. apply H0; (red; intro; subst r; elim H1). +Qed. + +(** Preservation of register agreement under various assignments. *) + +Lemma agree_set_mreg: + forall ms sp rs r v, + agree ms sp rs -> + agree (Regmap.set r v ms) sp (rs#(preg_of r) <- v). +Proof. + unfold agree; intros. elim H; intros; clear H. + split. rewrite Pregmap.gso. auto. apply sym_not_eq. apply preg_of_not_GPR1. + intros. unfold Regmap.set. case (RegEq.eq r0 r); intro. + subst r0. rewrite Pregmap.gss. auto. + rewrite Pregmap.gso. auto. red; intro. + elim n. apply preg_of_injective; auto. +Qed. +Hint Resolve agree_set_mreg: ppcgen. + +Lemma agree_set_mireg: + forall ms sp rs r v, + agree ms sp (rs#(preg_of r) <- v) -> + mreg_type r = Tint -> + agree ms sp (rs#(ireg_of r) <- v). +Proof. + intros. unfold preg_of in H. rewrite H0 in H. auto. +Qed. +Hint Resolve agree_set_mireg: ppcgen. + +Lemma agree_set_mfreg: + forall ms sp rs r v, + agree ms sp (rs#(preg_of r) <- v) -> + mreg_type r = Tfloat -> + agree ms sp (rs#(freg_of r) <- v). +Proof. + intros. unfold preg_of in H. rewrite H0 in H. auto. +Qed. +Hint Resolve agree_set_mfreg: ppcgen. + +Lemma agree_set_other: + forall ms sp rs r v, + agree ms sp rs -> + ~(is_data_reg r) -> + agree ms sp (rs#r <- v). +Proof. + intros. apply agree_exten_1 with rs. + auto. intros. apply Pregmap.gso. red; intro; subst r0; contradiction. +Qed. +Hint Resolve agree_set_other: ppcgen. + +Lemma agree_nextinstr: + forall ms sp rs, + agree ms sp rs -> agree ms sp (nextinstr rs). +Proof. + intros. unfold nextinstr. apply agree_set_other. auto. auto. +Qed. +Hint Resolve agree_nextinstr: ppcgen. + +Lemma agree_set_mireg_twice: + forall ms sp rs r v v', + agree ms sp rs -> + mreg_type r = Tint -> + agree (Regmap.set r v ms) sp (rs #(ireg_of r) <- v' #(ireg_of r) <- v). +Proof. + intros. replace (IR (ireg_of r)) with (preg_of r). elim H; intros. + split. repeat (rewrite Pregmap.gso; auto with ppcgen). + intros. case (mreg_eq r r0); intro. + subst r0. rewrite Regmap.gss. rewrite Pregmap.gss. auto. + assert (preg_of r <> preg_of r0). + red; intro. elim n. apply preg_of_injective. auto. + rewrite Regmap.gso; auto. + repeat (rewrite Pregmap.gso; auto). + unfold preg_of. rewrite H0. auto. +Qed. +Hint Resolve agree_set_mireg_twice: ppcgen. + +Lemma agree_set_twice_mireg: + forall ms sp rs r v v', + agree (Regmap.set r v' ms) sp rs -> + mreg_type r = Tint -> + agree (Regmap.set r v ms) sp (rs#(ireg_of r) <- v). +Proof. + intros. elim H; intros. + split. rewrite Pregmap.gso. auto. + generalize (ireg_of_not_GPR1 r); congruence. + intros. generalize (H2 r0). + case (mreg_eq r0 r); intro. + subst r0. repeat rewrite Regmap.gss. unfold preg_of; rewrite H0. + rewrite Pregmap.gss. auto. + repeat rewrite Regmap.gso; auto. + rewrite Pregmap.gso. auto. + replace (IR (ireg_of r)) with (preg_of r). + red; intros. elim n. apply preg_of_injective; auto. + unfold preg_of. rewrite H0. auto. +Qed. +Hint Resolve agree_set_twice_mireg: ppcgen. + +Lemma agree_set_commut: + forall ms sp rs r1 r2 v1 v2, + r1 <> r2 -> + agree ms sp ((rs#r2 <- v2)#r1 <- v1) -> + agree ms sp ((rs#r1 <- v1)#r2 <- v2). +Proof. + intros. apply agree_exten_1 with ((rs#r2 <- v2)#r1 <- v1). auto. + intros. + case (preg_eq r r1); intro. + subst r1. rewrite Pregmap.gss. rewrite Pregmap.gso. rewrite Pregmap.gss. + auto. auto. + case (preg_eq r r2); intro. + subst r2. rewrite Pregmap.gss. rewrite Pregmap.gso. rewrite Pregmap.gss. + auto. auto. + repeat (rewrite Pregmap.gso; auto). +Qed. +Hint Resolve agree_set_commut: ppcgen. + +Lemma agree_nextinstr_commut: + forall ms sp rs r v, + agree ms sp (rs#r <- v) -> + r <> PC -> + agree ms sp ((nextinstr rs)#r <- v). +Proof. + intros. unfold nextinstr. apply agree_set_commut. auto. + apply agree_set_other. auto. auto. +Qed. +Hint Resolve agree_nextinstr_commut: ppcgen. + +Lemma agree_set_mireg_exten: + forall ms sp rs r v (rs': regset), + agree ms sp rs -> + mreg_type r = Tint -> + rs'#(ireg_of r) = v -> + (forall r', + r' <> IR GPR12 -> r' <> FR FPR13 -> + r' <> PC -> r' <> LR -> r' <> CTR -> + r' <> CR0_0 -> r' <> CR0_1 -> r' <> CR0_2 -> r' <> CR0_3 -> + r' <> CARRY -> + r' <> IR (ireg_of r) -> rs'#r' = rs#r') -> + agree (Regmap.set r v ms) sp rs'. +Proof. + intros. apply agree_exten_2 with (rs#(ireg_of r) <- v). + auto with ppcgen. + intros. unfold Pregmap.set. case (PregEq.eq r0 (ireg_of r)); intro. + subst r0. auto. apply H2; auto. +Qed. + +(** Useful properties of the PC and GPR0 registers. *) + +Lemma nextinstr_inv: + forall r rs, r <> PC -> (nextinstr rs)#r = rs#r. +Proof. + intros. unfold nextinstr. apply Pregmap.gso. auto. +Qed. +Hint Resolve nextinstr_inv: ppcgen. + +Lemma nextinstr_set_preg: + forall rs m v, + (nextinstr (rs#(preg_of m) <- v))#PC = Val.add rs#PC Vone. +Proof. + intros. unfold nextinstr. rewrite Pregmap.gss. + rewrite Pregmap.gso. auto. apply sym_not_eq. auto with ppcgen. +Qed. +Hint Resolve nextinstr_set_preg: ppcgen. + +Lemma gpr_or_zero_not_zero: + forall rs r, r <> GPR0 -> gpr_or_zero rs r = rs#r. +Proof. + intros. unfold gpr_or_zero. case (ireg_eq r GPR0); tauto. +Qed. +Lemma gpr_or_zero_zero: + forall rs, gpr_or_zero rs GPR0 = Vzero. +Proof. + intros. reflexivity. +Qed. +Hint Resolve gpr_or_zero_not_zero gpr_or_zero_zero: ppcgen. + +(** Connection between Mach and Asm calling conventions for external + functions. *) + +Lemma extcall_arg_match: + forall ms sp rs m l v, + agree ms sp rs -> + Machconcr.extcall_arg ms m sp l v -> + Asm.extcall_arg rs m l v. +Proof. + intros. inv H0. + rewrite (preg_val _ _ _ r H). constructor. + rewrite (sp_val _ _ _ H) in H1. + destruct ty; unfold load_stack in H1. + econstructor. reflexivity. assumption. + econstructor. reflexivity. assumption. +Qed. + +Lemma extcall_args_match: + forall ms sp rs m, agree ms sp rs -> + forall ll vl, + Machconcr.extcall_args ms m sp ll vl -> + Asm.extcall_args rs m ll vl. +Proof. + induction 2; constructor; auto. eapply extcall_arg_match; eauto. +Qed. + +Lemma extcall_arguments_match: + forall ms m sp rs sg args, + agree ms sp rs -> + Machconcr.extcall_arguments ms m sp sg args -> + Asm.extcall_arguments rs m sg args. +Proof. + unfold Machconcr.extcall_arguments, Asm.extcall_arguments; intros. + eapply extcall_args_match; eauto. +Qed. + +(** * Execution of straight-line code *) + +Section STRAIGHTLINE. + +Variable ge: genv. +Variable fn: code. + +(** Straight-line code is composed of PPC instructions that execute + in sequence (no branches, no function calls and returns). + The following inductive predicate relates the machine states + before and after executing a straight-line sequence of instructions. + Instructions are taken from the first list instead of being fetched + from memory. *) + +Inductive exec_straight: code -> regset -> mem -> + code -> regset -> mem -> Prop := + | 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 -> + rs2#PC = Val.add rs1#PC Vone -> + exec_straight c rs2 m2 c' rs3 m3 -> + exec_straight (i :: c) rs1 m1 c' rs3 m3. + +Lemma exec_straight_trans: + forall c1 rs1 m1 c2 rs2 m2 c3 rs3 m3, + exec_straight c1 rs1 m1 c2 rs2 m2 -> + exec_straight c2 rs2 m2 c3 rs3 m3 -> + exec_straight c1 rs1 m1 c3 rs3 m3. +Proof. + induction 1; intros. + apply exec_straight_step with rs2 m2; auto. + apply exec_straight_step with rs2 m2; auto. +Qed. + +Lemma exec_straight_two: + forall i1 i2 c rs1 m1 rs2 m2 rs3 m3, + exec_instr ge fn i1 rs1 m1 = OK rs2 m2 -> + exec_instr ge fn i2 rs2 m2 = OK rs3 m3 -> + rs2#PC = Val.add rs1#PC Vone -> + rs3#PC = Val.add rs2#PC Vone -> + exec_straight (i1 :: i2 :: c) rs1 m1 c rs3 m3. +Proof. + intros. apply exec_straight_step with rs2 m2; auto. + apply exec_straight_one; auto. +Qed. + +Lemma exec_straight_three: + forall i1 i2 i3 c rs1 m1 rs2 m2 rs3 m3 rs4 m4, + exec_instr ge fn i1 rs1 m1 = OK rs2 m2 -> + exec_instr ge fn i2 rs2 m2 = OK rs3 m3 -> + exec_instr ge fn i3 rs3 m3 = OK rs4 m4 -> + rs2#PC = Val.add rs1#PC Vone -> + rs3#PC = Val.add rs2#PC Vone -> + rs4#PC = Val.add rs3#PC Vone -> + exec_straight (i1 :: i2 :: i3 :: c) rs1 m1 c rs4 m4. +Proof. + intros. apply exec_straight_step with rs2 m2; auto. + eapply exec_straight_two; eauto. +Qed. + +(** * Correctness of PowerPC constructor functions *) + +(** Properties of comparisons. *) + +Lemma compare_float_spec: + forall rs v1 v2, + let rs1 := nextinstr (compare_float rs v1 v2) in + rs1#CR0_0 = Val.cmpf Clt v1 v2 + /\ rs1#CR0_1 = Val.cmpf Cgt v1 v2 + /\ rs1#CR0_2 = Val.cmpf Ceq v1 v2 + /\ forall r', r' <> PC -> r' <> CR0_0 -> r' <> CR0_1 -> + r' <> CR0_2 -> r' <> CR0_3 -> rs1#r' = rs#r'. +Proof. + intros. unfold rs1. + split. reflexivity. + split. reflexivity. + split. reflexivity. + intros. rewrite nextinstr_inv; auto. + unfold compare_float. repeat (rewrite Pregmap.gso; auto). +Qed. + +Lemma compare_sint_spec: + forall rs v1 v2, + let rs1 := nextinstr (compare_sint rs v1 v2) in + rs1#CR0_0 = Val.cmp Clt v1 v2 + /\ rs1#CR0_1 = Val.cmp Cgt v1 v2 + /\ rs1#CR0_2 = Val.cmp Ceq v1 v2 + /\ forall r', r' <> PC -> r' <> CR0_0 -> r' <> CR0_1 -> + r' <> CR0_2 -> r' <> CR0_3 -> rs1#r' = rs#r'. +Proof. + intros. unfold rs1. + split. reflexivity. + split. reflexivity. + split. reflexivity. + intros. rewrite nextinstr_inv; auto. + unfold compare_sint. repeat (rewrite Pregmap.gso; auto). +Qed. + +Lemma compare_uint_spec: + forall rs v1 v2, + let rs1 := nextinstr (compare_uint rs v1 v2) in + rs1#CR0_0 = Val.cmpu Clt v1 v2 + /\ rs1#CR0_1 = Val.cmpu Cgt v1 v2 + /\ rs1#CR0_2 = Val.cmpu Ceq v1 v2 + /\ forall r', r' <> PC -> r' <> CR0_0 -> r' <> CR0_1 -> + r' <> CR0_2 -> r' <> CR0_3 -> rs1#r' = rs#r'. +Proof. + intros. unfold rs1. + split. reflexivity. + split. reflexivity. + split. reflexivity. + intros. rewrite nextinstr_inv; auto. + unfold compare_uint. repeat (rewrite Pregmap.gso; auto). +Qed. + +(** Loading a constant. *) + +Lemma loadimm_correct: + forall r n k rs m, + exists rs', + exec_straight (loadimm r n k) rs m k rs' m + /\ rs'#r = Vint n + /\ forall r': preg, r' <> r -> r' <> PC -> rs'#r' = rs#r'. +Proof. + intros. unfold loadimm. + case (Int.eq (high_s n) Int.zero). + (* addi *) + exists (nextinstr (rs#r <- (Vint n))). + split. apply exec_straight_one. + simpl. rewrite Int.add_commut. rewrite Int.add_zero. reflexivity. + reflexivity. + split. rewrite nextinstr_inv; auto with ppcgen. + apply Pregmap.gss. + intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto. + (* addis *) + generalize (Int.eq_spec (low_s n) Int.zero); case (Int.eq (low_s n) Int.zero); intro. + exists (nextinstr (rs#r <- (Vint n))). + split. apply exec_straight_one. + simpl. rewrite Int.add_commut. + rewrite <- H. rewrite low_high_s. reflexivity. + reflexivity. + split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. + intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto. + (* addis + ori *) + pose (rs1 := nextinstr (rs#r <- (Vint (Int.shl (high_u n) (Int.repr 16))))). + exists (nextinstr (rs1#r <- (Vint n))). + split. eapply exec_straight_two. + simpl. rewrite Int.add_commut. rewrite Int.add_zero. reflexivity. + simpl. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss. + unfold Val.or. rewrite low_high_u. reflexivity. + reflexivity. reflexivity. + split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. + intros. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. + unfold rs1. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. +Qed. + +(** Add integer immediate. *) + +Lemma addimm_1_correct: + forall r1 r2 n k rs m, + r1 <> GPR0 -> + r2 <> GPR0 -> + exists rs', + exec_straight (addimm_1 r1 r2 n k) rs m k rs' m + /\ rs'#r1 = Val.add rs#r2 (Vint n) + /\ forall r': preg, r' <> r1 -> r' <> PC -> rs'#r' = rs#r'. +Proof. + intros. unfold addimm_1. + (* addi *) + case (Int.eq (high_s n) Int.zero). + exists (nextinstr (rs#r1 <- (Val.add rs#r2 (Vint n)))). + split. apply exec_straight_one. + simpl. rewrite gpr_or_zero_not_zero; auto. + reflexivity. + split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. + intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto. + (* addis *) + generalize (Int.eq_spec (low_s n) Int.zero); case (Int.eq (low_s n) Int.zero); intro. + exists (nextinstr (rs#r1 <- (Val.add rs#r2 (Vint n)))). + split. apply exec_straight_one. + simpl. rewrite gpr_or_zero_not_zero; auto. + generalize (low_high_s n). rewrite H1. rewrite Int.add_zero. intro. + rewrite H2. auto. + reflexivity. + split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. + intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto. + (* addis + addi *) + pose (rs1 := nextinstr (rs#r1 <- (Val.add rs#r2 (Vint (Int.shl (high_s n) (Int.repr 16)))))). + exists (nextinstr (rs1#r1 <- (Val.add rs#r2 (Vint n)))). + split. apply exec_straight_two with rs1 m. + simpl. rewrite gpr_or_zero_not_zero; auto. + simpl. rewrite gpr_or_zero_not_zero; auto. + unfold rs1 at 1. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss. + rewrite Val.add_assoc. simpl. rewrite low_high_s. auto. + reflexivity. reflexivity. + split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. + intros. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. + unfold rs1. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto. +Qed. + +Lemma addimm_2_correct: + forall r1 r2 n k rs m, + r2 <> GPR12 -> + exists rs', + exec_straight (addimm_2 r1 r2 n k) rs m k rs' m + /\ rs'#r1 = Val.add rs#r2 (Vint n) + /\ forall r': preg, r' <> r1 -> r' <> GPR12 -> r' <> PC -> rs'#r' = rs#r'. +Proof. + intros. unfold addimm_2. + generalize (loadimm_correct GPR12 n (Padd r1 r2 GPR12 :: k) rs m). + intros [rs1 [EX [RES OTHER]]]. + exists (nextinstr (rs1#r1 <- (Val.add rs#r2 (Vint n)))). + split. eapply exec_straight_trans. eexact EX. + apply exec_straight_one. simpl. rewrite RES. rewrite OTHER. + auto. congruence. discriminate. + reflexivity. + split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. + intros. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. +Qed. + +Lemma addimm_correct: + forall r1 r2 n k rs m, + r2 <> GPR12 -> + exists rs', + exec_straight (addimm r1 r2 n k) rs m k rs' m + /\ rs'#r1 = Val.add rs#r2 (Vint n) + /\ forall r': preg, r' <> r1 -> r' <> GPR12 -> r' <> PC -> rs'#r' = rs#r'. +Proof. + intros. unfold addimm. + case (ireg_eq r1 GPR0); intro. + apply addimm_2_correct; auto. + case (ireg_eq r2 GPR0); intro. + apply addimm_2_correct; auto. + generalize (addimm_1_correct r1 r2 n k rs m n0 n1). + intros [rs' [EX [RES OTH]]]. exists rs'. intuition. +Qed. + +(** And integer immediate. *) + +Lemma andimm_correct: + forall r1 r2 n k (rs : regset) m, + r2 <> GPR12 -> + let v := Val.and rs#r2 (Vint n) in + exists rs', + exec_straight (andimm r1 r2 n k) rs m k rs' m + /\ rs'#r1 = v + /\ rs'#CR0_2 = Val.cmp Ceq v Vzero + /\ forall r': preg, + r' <> r1 -> r' <> GPR12 -> r' <> PC -> + r' <> CR0_0 -> r' <> CR0_1 -> r' <> CR0_2 -> r' <> CR0_3 -> + rs'#r' = rs#r'. +Proof. + intros. unfold andimm. + case (Int.eq (high_u n) Int.zero). + (* andi *) + exists (nextinstr (compare_sint (rs#r1 <- v) v Vzero)). + generalize (compare_sint_spec (rs#r1 <- v) v Vzero). + intros [A [B [C D]]]. + split. apply exec_straight_one. reflexivity. reflexivity. + split. rewrite D; try discriminate. apply Pregmap.gss. + split. auto. + intros. rewrite D; auto. apply Pregmap.gso; auto. + (* andis *) + generalize (Int.eq_spec (low_u n) Int.zero); + case (Int.eq (low_u n) Int.zero); intro. + exists (nextinstr (compare_sint (rs#r1 <- v) v Vzero)). + generalize (compare_sint_spec (rs#r1 <- v) v Vzero). + intros [A [B [C D]]]. + split. apply exec_straight_one. simpl. + generalize (low_high_u n). rewrite H0. rewrite Int.or_zero. + intro. rewrite H1. reflexivity. reflexivity. + split. rewrite D; try discriminate. apply Pregmap.gss. + split. auto. + intros. rewrite D; auto. apply Pregmap.gso; auto. + (* loadimm + and *) + generalize (loadimm_correct GPR12 n (Pand_ r1 r2 GPR12 :: k) rs m). + intros [rs1 [EX1 [RES1 OTHER1]]]. + exists (nextinstr (compare_sint (rs1#r1 <- v) v Vzero)). + generalize (compare_sint_spec (rs1#r1 <- v) v Vzero). + intros [A [B [C D]]]. + split. eapply exec_straight_trans. eexact EX1. + apply exec_straight_one. simpl. rewrite RES1. + rewrite (OTHER1 r2). reflexivity. congruence. congruence. + reflexivity. + split. rewrite D; try discriminate. apply Pregmap.gss. + split. auto. + intros. rewrite D; auto. rewrite Pregmap.gso; auto. +Qed. + +(** Or integer immediate. *) + +Lemma orimm_correct: + forall r1 (r2: ireg) n k (rs : regset) m, + let v := Val.or rs#r2 (Vint n) in + exists rs', + exec_straight (orimm r1 r2 n k) rs m k rs' m + /\ rs'#r1 = v + /\ forall r': preg, r' <> r1 -> r' <> PC -> rs'#r' = rs#r'. +Proof. + intros. unfold orimm. + case (Int.eq (high_u n) Int.zero). + (* ori *) + exists (nextinstr (rs#r1 <- v)). + split. apply exec_straight_one. reflexivity. reflexivity. + split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. + intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto. + (* oris *) + generalize (Int.eq_spec (low_u n) Int.zero); + case (Int.eq (low_u n) Int.zero); intro. + exists (nextinstr (rs#r1 <- v)). + split. apply exec_straight_one. simpl. + generalize (low_high_u n). rewrite H. rewrite Int.or_zero. + intro. rewrite H0. reflexivity. reflexivity. + split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. + intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto. + (* oris + ori *) + pose (rs1 := nextinstr (rs#r1 <- (Val.or rs#r2 (Vint (Int.shl (high_u n) (Int.repr 16)))))). + exists (nextinstr (rs1#r1 <- v)). + split. apply exec_straight_two with rs1 m. + reflexivity. simpl. unfold rs1 at 1. + rewrite nextinstr_inv; auto with ppcgen. + rewrite Pregmap.gss. rewrite Val.or_assoc. simpl. + rewrite low_high_u. reflexivity. reflexivity. reflexivity. + split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. + intros. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. + unfold rs1. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. +Qed. + +(** Xor integer immediate. *) + +Lemma xorimm_correct: + forall r1 (r2: ireg) n k (rs : regset) m, + let v := Val.xor rs#r2 (Vint n) in + exists rs', + exec_straight (xorimm r1 r2 n k) rs m k rs' m + /\ rs'#r1 = v + /\ forall r': preg, r' <> r1 -> r' <> PC -> rs'#r' = rs#r'. +Proof. + intros. unfold xorimm. + case (Int.eq (high_u n) Int.zero). + (* xori *) + exists (nextinstr (rs#r1 <- v)). + split. apply exec_straight_one. reflexivity. reflexivity. + split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. + intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto. + (* xoris *) + generalize (Int.eq_spec (low_u n) Int.zero); + case (Int.eq (low_u n) Int.zero); intro. + exists (nextinstr (rs#r1 <- v)). + split. apply exec_straight_one. simpl. + generalize (low_high_u_xor n). rewrite H. rewrite Int.xor_zero. + intro. rewrite H0. reflexivity. reflexivity. + split. rewrite nextinstr_inv; auto with ppcgen. apply Pregmap.gss. + intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto. + (* xoris + xori *) + pose (rs1 := nextinstr (rs#r1 <- (Val.xor rs#r2 (Vint (Int.shl (high_u n) (Int.repr 16)))))). + exists (nextinstr (rs1#r1 <- v)). + split. apply exec_straight_two with rs1 m. + reflexivity. simpl. unfold rs1 at 1. + rewrite nextinstr_inv; try discriminate. + rewrite Pregmap.gss. rewrite Val.xor_assoc. simpl. + rewrite low_high_u_xor. reflexivity. reflexivity. reflexivity. + split. rewrite nextinstr_inv; auto with ppcgen. + apply Pregmap.gss. + intros. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. + unfold rs1. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. +Qed. + +(** Indexed memory loads. *) + +Lemma loadind_aux_correct: + forall (base: ireg) ofs ty dst (rs: regset) m v, + Mem.loadv (chunk_of_type ty) m (Val.add rs#base (Vint ofs)) = Some v -> + mreg_type dst = ty -> + base <> GPR0 -> + exec_instr ge fn (loadind_aux base ofs ty dst) rs m = + OK (nextinstr (rs#(preg_of dst) <- v)) m. +Proof. + intros. unfold loadind_aux. unfold preg_of. rewrite H0. destruct ty. + simpl. unfold load1. rewrite gpr_or_zero_not_zero; auto. + unfold const_low. simpl in H. rewrite H. auto. + simpl. unfold load1. rewrite gpr_or_zero_not_zero; auto. + unfold const_low. simpl in H. rewrite H. auto. +Qed. + +Lemma loadind_correct: + forall (base: ireg) ofs ty dst k (rs: regset) m v, + Mem.loadv (chunk_of_type ty) m (Val.add rs#base (Vint ofs)) = Some v -> + mreg_type dst = ty -> + base <> GPR0 -> + exists rs', + exec_straight (loadind base ofs ty dst k) rs m k rs' m + /\ rs'#(preg_of dst) = v + /\ forall r, r <> PC -> r <> GPR12 -> r <> preg_of dst -> rs'#r = rs#r. +Proof. + intros. unfold loadind. + assert (preg_of dst <> PC). + unfold preg_of. case (mreg_type dst); discriminate. + (* short offset *) + case (Int.eq (high_s ofs) Int.zero). + exists (nextinstr (rs#(preg_of dst) <- v)). + split. apply exec_straight_one. apply loadind_aux_correct; auto. + unfold nextinstr. rewrite Pregmap.gss. rewrite Pregmap.gso. auto. auto. + split. rewrite nextinstr_inv; auto. apply Pregmap.gss. + intros. rewrite nextinstr_inv; auto. apply Pregmap.gso; auto. + (* long offset *) + pose (rs1 := nextinstr (rs#GPR12 <- (Val.add rs#base (Vint (Int.shl (high_s ofs) (Int.repr 16)))))). + exists (nextinstr (rs1#(preg_of dst) <- v)). + split. apply exec_straight_two with rs1 m. + simpl. rewrite gpr_or_zero_not_zero; auto. + apply loadind_aux_correct. + unfold rs1. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss. + rewrite Val.add_assoc. simpl. rewrite low_high_s. assumption. + auto. discriminate. reflexivity. + unfold nextinstr. rewrite Pregmap.gss. rewrite Pregmap.gso. auto. auto. + split. rewrite nextinstr_inv; auto. apply Pregmap.gss. + intros. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. + unfold rs1. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. +Qed. + +(** Indexed memory stores. *) + +Lemma storeind_aux_correct: + forall (base: ireg) ofs ty src (rs: regset) m m', + Mem.storev (chunk_of_type ty) m (Val.add rs#base (Vint ofs)) (rs#(preg_of src)) = Some m' -> + mreg_type src = ty -> + base <> GPR0 -> + exec_instr ge fn (storeind_aux src base ofs ty) rs m = + OK (nextinstr rs) m'. +Proof. + intros. unfold storeind_aux. unfold preg_of in H. rewrite H0 in H. destruct ty. + simpl. unfold store1. rewrite gpr_or_zero_not_zero; auto. + unfold const_low. simpl in H. rewrite H. auto. + simpl. unfold store1. rewrite gpr_or_zero_not_zero; auto. + unfold const_low. simpl in H. rewrite H. auto. +Qed. + +Lemma storeind_correct: + forall (base: ireg) ofs ty src k (rs: regset) m m', + Mem.storev (chunk_of_type ty) m (Val.add rs#base (Vint ofs)) (rs#(preg_of src)) = Some m' -> + mreg_type src = ty -> + base <> GPR0 -> + exists rs', + exec_straight (storeind src base ofs ty k) rs m k rs' m' + /\ forall r, r <> PC -> r <> GPR12 -> rs'#r = rs#r. +Proof. + intros. unfold storeind. + (* short offset *) + case (Int.eq (high_s ofs) Int.zero). + exists (nextinstr rs). + split. apply exec_straight_one. apply storeind_aux_correct; auto. + reflexivity. + intros. rewrite nextinstr_inv; auto. + (* long offset *) + pose (rs1 := nextinstr (rs#GPR12 <- (Val.add rs#base (Vint (Int.shl (high_s ofs) (Int.repr 16)))))). + exists (nextinstr rs1). + split. apply exec_straight_two with rs1 m. + simpl. rewrite gpr_or_zero_not_zero; auto. + apply storeind_aux_correct; auto with ppcgen. + unfold rs1. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss. + rewrite nextinstr_inv; auto with ppcgen. + rewrite Pregmap.gso; auto with ppcgen. + rewrite Val.add_assoc. simpl. rewrite low_high_s. assumption. + reflexivity. reflexivity. + intros. rewrite nextinstr_inv; auto. + unfold rs1. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. +Qed. + +(** Float comparisons. *) + +Lemma floatcomp_correct: + forall cmp (r1 r2: freg) k rs m, + exists rs', + exec_straight (floatcomp cmp r1 r2 k) rs m k rs' m + /\ rs'#(reg_of_crbit (fst (crbit_for_fcmp cmp))) = + (if snd (crbit_for_fcmp cmp) + then Val.cmpf cmp rs#r1 rs#r2 + else Val.notbool (Val.cmpf cmp rs#r1 rs#r2)) + /\ forall r', + r' <> PC -> r' <> CR0_0 -> r' <> CR0_1 -> + r' <> CR0_2 -> r' <> CR0_3 -> rs'#r' = rs#r'. +Proof. + intros. + generalize (compare_float_spec rs rs#r1 rs#r2). + intros [A [B [C D]]]. + set (rs1 := nextinstr (compare_float rs rs#r1 rs#r2)) in *. + assert ((cmp = Ceq \/ cmp = Cne \/ cmp = Clt \/ cmp = Cgt) + \/ (cmp = Cle \/ cmp = Cge)). + case cmp; tauto. + unfold floatcomp. elim H; intro; clear H. + exists rs1. + split. generalize H0; intros [EQ|[EQ|[EQ|EQ]]]; subst cmp; + apply exec_straight_one; reflexivity. + split. + generalize H0; intros [EQ|[EQ|[EQ|EQ]]]; subst cmp; simpl; auto. + rewrite Val.negate_cmpf_eq. auto. + auto. + (* two instrs *) + exists (nextinstr (rs1#CR0_3 <- (Val.cmpf cmp rs#r1 rs#r2))). + split. elim H0; intro; subst cmp. + apply exec_straight_two with rs1 m. + reflexivity. simpl. + rewrite C; rewrite A. rewrite Val.or_commut. rewrite <- Val.cmpf_le. + reflexivity. reflexivity. reflexivity. + apply exec_straight_two with rs1 m. + reflexivity. simpl. + rewrite C; rewrite B. rewrite Val.or_commut. rewrite <- Val.cmpf_ge. + reflexivity. reflexivity. reflexivity. + split. elim H0; intro; subst cmp; simpl. + reflexivity. + reflexivity. + intros. rewrite nextinstr_inv; auto. rewrite Pregmap.gso; auto. +Qed. + +Ltac TypeInv := + match goal with + | H: (List.map ?f ?x = nil) |- _ => + destruct x; [clear H | simpl in H; discriminate] + | H: (List.map ?f ?x = ?hd :: ?tl) |- _ => + destruct x; simpl in H; + [ discriminate | + injection H; clear H; let T := fresh "T" in ( + intros H T; TypeInv) ] + | _ => idtac + end. + +(** Translation of conditions. *) + +Lemma transl_cond_correct_aux: + forall cond args k ms sp rs m, + map mreg_type args = type_of_condition cond -> + agree ms sp rs -> + exists rs', + exec_straight (transl_cond cond args k) rs m k rs' m + /\ rs'#(reg_of_crbit (fst (crbit_for_cond cond))) = + (if snd (crbit_for_cond cond) + then eval_condition_total cond (map ms args) + else Val.notbool (eval_condition_total cond (map ms args))) + /\ agree ms sp rs'. +Proof. + intros. destruct cond; simpl in H; TypeInv. + (* Ccomp *) + simpl. + generalize (compare_sint_spec rs ms#m0 ms#m1). + intros [A [B [C D]]]. + exists (nextinstr (compare_sint rs ms#m0 ms#m1)). + split. apply exec_straight_one. simpl. + repeat (rewrite <- (ireg_val ms sp rs); auto). + reflexivity. + split. + case c; simpl; auto; rewrite <- Val.negate_cmp; simpl; auto. + apply agree_exten_2 with rs; auto. + (* Ccompu *) + simpl. + generalize (compare_uint_spec rs ms#m0 ms#m1). + intros [A [B [C D]]]. + exists (nextinstr (compare_uint rs ms#m0 ms#m1)). + split. apply exec_straight_one. simpl. + repeat (rewrite <- (ireg_val ms sp rs); auto). + reflexivity. + split. + case c; simpl; auto; rewrite <- Val.negate_cmpu; simpl; auto. + apply agree_exten_2 with rs; auto. + (* Ccompimm *) + simpl. + case (Int.eq (high_s i) Int.zero). + generalize (compare_sint_spec rs ms#m0 (Vint i)). + intros [A [B [C D]]]. + exists (nextinstr (compare_sint rs ms#m0 (Vint i))). + split. apply exec_straight_one. simpl. + repeat (rewrite <- (ireg_val ms sp rs); auto). + reflexivity. + split. + case c; simpl; auto; rewrite <- Val.negate_cmp; simpl; auto. + apply agree_exten_2 with rs; auto. + generalize (loadimm_correct GPR12 i (Pcmpw (ireg_of m0) GPR12 :: k) rs m). + intros [rs1 [EX1 [RES1 OTH1]]]. + assert (agree ms sp rs1). apply agree_exten_2 with rs; auto. + generalize (compare_sint_spec rs1 ms#m0 (Vint i)). + intros [A [B [C D]]]. + exists (nextinstr (compare_sint rs1 ms#m0 (Vint i))). + split. eapply exec_straight_trans. eexact EX1. + apply exec_straight_one. simpl. + repeat (rewrite <- (ireg_val ms sp rs1); auto). rewrite RES1. + reflexivity. reflexivity. + split. + case c; simpl; auto; rewrite <- Val.negate_cmp; simpl; auto. + apply agree_exten_2 with rs1; auto. + (* Ccompuimm *) + simpl. + case (Int.eq (high_u i) Int.zero). + generalize (compare_uint_spec rs ms#m0 (Vint i)). + intros [A [B [C D]]]. + exists (nextinstr (compare_uint rs ms#m0 (Vint i))). + split. apply exec_straight_one. simpl. + repeat (rewrite <- (ireg_val ms sp rs); auto). + reflexivity. + split. + case c; simpl; auto; rewrite <- Val.negate_cmpu; simpl; auto. + apply agree_exten_2 with rs; auto. + generalize (loadimm_correct GPR12 i (Pcmplw (ireg_of m0) GPR12 :: k) rs m). + intros [rs1 [EX1 [RES1 OTH1]]]. + assert (agree ms sp rs1). apply agree_exten_2 with rs; auto. + generalize (compare_uint_spec rs1 ms#m0 (Vint i)). + intros [A [B [C D]]]. + exists (nextinstr (compare_uint rs1 ms#m0 (Vint i))). + split. eapply exec_straight_trans. eexact EX1. + apply exec_straight_one. simpl. + repeat (rewrite <- (ireg_val ms sp rs1); auto). rewrite RES1. + reflexivity. reflexivity. + split. + case c; simpl; auto; rewrite <- Val.negate_cmpu; simpl; auto. + apply agree_exten_2 with rs1; auto. + (* Ccompf *) + simpl. + generalize (floatcomp_correct c (freg_of m0) (freg_of m1) k rs m). + intros [rs' [EX [RES OTH]]]. + exists rs'. split. auto. + split. rewrite RES. repeat (rewrite <- (freg_val ms sp rs); auto). + apply agree_exten_2 with rs; auto. + (* Cnotcompf *) + simpl. + generalize (floatcomp_correct c (freg_of m0) (freg_of m1) k rs m). + intros [rs' [EX [RES OTH]]]. + exists rs'. split. auto. + split. rewrite RES. repeat (rewrite <- (freg_val ms sp rs); auto). + assert (forall v1 v2, Val.notbool (Val.notbool (Val.cmpf c v1 v2)) = Val.cmpf c v1 v2). + intros v1 v2; unfold Val.cmpf; destruct v1; destruct v2; auto. + apply Val.notbool_idem2. + rewrite H. + generalize RES. case (snd (crbit_for_fcmp c)); simpl; auto. + apply agree_exten_2 with rs; auto. + (* Cmaskzero *) + simpl. + generalize (andimm_correct GPR12 (ireg_of m0) i k rs m (ireg_of_not_GPR12 m0)). + intros [rs' [A [B [C D]]]]. + exists rs'. split. assumption. + split. rewrite C. rewrite <- (ireg_val ms sp rs); auto. + apply agree_exten_2 with rs; auto. + (* Cmasknotzero *) + simpl. + generalize (andimm_correct GPR12 (ireg_of m0) i k rs m (ireg_of_not_GPR12 m0)). + intros [rs' [A [B [C D]]]]. + exists rs'. split. assumption. + split. rewrite C. rewrite <- (ireg_val ms sp rs); auto. + rewrite Val.notbool_idem3. reflexivity. + apply agree_exten_2 with rs; auto. +Qed. + +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) 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))) = + (if snd (crbit_for_cond cond) + then Val.of_bool b + else Val.notbool (Val.of_bool b)) + /\ agree ms sp rs'. +Proof. + intros. rewrite <- (eval_condition_weaken _ _ _ H1). + apply transl_cond_correct_aux; auto. +Qed. + +(** Translation of arithmetic operations. *) + +Ltac TranslOpSimpl := + match goal with + | |- exists rs' : regset, + exec_straight ?c ?rs ?m ?k rs' ?m /\ + agree (Regmap.set ?res ?v ?ms) ?sp rs' => + (exists (nextinstr (rs#(ireg_of res) <- v)); + split; + [ apply exec_straight_one; + [ repeat (rewrite (ireg_val ms sp rs); auto); reflexivity + | reflexivity ] + | auto with ppcgen ]) + || + (exists (nextinstr (rs#(freg_of res) <- v)); + split; + [ apply exec_straight_one; + [ repeat (rewrite (freg_val ms sp rs); auto); reflexivity + | reflexivity ] + | auto with ppcgen ]) + end. + +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) 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. + inversion H. + (* Omove *) + simpl. exists (nextinstr (rs#(preg_of res) <- (ms r1))). + split. caseEq (mreg_type r1); intro. + apply exec_straight_one. simpl. rewrite (ireg_val ms sp rs); auto. + simpl. unfold preg_of. rewrite <- H2. rewrite H5. reflexivity. + auto with ppcgen. + apply exec_straight_one. simpl. rewrite (freg_val ms sp rs); auto. + simpl. unfold preg_of. rewrite <- H2. rewrite H5. reflexivity. + auto with ppcgen. + auto with ppcgen. + (* Other instructions *) + clear H1; clear H2; clear H4. + destruct op; simpl in H5; injection H5; clear H5; intros; + TypeInv; simpl; try (TranslOpSimpl). + (* Omove again *) + congruence. + (* Ointconst *) + generalize (loadimm_correct (ireg_of res) i k rs m). + intros [rs' [A [B C]]]. + exists rs'. split. auto. + apply agree_set_mireg_exten with rs; auto. + (* Ofloatconst *) + exists (nextinstr (rs#(freg_of res) <- (Vfloat f) #GPR12 <- Vundef)). + split. apply exec_straight_one. reflexivity. reflexivity. + auto with ppcgen. + (* Oaddrsymbol *) + change (find_symbol_offset ge i i0) with (symbol_offset ge i i0). + set (v := symbol_offset ge i i0). + pose (rs1 := nextinstr (rs#GPR12 <- (high_half v))). + exists (nextinstr (rs1#(ireg_of res) <- v)). + split. apply exec_straight_two with rs1 m. + unfold exec_instr. rewrite gpr_or_zero_zero. + unfold const_high. rewrite Val.add_commut. + rewrite high_half_zero. reflexivity. + simpl. rewrite gpr_or_zero_not_zero. 2: congruence. + unfold rs1 at 1. rewrite nextinstr_inv; auto with ppcgen. + rewrite Pregmap.gss. + fold v. rewrite Val.add_commut. unfold v. rewrite low_high_half. + reflexivity. reflexivity. reflexivity. + unfold rs1. apply agree_nextinstr. apply agree_set_mireg; auto. + apply agree_set_mreg. apply agree_nextinstr. + apply agree_set_other. auto. simpl. tauto. + (* Oaddrstack *) + assert (GPR1 <> GPR12). discriminate. + generalize (addimm_correct (ireg_of res) GPR1 i k rs m H2). + intros [rs' [EX [RES OTH]]]. + exists rs'. split. auto. + apply agree_set_mireg_exten with rs; auto. + rewrite (sp_val ms sp rs). auto. auto. + (* 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. + replace (Val.zero_ext 8 (ms m0)) + with (Val.rolm (ms m0) Int.zero (Int.repr 255)). + auto with ppcgen. + unfold Val.rolm, Val.zero_ext. destruct (ms m0); auto. + rewrite Int.rolm_zero. rewrite Int.zero_ext_and. auto. compute; auto. + (* Ocast16unsigned *) + exists (nextinstr (rs#(ireg_of res) <- (Val.rolm (ms m0) Int.zero (Int.repr 65535)))). + split. apply exec_straight_one. repeat (rewrite (ireg_val ms sp rs)); auto. reflexivity. + replace (Val.zero_ext 16 (ms m0)) + with (Val.rolm (ms m0) Int.zero (Int.repr 65535)). + auto with ppcgen. + unfold Val.rolm, Val.zero_ext. destruct (ms m0); auto. + rewrite Int.rolm_zero. rewrite Int.zero_ext_and. auto. compute; auto. + (* Oaddimm *) + generalize (addimm_correct (ireg_of res) (ireg_of m0) i k rs m + (ireg_of_not_GPR12 m0)). + intros [rs' [A [B C]]]. + exists rs'. split. auto. + apply agree_set_mireg_exten with rs; auto. + rewrite (ireg_val ms sp rs); auto. + (* Osub *) + exists (nextinstr (rs#(ireg_of res) <- (Val.sub (ms m0) (ms m1)) #CARRY <- Vundef)). + split. apply exec_straight_one. repeat (rewrite (ireg_val ms sp rs); auto). + simpl. reflexivity. auto with ppcgen. + (* Osubimm *) + case (Int.eq (high_s i) Int.zero). + exists (nextinstr (rs#(ireg_of res) <- (Val.sub (Vint i) (ms m0)) #CARRY <- Vundef)). + split. apply exec_straight_one. rewrite (ireg_val ms sp rs); auto. + reflexivity. simpl. auto with ppcgen. + generalize (loadimm_correct GPR12 i (Psubfc (ireg_of res) (ireg_of m0) GPR12 :: k) rs m). + intros [rs1 [EX [RES OTH]]]. + assert (agree ms sp rs1). apply agree_exten_2 with rs; auto. + exists (nextinstr (rs1#(ireg_of res) <- (Val.sub (Vint i) (ms m0)) #CARRY <- Vundef)). + split. eapply exec_straight_trans. eexact EX. + apply exec_straight_one. repeat (rewrite (ireg_val ms sp rs); auto). + simpl. rewrite RES. rewrite OTH. reflexivity. + generalize (ireg_of_not_GPR12 m0); congruence. + discriminate. + reflexivity. simpl; auto with ppcgen. + (* Omulimm *) + case (Int.eq (high_s i) Int.zero). + exists (nextinstr (rs#(ireg_of res) <- (Val.mul (ms m0) (Vint i)))). + split. apply exec_straight_one. rewrite (ireg_val ms sp rs); auto. + reflexivity. auto with ppcgen. + generalize (loadimm_correct GPR12 i (Pmullw (ireg_of res) (ireg_of m0) GPR12 :: k) rs m). + intros [rs1 [EX [RES OTH]]]. + assert (agree ms sp rs1). apply agree_exten_2 with rs; auto. + exists (nextinstr (rs1#(ireg_of res) <- (Val.mul (ms m0) (Vint i)))). + split. eapply exec_straight_trans. eexact EX. + apply exec_straight_one. repeat (rewrite (ireg_val ms sp rs); auto). + simpl. rewrite RES. rewrite OTH. reflexivity. + generalize (ireg_of_not_GPR12 m0); congruence. + discriminate. + reflexivity. simpl; auto with ppcgen. + (* Oand *) + pose (v := Val.and (ms m0) (ms m1)). + pose (rs1 := rs#(ireg_of res) <- v). + generalize (compare_sint_spec rs1 v Vzero). + intros [A [B [C D]]]. + exists (nextinstr (compare_sint rs1 v Vzero)). + split. apply exec_straight_one. + unfold rs1, v. repeat (rewrite (ireg_val ms sp rs); auto). + reflexivity. + apply agree_exten_2 with rs1. unfold rs1, v; auto with ppcgen. + auto. + (* Oandimm *) + generalize (andimm_correct (ireg_of res) (ireg_of m0) i k rs m + (ireg_of_not_GPR12 m0)). + intros [rs' [A [B [C D]]]]. + exists rs'. split. auto. apply agree_set_mireg_exten with rs; auto. + rewrite (ireg_val ms sp rs); auto. + (* Oorimm *) + generalize (orimm_correct (ireg_of res) (ireg_of m0) i k rs m). + intros [rs' [A [B C]]]. + exists rs'. split. auto. apply agree_set_mireg_exten with rs; auto. + rewrite (ireg_val ms sp rs); auto. + (* Oxorimm *) + generalize (xorimm_correct (ireg_of res) (ireg_of m0) i k rs m). + intros [rs' [A [B C]]]. + exists rs'. split. auto. apply agree_set_mireg_exten with rs; auto. + rewrite (ireg_val ms sp rs); auto. + (* Oshr *) + exists (nextinstr (rs#(ireg_of res) <- (Val.shr (ms m0) (ms m1)) #CARRY <- (Val.shr_carry (ms m0) (ms m1)))). + split. apply exec_straight_one. repeat (rewrite (ireg_val ms sp rs); auto). + reflexivity. auto with ppcgen. + (* Oshrimm *) + exists (nextinstr (rs#(ireg_of res) <- (Val.shr (ms m0) (Vint i)) #CARRY <- (Val.shr_carry (ms m0) (Vint i)))). + split. apply exec_straight_one. repeat (rewrite (ireg_val ms sp rs); auto). + reflexivity. auto with ppcgen. + (* Oxhrximm *) + pose (rs1 := nextinstr (rs#(ireg_of res) <- (Val.shr (ms m0) (Vint i)) #CARRY <- (Val.shr_carry (ms m0) (Vint i)))). + exists (nextinstr (rs1#(ireg_of res) <- (Val.shrx (ms m0) (Vint i)))). + split. apply exec_straight_two with rs1 m. + unfold rs1; rewrite (ireg_val ms sp rs); auto. + simpl; unfold rs1; repeat rewrite <- (ireg_val ms sp rs); auto. + repeat (rewrite nextinstr_inv; try discriminate). + repeat rewrite Pregmap.gss. decEq. decEq. + apply (f_equal3 (@Pregmap.set val)); auto. + rewrite Pregmap.gso. rewrite Pregmap.gss. apply Val.shrx_carry. + discriminate. reflexivity. reflexivity. + apply agree_exten_2 with (rs#(ireg_of res) <- (Val.shrx (ms m0) (Vint i))). + auto with ppcgen. + intros. rewrite nextinstr_inv; auto. + case (preg_eq (ireg_of res) r); intro. + subst r. repeat rewrite Pregmap.gss. auto. + repeat rewrite Pregmap.gso; auto. + unfold rs1. rewrite nextinstr_inv; auto. + repeat rewrite Pregmap.gso; auto. + (* Ointoffloat *) + exists (nextinstr (rs#(ireg_of res) <- (Val.intoffloat (ms m0)) #FPR13 <- Vundef)). + split. apply exec_straight_one. + repeat (rewrite (freg_val ms sp rs); auto). + reflexivity. auto with ppcgen. + (* Ointuoffloat *) + exists (nextinstr (rs#(ireg_of res) <- (Val.intuoffloat (ms m0)) #FPR13 <- Vundef)). + split. apply exec_straight_one. + repeat (rewrite (freg_val ms sp rs); auto). + reflexivity. auto with ppcgen. + (* Ofloatofint *) + exists (nextinstr (rs#(freg_of res) <- (Val.floatofint (ms m0)) #GPR12 <- Vundef #FPR13 <- Vundef)). + split. apply exec_straight_one. + repeat (rewrite (ireg_val ms sp rs); auto). + reflexivity. auto 10 with ppcgen. + (* Ofloatofintu *) + exists (nextinstr (rs#(freg_of res) <- (Val.floatofintu (ms m0)) #GPR12 <- Vundef #FPR13 <- Vundef)). + split. apply exec_straight_one. + repeat (rewrite (ireg_val ms sp rs); auto). + reflexivity. auto 10 with ppcgen. + (* Ocmp *) + set (bit := fst (crbit_for_cond c)). + set (isset := snd (crbit_for_cond c)). + set (k1 := + Pmfcrbit (ireg_of res) bit :: + (if isset + then k + else Pxori (ireg_of res) (ireg_of res) (Cint Int.one) :: k)). + generalize (transl_cond_correct_aux c args k1 ms sp rs m H2 H0). + fold bit; fold isset. + intros [rs1 [EX1 [RES1 AG1]]]. + set (rs2 := nextinstr (rs1#(ireg_of res) <- (rs1#(reg_of_crbit bit)))). + destruct isset. + exists rs2. + split. apply exec_straight_trans with k1 rs1 m. assumption. + unfold k1. apply exec_straight_one. + reflexivity. reflexivity. + unfold rs2. rewrite RES1. auto with ppcgen. + exists (nextinstr (rs2#(ireg_of res) <- (eval_condition_total c ms##args))). + split. apply exec_straight_trans with k1 rs1 m. assumption. + unfold k1. apply exec_straight_two with rs2 m. + reflexivity. simpl. + replace (Val.xor (rs2 (ireg_of res)) (Vint Int.one)) + with (eval_condition_total c ms##args). + reflexivity. + unfold rs2. rewrite nextinstr_inv; auto with ppcgen. rewrite Pregmap.gss. + rewrite RES1. apply Val.notbool_xor. apply eval_condition_total_is_bool. + reflexivity. reflexivity. + unfold rs2. auto with ppcgen. +Qed. + +Lemma transl_load_store_correct: + forall (mk1: constant -> ireg -> instruction) (mk2: ireg -> ireg -> instruction) + addr args k ms sp rs m ms' m', + (forall cst (r1: ireg) (rs1: regset) k, + eval_addressing_total ge sp addr (map ms args) = Val.add rs1#r1 (const_low ge cst) -> + agree ms sp rs1 -> + r1 <> GPR0 -> + exists rs', + exec_straight (mk1 cst r1 :: k) rs1 m k rs' m' /\ + agree ms' sp rs') -> + (forall (r1 r2: ireg) (rs1: regset) k, + eval_addressing_total ge sp addr (map ms args) = Val.add rs1#r1 rs1#r2 -> + agree ms sp rs1 -> + exists rs', + exec_straight (mk2 r1 r2 :: k) rs1 m k rs' m' /\ + agree ms' sp rs') -> + agree ms sp rs -> + map mreg_type args = type_of_addressing addr -> + exists rs', + exec_straight (transl_load_store mk1 mk2 addr args k) rs m + k rs' m' + /\ agree ms' sp rs'. +Proof. + intros. destruct addr; simpl in H2; TypeInv; simpl. + (* Aindexed *) + case (ireg_eq (ireg_of t) GPR0); intro. + (* Aindexed from GPR0 *) + set (rs1 := nextinstr (rs#GPR12 <- (ms t))). + set (rs2 := nextinstr (rs1#GPR12 <- (Val.add (ms t) (Vint (Int.shl (high_s i) (Int.repr 16)))))). + assert (ADDR: eval_addressing_total ge sp (Aindexed i) ms##(t :: nil) = + Val.add rs2#GPR12 (const_low ge (Cint (low_s i)))). + simpl. unfold rs2. rewrite nextinstr_inv. rewrite Pregmap.gss. + rewrite Val.add_assoc. simpl. rewrite low_high_s. auto. + discriminate. + assert (AG: agree ms sp rs2). unfold rs2, rs1; auto 6 with ppcgen. + assert (NOT0: GPR12 <> GPR0). discriminate. + generalize (H _ _ _ k ADDR AG NOT0). + intros [rs' [EX' AG']]. + exists rs'. split. + apply exec_straight_trans with (mk1 (Cint (low_s i)) GPR12 :: k) rs2 m. + apply exec_straight_two with rs1 m. + unfold rs1. rewrite (ireg_val ms sp rs); auto. + unfold rs2. replace (ms t) with (rs1#GPR12). auto. + unfold rs1. rewrite nextinstr_inv. apply Pregmap.gss. discriminate. + reflexivity. reflexivity. + assumption. assumption. + (* Aindexed short *) + case (Int.eq (high_s i) Int.zero). + assert (ADDR: eval_addressing_total ge sp (Aindexed i) ms##(t :: nil) = + Val.add rs#(ireg_of t) (const_low ge (Cint i))). + simpl. rewrite (ireg_val ms sp rs); auto. + generalize (H _ _ _ k ADDR H1 n). intros [rs' [EX' AG']]. + exists rs'. split. auto. auto. + (* Aindexed long *) + set (rs1 := nextinstr (rs#GPR12 <- (Val.add (ms t) (Vint (Int.shl (high_s i) (Int.repr 16)))))). + assert (ADDR: eval_addressing_total ge sp (Aindexed i) ms##(t :: nil) = + Val.add rs1#GPR12 (const_low ge (Cint (low_s i)))). + simpl. unfold rs1. rewrite nextinstr_inv. rewrite Pregmap.gss. + rewrite Val.add_assoc. simpl. rewrite low_high_s. auto. + discriminate. + assert (AG: agree ms sp rs1). unfold rs1; auto with ppcgen. + assert (NOT0: GPR12 <> GPR0). discriminate. + generalize (H _ _ _ k ADDR AG NOT0). intros [rs' [EX' AG']]. + exists rs'. split. apply exec_straight_step with rs1 m. + simpl. rewrite gpr_or_zero_not_zero; auto. + rewrite <- (ireg_val ms sp rs); auto. reflexivity. + assumption. assumption. + (* Aindexed2 *) + apply H0. + simpl. repeat (rewrite (ireg_val ms sp rs); auto). auto. + (* Aglobal *) + set (rs1 := nextinstr (rs#GPR12 <- (const_high ge (Csymbol_high i i0)))). + assert (ADDR: eval_addressing_total ge sp (Aglobal i i0) ms##nil = + Val.add rs1#GPR12 (const_low ge (Csymbol_low i i0))). + simpl. unfold rs1. rewrite nextinstr_inv. rewrite Pregmap.gss. + unfold const_high, const_low. + set (v := symbol_offset ge i i0). + symmetry. rewrite Val.add_commut. unfold v. apply low_high_half. + discriminate. + assert (AG: agree ms sp rs1). unfold rs1; auto with ppcgen. + assert (NOT0: GPR12 <> GPR0). discriminate. + generalize (H _ _ _ k ADDR AG NOT0). intros [rs' [EX' AG']]. + exists rs'. split. apply exec_straight_step with rs1 m. + unfold exec_instr. rewrite gpr_or_zero_zero. + rewrite Val.add_commut. unfold const_high. + rewrite high_half_zero. + reflexivity. reflexivity. + assumption. assumption. + (* Abased *) + assert (COMMON: + forall (rs1: regset) r, + r <> GPR0 -> + ms t = rs1#r -> + agree ms sp rs1 -> + exists rs', + exec_straight + (Paddis GPR12 r (Csymbol_high i i0) + :: mk1 (Csymbol_low i i0) GPR12 :: k) rs1 m k rs' m' + /\ agree ms' sp rs'). + intros. + set (rs2 := nextinstr (rs1#GPR12 <- (Val.add (ms t) (const_high ge (Csymbol_high i i0))))). + assert (ADDR: eval_addressing_total ge sp (Abased i i0) ms##(t::nil) = + Val.add rs2#GPR12 (const_low ge (Csymbol_low i i0))). + simpl. unfold rs2. rewrite nextinstr_inv. rewrite Pregmap.gss. + unfold const_high. + set (v := symbol_offset ge i i0). + rewrite Val.add_assoc. + rewrite (Val.add_commut (high_half v)). + unfold v. rewrite low_high_half. apply Val.add_commut. + discriminate. + assert (AG: agree ms sp rs2). unfold rs2; auto with ppcgen. + assert (NOT0: GPR12 <> GPR0). discriminate. + generalize (H _ _ _ k ADDR AG NOT0). intros [rs' [EX' AG']]. + exists rs'. split. apply exec_straight_step with rs2 m. + unfold exec_instr. rewrite gpr_or_zero_not_zero; auto. + rewrite <- H3. reflexivity. reflexivity. + assumption. assumption. + case (ireg_eq (ireg_of t) GPR0); intro. + set (rs1 := nextinstr (rs#GPR12 <- (ms t))). + assert (R1: GPR12 <> GPR0). discriminate. + assert (R2: ms t = rs1 GPR12). + unfold rs1. rewrite nextinstr_inv. rewrite Pregmap.gss; auto. + discriminate. + assert (R3: agree ms sp rs1). unfold rs1; auto with ppcgen. + generalize (COMMON rs1 GPR12 R1 R2 R3). intros [rs' [EX' AG']]. + exists rs'. split. + apply exec_straight_step with rs1 m. + unfold rs1. rewrite (ireg_val ms sp rs); auto. reflexivity. + assumption. assumption. + apply COMMON; auto. eapply ireg_val; eauto. + (* Ainstack *) + case (Int.eq (high_s i) Int.zero). + apply H. simpl. rewrite (sp_val ms sp rs); auto. auto. + discriminate. + set (rs1 := nextinstr (rs#GPR12 <- (Val.add sp (Vint (Int.shl (high_s i) (Int.repr 16)))))). + assert (ADDR: eval_addressing_total ge sp (Ainstack i) ms##nil = + Val.add rs1#GPR12 (const_low ge (Cint (low_s i)))). + simpl. unfold rs1. rewrite nextinstr_inv. rewrite Pregmap.gss. + rewrite Val.add_assoc. decEq. simpl. rewrite low_high_s. auto. + discriminate. + assert (AG: agree ms sp rs1). unfold rs1; auto with ppcgen. + assert (NOT0: GPR12 <> GPR0). discriminate. + generalize (H _ _ _ k ADDR AG NOT0). intros [rs' [EX' AG']]. + exists rs'. split. apply exec_straight_step with rs1 m. + simpl. rewrite gpr_or_zero_not_zero. + unfold rs1. rewrite (sp_val ms sp rs). reflexivity. + auto. discriminate. reflexivity. assumption. assumption. +Qed. + +(** Translation of memory loads. *) + +Lemma transl_load_correct: + forall (mk1: constant -> ireg -> instruction) (mk2: ireg -> ireg -> instruction) + chunk addr args k ms sp rs m dst a v, + (forall cst (r1: ireg) (rs1: regset), + exec_instr ge fn (mk1 cst r1) rs1 m = + load1 ge chunk (preg_of dst) cst r1 rs1 m) -> + (forall (r1 r2: ireg) (rs1: regset), + exec_instr ge fn (mk2 r1 r2) rs1 m = + load2 chunk (preg_of dst) r1 r2 rs1 m) -> + agree ms sp rs -> + map mreg_type args = type_of_addressing addr -> + eval_addressing ge sp addr (map ms args) = Some a -> + Mem.loadv chunk m a = Some v -> + exists rs', + exec_straight (transl_load_store mk1 mk2 addr args k) rs m + k rs' m + /\ agree (Regmap.set dst v ms) sp rs'. +Proof. + intros. apply transl_load_store_correct with ms. + intros. exists (nextinstr (rs1#(preg_of dst) <- v)). + split. apply exec_straight_one. rewrite H. + unfold load1. rewrite gpr_or_zero_not_zero; auto. + rewrite <- (eval_addressing_weaken _ _ _ _ H3) in H4. + rewrite H5 in H4. rewrite H4. auto. + auto with ppcgen. auto with ppcgen. + intros. exists (nextinstr (rs1#(preg_of dst) <- v)). + split. apply exec_straight_one. rewrite H0. + unfold load2. + rewrite <- (eval_addressing_weaken _ _ _ _ H3) in H4. + rewrite H5 in H4. rewrite H4. auto. + auto with ppcgen. auto with ppcgen. + auto. auto. +Qed. + +(** Translation of memory stores. *) + +Lemma transl_store_correct: + forall (mk1: constant -> ireg -> instruction) (mk2: ireg -> ireg -> instruction) + chunk addr args k ms sp rs m src a m', + (forall cst (r1: ireg) (rs1: regset), + exec_instr ge fn (mk1 cst r1) rs1 m = + store1 ge chunk (preg_of src) cst r1 rs1 m) -> + (forall (r1 r2: ireg) (rs1: regset), + exec_instr ge fn (mk2 r1 r2) rs1 m = + store2 chunk (preg_of src) r1 r2 rs1 m) -> + agree ms sp rs -> + map mreg_type args = type_of_addressing addr -> + eval_addressing ge sp addr (map ms args) = Some a -> + Mem.storev chunk m a (ms src) = Some m' -> + exists rs', + exec_straight (transl_load_store mk1 mk2 addr args k) rs m + k rs' m' + /\ agree ms sp rs'. +Proof. + intros. apply transl_load_store_correct with ms. + intros. exists (nextinstr rs1). + split. apply exec_straight_one. rewrite H. + unfold store1. rewrite gpr_or_zero_not_zero; auto. + rewrite <- (eval_addressing_weaken _ _ _ _ H3) in H4. + rewrite H5 in H4. elim H6; intros. rewrite H9 in H4. + rewrite H4. auto. + auto with ppcgen. auto with ppcgen. + intros. exists (nextinstr rs1). + split. apply exec_straight_one. rewrite H0. + unfold store2. + rewrite <- (eval_addressing_weaken _ _ _ _ H3) in H4. + rewrite H5 in H4. elim H6; intros. rewrite H8 in H4. + rewrite H4. auto. + auto with ppcgen. auto with ppcgen. + auto. auto. +Qed. + +(** Translation of allocations *) + +Lemma transl_alloc_correct: + forall ms sp rs sz m m' blk k, + agree ms sp rs -> + ms Conventions.loc_alloc_argument = Vint sz -> + Mem.alloc m 0 (Int.signed sz) = (m', blk) -> + let ms' := Regmap.set Conventions.loc_alloc_result (Vptr blk Int.zero) ms in + exists rs', + exec_straight (Pallocblock :: k) rs m k rs' m' + /\ agree ms' sp rs'. +Proof. + intros. + pose (rs' := nextinstr (rs#GPR3 <- (Vptr blk Int.zero) #LR <- (Val.add rs#PC Vone))). + exists rs'; split. + apply exec_straight_one. unfold exec_instr. + generalize (preg_val _ _ _ Conventions.loc_alloc_argument H). + unfold preg_of; intro. simpl in H2. rewrite <- H2. rewrite H0. + rewrite H1. reflexivity. + reflexivity. + unfold ms', rs'. apply agree_nextinstr. apply agree_set_other. + change (IR GPR3) with (preg_of Conventions.loc_alloc_result). + apply agree_set_mreg. auto. + simpl. tauto. +Qed. + +End STRAIGHTLINE. + diff --git a/powerpc/Asmgenretaddr.v b/powerpc/Asmgenretaddr.v new file mode 100644 index 0000000..23bd186 --- /dev/null +++ b/powerpc/Asmgenretaddr.v @@ -0,0 +1,188 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** 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 Asm. +Require Import Asmgen. + +(** 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 f 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 f i k, is_tail k (transl_instr f 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 f c1 c2, is_tail c1 c2 -> is_tail (transl_code f c1) (transl_code f 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 f 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/powerpc/Constprop.v b/powerpc/Constprop.v new file mode 100644 index 0000000..75fb148 --- /dev/null +++ b/powerpc/Constprop.v @@ -0,0 +1,1093 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Constant propagation over RTL. This is the first of the two + optimizations performed at RTL level. It proceeds by a standard + dataflow analysis and the corresponding code transformation. *) + +Require Import Coqlib. +Require Import Maps. +Require Import AST. +Require Import Integers. +Require Import Floats. +Require Import Values. +Require Import Globalenvs. +Require Import Op. +Require Import Registers. +Require Import RTL. +Require Import Lattice. +Require Import Kildall. + +(** * Static analysis *) + +(** To each pseudo-register at each program point, the static analysis + associates a compile-time approximation taken from the following set. *) + +Inductive approx : Set := + | Novalue: approx (** No value possible, code is unreachable. *) + | Unknown: approx (** All values are possible, + no compile-time information is available. *) + | I: int -> approx (** A known integer value. *) + | F: float -> approx (** A known floating-point value. *) + | S: ident -> int -> approx. + (** The value is the address of the given global + symbol plus the given integer offset. *) + +(** We equip this set of approximations with a semi-lattice structure. + The ordering is inclusion between the sets of values denoted by + the approximations. *) + +Module Approx <: SEMILATTICE_WITH_TOP. + Definition t := approx. + Definition eq (x y: t) := (x = y). + Definition eq_refl: forall x, eq x x := (@refl_equal t). + Definition eq_sym: forall x y, eq x y -> eq y x := (@sym_equal t). + Definition eq_trans: forall x y z, eq x y -> eq y z -> eq x z := (@trans_equal t). + Lemma eq_dec: forall (x y: t), {x=y} + {x<>y}. + Proof. + decide equality. + apply Int.eq_dec. + apply Float.eq_dec. + apply Int.eq_dec. + apply ident_eq. + Qed. + Definition beq (x y: t) := if eq_dec x y then true else false. + Lemma beq_correct: forall x y, beq x y = true -> x = y. + Proof. + unfold beq; intros. destruct (eq_dec x y). auto. congruence. + Qed. + Definition ge (x y: t) : Prop := + x = Unknown \/ y = Novalue \/ x = y. + Lemma ge_refl: forall x y, eq x y -> ge x y. + Proof. + unfold eq, ge; tauto. + Qed. + Lemma ge_trans: forall x y z, ge x y -> ge y z -> ge x z. + Proof. + unfold ge; intuition congruence. + Qed. + Lemma ge_compat: forall x x' y y', eq x x' -> eq y y' -> ge x y -> ge x' y'. + Proof. + unfold eq, ge; intros; congruence. + Qed. + Definition bot := Novalue. + Definition top := Unknown. + Lemma ge_bot: forall x, ge x bot. + Proof. + unfold ge, bot; tauto. + Qed. + Lemma ge_top: forall x, ge top x. + Proof. + unfold ge, bot; tauto. + Qed. + Definition lub (x y: t) : t := + if eq_dec x y then x else + match x, y with + | Novalue, _ => y + | _, Novalue => x + | _, _ => Unknown + end. + Lemma lub_commut: forall x y, eq (lub x y) (lub y x). + Proof. + unfold lub, eq; intros. + case (eq_dec x y); case (eq_dec y x); intros; try congruence. + destruct x; destruct y; auto. + Qed. + Lemma ge_lub_left: forall x y, ge (lub x y) x. + Proof. + unfold lub; intros. + case (eq_dec x y); intro. + apply ge_refl. apply eq_refl. + destruct x; destruct y; unfold ge; tauto. + Qed. +End Approx. + +Module D := LPMap Approx. + +(** We now define the abstract interpretations of conditions and operators + over this set of approximations. For instance, the abstract interpretation + of the operator [Oaddf] applied to two expressions [a] and [b] is + [F(Float.add f g)] if [a] and [b] have static approximations [Vfloat f] + and [Vfloat g] respectively, and [Unknown] otherwise. + + The static approximations are defined by large pattern-matchings over + the approximations of the results. We write these matchings in the + indirect style described in file [Cmconstr] to avoid excessive + duplication of cases in proofs. *) + +(* +Definition eval_static_condition (cond: condition) (vl: list approx) := + match cond, vl with + | Ccomp c, I n1 :: I n2 :: nil => Some(Int.cmp c n1 n2) + | Ccompu c, I n1 :: I n2 :: nil => Some(Int.cmpu c n1 n2) + | Ccompimm c n, I n1 :: nil => Some(Int.cmp c n1 n) + | Ccompuimm c n, I n1 :: nil => Some(Int.cmpu c n1 n) + | Ccompf c, F n1 :: F n2 :: nil => Some(Float.cmp c n1 n2) + | Cnotcompf c, F n1 :: F n2 :: nil => Some(negb(Float.cmp c n1 n2)) + | Cmaskzero n, I n1 :: nil => Some(Int.eq (Int.and n1 n) Int.zero) + | Cmasknotzero n, n1::nil => Some(negb(Int.eq (Int.and n1 n) Int.zero)) + | _, _ => None + end. +*) + +Inductive eval_static_condition_cases: forall (cond: condition) (vl: list approx), Set := + | eval_static_condition_case1: + forall c n1 n2, + eval_static_condition_cases (Ccomp c) (I n1 :: I n2 :: nil) + | eval_static_condition_case2: + forall c n1 n2, + eval_static_condition_cases (Ccompu c) (I n1 :: I n2 :: nil) + | eval_static_condition_case3: + forall c n n1, + eval_static_condition_cases (Ccompimm c n) (I n1 :: nil) + | eval_static_condition_case4: + forall c n n1, + eval_static_condition_cases (Ccompuimm c n) (I n1 :: nil) + | eval_static_condition_case5: + forall c n1 n2, + eval_static_condition_cases (Ccompf c) (F n1 :: F n2 :: nil) + | eval_static_condition_case6: + forall c n1 n2, + eval_static_condition_cases (Cnotcompf c) (F n1 :: F n2 :: nil) + | eval_static_condition_case7: + forall n n1, + eval_static_condition_cases (Cmaskzero n) (I n1 :: nil) + | eval_static_condition_case8: + forall n n1, + eval_static_condition_cases (Cmasknotzero n) (I n1 :: nil) + | eval_static_condition_default: + forall (cond: condition) (vl: list approx), + eval_static_condition_cases cond vl. + +Definition eval_static_condition_match (cond: condition) (vl: list approx) := + match cond as z1, vl as z2 return eval_static_condition_cases z1 z2 with + | Ccomp c, I n1 :: I n2 :: nil => + eval_static_condition_case1 c n1 n2 + | Ccompu c, I n1 :: I n2 :: nil => + eval_static_condition_case2 c n1 n2 + | Ccompimm c n, I n1 :: nil => + eval_static_condition_case3 c n n1 + | Ccompuimm c n, I n1 :: nil => + eval_static_condition_case4 c n n1 + | Ccompf c, F n1 :: F n2 :: nil => + eval_static_condition_case5 c n1 n2 + | Cnotcompf c, F n1 :: F n2 :: nil => + eval_static_condition_case6 c n1 n2 + | Cmaskzero n, I n1 :: nil => + eval_static_condition_case7 n n1 + | Cmasknotzero n, I n1 :: nil => + eval_static_condition_case8 n n1 + | cond, vl => + eval_static_condition_default cond vl + end. + +Definition eval_static_condition (cond: condition) (vl: list approx) := + match eval_static_condition_match cond vl with + | eval_static_condition_case1 c n1 n2 => + Some(Int.cmp c n1 n2) + | eval_static_condition_case2 c n1 n2 => + Some(Int.cmpu c n1 n2) + | eval_static_condition_case3 c n n1 => + Some(Int.cmp c n1 n) + | eval_static_condition_case4 c n n1 => + Some(Int.cmpu c n1 n) + | eval_static_condition_case5 c n1 n2 => + Some(Float.cmp c n1 n2) + | eval_static_condition_case6 c n1 n2 => + Some(negb(Float.cmp c n1 n2)) + | eval_static_condition_case7 n n1 => + Some(Int.eq (Int.and n1 n) Int.zero) + | eval_static_condition_case8 n n1 => + Some(negb(Int.eq (Int.and n1 n) Int.zero)) + | eval_static_condition_default cond vl => + None + end. + +(* +Definition eval_static_operation (op: operation) (vl: list approx) := + match op, vl with + | Omove, v1::nil => v1 + | Ointconst n, nil => I n + | Ofloatconst n, nil => F n + | Oaddrsymbol s n, nil => S s n + | Ocast8signed, I n1 :: nil => I(Int.sign_ext 8 n) + | Ocast8unsigned, I n1 :: nil => I(Int.zero_ext 8 n) + | Ocast16signed, I n1 :: nil => I(Int.sign_ext 16 n) + | Ocast16unsigned, I n1 :: nil => I(Int.zero_ext 16 n) + | Oadd, I n1 :: I n2 :: nil => I(Int.add n1 n2) + | Oadd, S s1 n1 :: I n2 :: nil => S s1 (Int.add n1 n2) + | Oaddimm n, I n1 :: nil => I (Int.add n1 n) + | Oaddimm n, S s1 n1 :: nil => S s1 (Int.add n1 n) + | Osub, I n1 :: I n2 :: nil => I(Int.sub n1 n2) + | Osub, S s1 n1 :: I n2 :: nil => S s1 (Int.sub n1 n2) + | Osubimm n, I n1 :: nil => I (Int.sub n n1) + | Omul, I n1 :: I n2 :: nil => I(Int.mul n1 n2) + | Omulimm n, I n1 :: nil => I(Int.mul n1 n) + | Odiv, I n1 :: I n2 :: nil => if Int.eq n2 Int.zero then Unknown else I(Int.divs n1 n2) + | Odivu, I n1 :: I n2 :: nil => if Int.eq n2 Int.zero then Unknown else I(Int.divu n1 n2) + | Oand, I n1 :: I n2 :: nil => I(Int.and n1 n2) + | Oandimm n, I n1 :: nil => I(Int.and n1 n) + | Oor, I n1 :: I n2 :: nil => I(Int.or n1 n2) + | Oorimm n, I n1 :: nil => I(Int.or n1 n) + | Oxor, I n1 :: I n2 :: nil => I(Int.xor n1 n2) + | Oxorimm n, I n1 :: nil => I(Int.xor n1 n) + | Onand, I n1 :: I n2 :: nil => I(Int.xor (Int.and n1 n2) Int.mone) + | Onor, I n1 :: I n2 :: nil => I(Int.xor (Int.or n1 n2) Int.mone) + | Onxor, I n1 :: I n2 :: nil => I(Int.xor (Int.xor n1 n2) Int.mone) + | Oshl, I n1 :: I n2 :: nil => if Int.ltu n2 (Int.repr 32) then I(Int.shl n1 n2) else Unknown + | Oshr, I n1 :: I n2 :: nil => if Int.ltu n2 (Int.repr 32) then I(Int.shr n1 n2) else Unknown + | Oshrimm n, I n1 :: nil => if Int.ltu n (Int.repr 32) then I(Int.shr n1 n) else Unknown + | Oshrximm n, I n1 :: nil => if Int.ltu n (Int.repr 32) then I(Int.shrx n1 n) else Unknown + | Oshru, I n1 :: I n2 :: nil => if Int.ltu n2 (Int.repr 32) then I(Int.shru n1 n2) else Unknown + | Orolm amount mask, I n1 :: nil => I(Int.rolm n1 amount mask) + | Onegf, F n1 :: nil => F(Float.neg n1) + | Oabsf, F n1 :: nil => F(Float.abs n1) + | Oaddf, F n1 :: F n2 :: nil => F(Float.add n1 n2) + | Osubf, F n1 :: F n2 :: nil => F(Float.sub n1 n2) + | Omulf, F n1 :: F n2 :: nil => F(Float.mul n1 n2) + | Odivf, F n1 :: F n2 :: nil => F(Float.div n1 n2) + | Omuladdf, F n1 :: F n2 :: F n3 :: nil => F(Float.add (Float.mul n1 n2) n3) + | Omulsubf, F n1 :: F n2 :: F n3 :: nil => F(Float.sub (Float.mul n1 n2) n3) + | Osingleoffloat, F n1 :: nil => F(Float.singleoffloat n1) + | Ointoffloat, F n1 :: nil => I(Float.intoffloat n1) + | Ointuoffloat, F n1 :: nil => I(Float.intuoffloat n1) + | Ofloatofint, I n1 :: nil => F(Float.floatofint n1) + | Ofloatofintu, I n1 :: nil => F(Float.floatofintu n1) + | Ocmp c, vl => + match eval_static_condition c vl with + | None => Unknown + | Some b => I(if b then Int.one else Int.zero) + end + | _, _ => Unknown + end. +*) + +Inductive eval_static_operation_cases: forall (op: operation) (vl: list approx), Set := + | eval_static_operation_case1: + forall v1, + eval_static_operation_cases (Omove) (v1::nil) + | eval_static_operation_case2: + forall n, + eval_static_operation_cases (Ointconst n) (nil) + | eval_static_operation_case3: + forall n, + eval_static_operation_cases (Ofloatconst n) (nil) + | eval_static_operation_case4: + forall s n, + eval_static_operation_cases (Oaddrsymbol s n) (nil) + | eval_static_operation_case6: + forall n1, + eval_static_operation_cases (Ocast8signed) (I n1 :: nil) + | eval_static_operation_case7: + forall n1, + eval_static_operation_cases (Ocast16signed) (I n1 :: nil) + | eval_static_operation_case8: + forall n1 n2, + eval_static_operation_cases (Oadd) (I n1 :: I n2 :: nil) + | eval_static_operation_case9: + forall s1 n1 n2, + eval_static_operation_cases (Oadd) (S s1 n1 :: I n2 :: nil) + | eval_static_operation_case11: + forall n n1, + eval_static_operation_cases (Oaddimm n) (I n1 :: nil) + | eval_static_operation_case12: + forall n s1 n1, + eval_static_operation_cases (Oaddimm n) (S s1 n1 :: nil) + | eval_static_operation_case13: + forall n1 n2, + eval_static_operation_cases (Osub) (I n1 :: I n2 :: nil) + | eval_static_operation_case14: + forall s1 n1 n2, + eval_static_operation_cases (Osub) (S s1 n1 :: I n2 :: nil) + | eval_static_operation_case15: + forall n n1, + eval_static_operation_cases (Osubimm n) (I n1 :: nil) + | eval_static_operation_case16: + forall n1 n2, + eval_static_operation_cases (Omul) (I n1 :: I n2 :: nil) + | eval_static_operation_case17: + forall n n1, + eval_static_operation_cases (Omulimm n) (I n1 :: nil) + | eval_static_operation_case18: + forall n1 n2, + eval_static_operation_cases (Odiv) (I n1 :: I n2 :: nil) + | eval_static_operation_case19: + forall n1 n2, + eval_static_operation_cases (Odivu) (I n1 :: I n2 :: nil) + | eval_static_operation_case20: + forall n1 n2, + eval_static_operation_cases (Oand) (I n1 :: I n2 :: nil) + | eval_static_operation_case21: + forall n n1, + eval_static_operation_cases (Oandimm n) (I n1 :: nil) + | eval_static_operation_case22: + forall n1 n2, + eval_static_operation_cases (Oor) (I n1 :: I n2 :: nil) + | eval_static_operation_case23: + forall n n1, + eval_static_operation_cases (Oorimm n) (I n1 :: nil) + | eval_static_operation_case24: + forall n1 n2, + eval_static_operation_cases (Oxor) (I n1 :: I n2 :: nil) + | eval_static_operation_case25: + forall n n1, + eval_static_operation_cases (Oxorimm n) (I n1 :: nil) + | eval_static_operation_case26: + forall n1 n2, + eval_static_operation_cases (Onand) (I n1 :: I n2 :: nil) + | eval_static_operation_case27: + forall n1 n2, + eval_static_operation_cases (Onor) (I n1 :: I n2 :: nil) + | eval_static_operation_case28: + forall n1 n2, + eval_static_operation_cases (Onxor) (I n1 :: I n2 :: nil) + | eval_static_operation_case29: + forall n1 n2, + eval_static_operation_cases (Oshl) (I n1 :: I n2 :: nil) + | eval_static_operation_case30: + forall n1 n2, + eval_static_operation_cases (Oshr) (I n1 :: I n2 :: nil) + | eval_static_operation_case31: + forall n n1, + eval_static_operation_cases (Oshrimm n) (I n1 :: nil) + | eval_static_operation_case32: + forall n n1, + eval_static_operation_cases (Oshrximm n) (I n1 :: nil) + | eval_static_operation_case33: + forall n1 n2, + eval_static_operation_cases (Oshru) (I n1 :: I n2 :: nil) + | eval_static_operation_case34: + forall amount mask n1, + eval_static_operation_cases (Orolm amount mask) (I n1 :: nil) + | eval_static_operation_case35: + forall n1, + eval_static_operation_cases (Onegf) (F n1 :: nil) + | eval_static_operation_case36: + forall n1, + eval_static_operation_cases (Oabsf) (F n1 :: nil) + | eval_static_operation_case37: + forall n1 n2, + eval_static_operation_cases (Oaddf) (F n1 :: F n2 :: nil) + | eval_static_operation_case38: + forall n1 n2, + eval_static_operation_cases (Osubf) (F n1 :: F n2 :: nil) + | eval_static_operation_case39: + forall n1 n2, + eval_static_operation_cases (Omulf) (F n1 :: F n2 :: nil) + | eval_static_operation_case40: + forall n1 n2, + eval_static_operation_cases (Odivf) (F n1 :: F n2 :: nil) + | eval_static_operation_case41: + forall n1 n2 n3, + eval_static_operation_cases (Omuladdf) (F n1 :: F n2 :: F n3 :: nil) + | eval_static_operation_case42: + forall n1 n2 n3, + eval_static_operation_cases (Omulsubf) (F n1 :: F n2 :: F n3 :: nil) + | eval_static_operation_case43: + forall n1, + eval_static_operation_cases (Osingleoffloat) (F n1 :: nil) + | eval_static_operation_case44: + forall n1, + eval_static_operation_cases (Ointoffloat) (F n1 :: nil) + | eval_static_operation_case45: + forall n1, + eval_static_operation_cases (Ofloatofint) (I n1 :: nil) + | eval_static_operation_case46: + forall n1, + eval_static_operation_cases (Ofloatofintu) (I n1 :: nil) + | eval_static_operation_case47: + forall c vl, + eval_static_operation_cases (Ocmp c) (vl) + | eval_static_operation_case48: + forall n1, + eval_static_operation_cases (Ocast8unsigned) (I n1 :: nil) + | eval_static_operation_case49: + forall n1, + eval_static_operation_cases (Ocast16unsigned) (I n1 :: nil) + | eval_static_operation_case50: + forall n1, + eval_static_operation_cases (Ointuoffloat) (F n1 :: nil) + | eval_static_operation_default: + forall (op: operation) (vl: list approx), + eval_static_operation_cases op vl. + +Definition eval_static_operation_match (op: operation) (vl: list approx) := + match op as z1, vl as z2 return eval_static_operation_cases z1 z2 with + | Omove, v1::nil => + eval_static_operation_case1 v1 + | Ointconst n, nil => + eval_static_operation_case2 n + | Ofloatconst n, nil => + eval_static_operation_case3 n + | Oaddrsymbol s n, nil => + eval_static_operation_case4 s n + | Ocast8signed, I n1 :: nil => + eval_static_operation_case6 n1 + | Ocast16signed, I n1 :: nil => + eval_static_operation_case7 n1 + | Oadd, I n1 :: I n2 :: nil => + eval_static_operation_case8 n1 n2 + | Oadd, S s1 n1 :: I n2 :: nil => + eval_static_operation_case9 s1 n1 n2 + | Oaddimm n, I n1 :: nil => + eval_static_operation_case11 n n1 + | Oaddimm n, S s1 n1 :: nil => + eval_static_operation_case12 n s1 n1 + | Osub, I n1 :: I n2 :: nil => + eval_static_operation_case13 n1 n2 + | Osub, S s1 n1 :: I n2 :: nil => + eval_static_operation_case14 s1 n1 n2 + | Osubimm n, I n1 :: nil => + eval_static_operation_case15 n n1 + | Omul, I n1 :: I n2 :: nil => + eval_static_operation_case16 n1 n2 + | Omulimm n, I n1 :: nil => + eval_static_operation_case17 n n1 + | Odiv, I n1 :: I n2 :: nil => + eval_static_operation_case18 n1 n2 + | Odivu, I n1 :: I n2 :: nil => + eval_static_operation_case19 n1 n2 + | Oand, I n1 :: I n2 :: nil => + eval_static_operation_case20 n1 n2 + | Oandimm n, I n1 :: nil => + eval_static_operation_case21 n n1 + | Oor, I n1 :: I n2 :: nil => + eval_static_operation_case22 n1 n2 + | Oorimm n, I n1 :: nil => + eval_static_operation_case23 n n1 + | Oxor, I n1 :: I n2 :: nil => + eval_static_operation_case24 n1 n2 + | Oxorimm n, I n1 :: nil => + eval_static_operation_case25 n n1 + | Onand, I n1 :: I n2 :: nil => + eval_static_operation_case26 n1 n2 + | Onor, I n1 :: I n2 :: nil => + eval_static_operation_case27 n1 n2 + | Onxor, I n1 :: I n2 :: nil => + eval_static_operation_case28 n1 n2 + | Oshl, I n1 :: I n2 :: nil => + eval_static_operation_case29 n1 n2 + | Oshr, I n1 :: I n2 :: nil => + eval_static_operation_case30 n1 n2 + | Oshrimm n, I n1 :: nil => + eval_static_operation_case31 n n1 + | Oshrximm n, I n1 :: nil => + eval_static_operation_case32 n n1 + | Oshru, I n1 :: I n2 :: nil => + eval_static_operation_case33 n1 n2 + | Orolm amount mask, I n1 :: nil => + eval_static_operation_case34 amount mask n1 + | Onegf, F n1 :: nil => + eval_static_operation_case35 n1 + | Oabsf, F n1 :: nil => + eval_static_operation_case36 n1 + | Oaddf, F n1 :: F n2 :: nil => + eval_static_operation_case37 n1 n2 + | Osubf, F n1 :: F n2 :: nil => + eval_static_operation_case38 n1 n2 + | Omulf, F n1 :: F n2 :: nil => + eval_static_operation_case39 n1 n2 + | Odivf, F n1 :: F n2 :: nil => + eval_static_operation_case40 n1 n2 + | Omuladdf, F n1 :: F n2 :: F n3 :: nil => + eval_static_operation_case41 n1 n2 n3 + | Omulsubf, F n1 :: F n2 :: F n3 :: nil => + eval_static_operation_case42 n1 n2 n3 + | Osingleoffloat, F n1 :: nil => + eval_static_operation_case43 n1 + | Ointoffloat, F n1 :: nil => + eval_static_operation_case44 n1 + | Ofloatofint, I n1 :: nil => + eval_static_operation_case45 n1 + | Ofloatofintu, I n1 :: nil => + eval_static_operation_case46 n1 + | Ocmp c, vl => + eval_static_operation_case47 c vl + | Ocast8unsigned, I n1 :: nil => + eval_static_operation_case48 n1 + | Ocast16unsigned, I n1 :: nil => + eval_static_operation_case49 n1 + | Ointuoffloat, F n1 :: nil => + eval_static_operation_case50 n1 + | op, vl => + eval_static_operation_default op vl + end. + +Definition eval_static_operation (op: operation) (vl: list approx) := + match eval_static_operation_match op vl with + | eval_static_operation_case1 v1 => + v1 + | eval_static_operation_case2 n => + I n + | eval_static_operation_case3 n => + F n + | eval_static_operation_case4 s n => + S s n + | eval_static_operation_case6 n1 => + I(Int.sign_ext 8 n1) + | eval_static_operation_case7 n1 => + I(Int.sign_ext 16 n1) + | eval_static_operation_case8 n1 n2 => + I(Int.add n1 n2) + | eval_static_operation_case9 s1 n1 n2 => + S s1 (Int.add n1 n2) + | eval_static_operation_case11 n n1 => + I (Int.add n1 n) + | eval_static_operation_case12 n s1 n1 => + S s1 (Int.add n1 n) + | eval_static_operation_case13 n1 n2 => + I(Int.sub n1 n2) + | eval_static_operation_case14 s1 n1 n2 => + S s1 (Int.sub n1 n2) + | eval_static_operation_case15 n n1 => + I (Int.sub n n1) + | eval_static_operation_case16 n1 n2 => + I(Int.mul n1 n2) + | eval_static_operation_case17 n n1 => + I(Int.mul n1 n) + | eval_static_operation_case18 n1 n2 => + if Int.eq n2 Int.zero then Unknown else I(Int.divs n1 n2) + | eval_static_operation_case19 n1 n2 => + if Int.eq n2 Int.zero then Unknown else I(Int.divu n1 n2) + | eval_static_operation_case20 n1 n2 => + I(Int.and n1 n2) + | eval_static_operation_case21 n n1 => + I(Int.and n1 n) + | eval_static_operation_case22 n1 n2 => + I(Int.or n1 n2) + | eval_static_operation_case23 n n1 => + I(Int.or n1 n) + | eval_static_operation_case24 n1 n2 => + I(Int.xor n1 n2) + | eval_static_operation_case25 n n1 => + I(Int.xor n1 n) + | eval_static_operation_case26 n1 n2 => + I(Int.xor (Int.and n1 n2) Int.mone) + | eval_static_operation_case27 n1 n2 => + I(Int.xor (Int.or n1 n2) Int.mone) + | eval_static_operation_case28 n1 n2 => + I(Int.xor (Int.xor n1 n2) Int.mone) + | eval_static_operation_case29 n1 n2 => + if Int.ltu n2 (Int.repr 32) then I(Int.shl n1 n2) else Unknown + | eval_static_operation_case30 n1 n2 => + if Int.ltu n2 (Int.repr 32) then I(Int.shr n1 n2) else Unknown + | eval_static_operation_case31 n n1 => + if Int.ltu n (Int.repr 32) then I(Int.shr n1 n) else Unknown + | eval_static_operation_case32 n n1 => + if Int.ltu n (Int.repr 32) then I(Int.shrx n1 n) else Unknown + | eval_static_operation_case33 n1 n2 => + if Int.ltu n2 (Int.repr 32) then I(Int.shru n1 n2) else Unknown + | eval_static_operation_case34 amount mask n1 => + I(Int.rolm n1 amount mask) + | eval_static_operation_case35 n1 => + F(Float.neg n1) + | eval_static_operation_case36 n1 => + F(Float.abs n1) + | eval_static_operation_case37 n1 n2 => + F(Float.add n1 n2) + | eval_static_operation_case38 n1 n2 => + F(Float.sub n1 n2) + | eval_static_operation_case39 n1 n2 => + F(Float.mul n1 n2) + | eval_static_operation_case40 n1 n2 => + F(Float.div n1 n2) + | eval_static_operation_case41 n1 n2 n3 => + F(Float.add (Float.mul n1 n2) n3) + | eval_static_operation_case42 n1 n2 n3 => + F(Float.sub (Float.mul n1 n2) n3) + | eval_static_operation_case43 n1 => + F(Float.singleoffloat n1) + | eval_static_operation_case44 n1 => + I(Float.intoffloat n1) + | eval_static_operation_case45 n1 => + F(Float.floatofint n1) + | eval_static_operation_case46 n1 => + F(Float.floatofintu n1) + | eval_static_operation_case47 c vl => + match eval_static_condition c vl with + | None => Unknown + | Some b => I(if b then Int.one else Int.zero) + end + | eval_static_operation_case48 n1 => + I(Int.zero_ext 8 n1) + | eval_static_operation_case49 n1 => + I(Int.zero_ext 16 n1) + | eval_static_operation_case50 n1 => + I(Float.intuoffloat n1) + | eval_static_operation_default op vl => + Unknown + end. + +(** The transfer function for the dataflow analysis is straightforward: + for [Iop] instructions, we set the approximation of the destination + register to the result of executing abstractly the operation; + for [Iload] and [Icall], we set the approximation of the destination + to [Unknown]. *) + +Definition approx_regs (rl: list reg) (approx: D.t) := + List.map (fun r => D.get r approx) rl. + +Definition transfer (f: function) (pc: node) (before: D.t) := + match f.(fn_code)!pc with + | None => before + | Some i => + match i with + | Inop s => + before + | Iop op args res s => + let a := eval_static_operation op (approx_regs args before) in + D.set res a before + | Iload chunk addr args dst s => + D.set dst Unknown before + | Istore chunk addr args src s => + 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 => + before + | Ireturn optarg => + before + end + end. + +(** The static analysis itself is then an instantiation of Kildall's + generic solver for forward dataflow inequations. [analyze f] + returns a mapping from program points to mappings of pseudo-registers + to approximations. It can fail to reach a fixpoint in a reasonable + number of iterations, in which case [None] is returned. *) + +Module DS := Dataflow_Solver(D)(NodeSetForward). + +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 *) + +(** ** Operator strength reduction *) + +(** We now define auxiliary functions for strength reduction of + operators and addressing modes: replacing an operator with a cheaper + one if some of its arguments are statically known. These are again + large pattern-matchings expressed in indirect style. *) + +Section STRENGTH_REDUCTION. + +Variable approx: D.t. + +Definition intval (r: reg) : option int := + match D.get r approx with I n => Some n | _ => None end. + +Inductive cond_strength_reduction_cases: condition -> list reg -> Set := + | csr_case1: + forall c r1 r2, + cond_strength_reduction_cases (Ccomp c) (r1 :: r2 :: nil) + | csr_case2: + forall c r1 r2, + cond_strength_reduction_cases (Ccompu c) (r1 :: r2 :: nil) + | csr_default: + forall c rl, + cond_strength_reduction_cases c rl. + +Definition cond_strength_reduction_match (cond: condition) (rl: list reg) := + match cond as x, rl as y return cond_strength_reduction_cases x y with + | Ccomp c, r1 :: r2 :: nil => + csr_case1 c r1 r2 + | Ccompu c, r1 :: r2 :: nil => + csr_case2 c r1 r2 + | cond, rl => + csr_default cond rl + end. + +Definition cond_strength_reduction + (cond: condition) (args: list reg) : condition * list reg := + match cond_strength_reduction_match cond args with + | csr_case1 c r1 r2 => + match intval r1, intval r2 with + | Some n, _ => + (Ccompimm (swap_comparison c) n, r2 :: nil) + | _, Some n => + (Ccompimm c n, r1 :: nil) + | _, _ => + (cond, args) + end + | csr_case2 c r1 r2 => + match intval r1, intval r2 with + | Some n, _ => + (Ccompuimm (swap_comparison c) n, r2 :: nil) + | _, Some n => + (Ccompuimm c n, r1 :: nil) + | _, _ => + (cond, args) + end + | csr_default cond args => + (cond, args) + end. + +Definition make_addimm (n: int) (r: reg) := + if Int.eq n Int.zero + then (Omove, r :: nil) + else (Oaddimm n, r :: nil). + +Definition make_shlimm (n: int) (r: reg) := + if Int.eq n Int.zero + then (Omove, r :: nil) + else (Orolm n (Int.shl Int.mone n), r :: nil). + +Definition make_shrimm (n: int) (r: reg) := + if Int.eq n Int.zero + then (Omove, r :: nil) + else (Oshrimm n, r :: nil). + +Definition make_shruimm (n: int) (r: reg) := + if Int.eq n Int.zero + then (Omove, r :: nil) + else (Orolm (Int.sub (Int.repr 32) n) (Int.shru Int.mone n), r :: nil). + +Definition make_mulimm (n: int) (r: reg) := + if Int.eq n Int.zero then + (Ointconst Int.zero, nil) + else if Int.eq n Int.one then + (Omove, r :: nil) + else + match Int.is_power2 n with + | Some l => make_shlimm l r + | None => (Omulimm n, r :: nil) + end. + +Definition make_andimm (n: int) (r: reg) := + if Int.eq n Int.zero + then (Ointconst Int.zero, nil) + else if Int.eq n Int.mone then (Omove, r :: nil) + else (Oandimm n, r :: nil). + +Definition make_orimm (n: int) (r: reg) := + if Int.eq n Int.zero then (Omove, r :: nil) + else if Int.eq n Int.mone then (Ointconst Int.mone, nil) + else (Oorimm n, r :: nil). + +Definition make_xorimm (n: int) (r: reg) := + if Int.eq n Int.zero + then (Omove, r :: nil) + else (Oxorimm n, r :: nil). + +Inductive op_strength_reduction_cases: operation -> list reg -> Set := + | op_strength_reduction_case1: + forall (r1: reg) (r2: reg), + op_strength_reduction_cases Oadd (r1 :: r2 :: nil) + | op_strength_reduction_case2: + forall (r1: reg) (r2: reg), + op_strength_reduction_cases Osub (r1 :: r2 :: nil) + | op_strength_reduction_case3: + forall (r1: reg) (r2: reg), + op_strength_reduction_cases Omul (r1 :: r2 :: nil) + | op_strength_reduction_case4: + forall (r1: reg) (r2: reg), + op_strength_reduction_cases Odiv (r1 :: r2 :: nil) + | op_strength_reduction_case5: + forall (r1: reg) (r2: reg), + op_strength_reduction_cases Odivu (r1 :: r2 :: nil) + | op_strength_reduction_case6: + forall (r1: reg) (r2: reg), + op_strength_reduction_cases Oand (r1 :: r2 :: nil) + | op_strength_reduction_case7: + forall (r1: reg) (r2: reg), + op_strength_reduction_cases Oor (r1 :: r2 :: nil) + | op_strength_reduction_case8: + forall (r1: reg) (r2: reg), + op_strength_reduction_cases Oxor (r1 :: r2 :: nil) + | op_strength_reduction_case9: + forall (r1: reg) (r2: reg), + op_strength_reduction_cases Oshl (r1 :: r2 :: nil) + | op_strength_reduction_case10: + forall (r1: reg) (r2: reg), + op_strength_reduction_cases Oshr (r1 :: r2 :: nil) + | op_strength_reduction_case11: + forall (r1: reg) (r2: reg), + op_strength_reduction_cases Oshru (r1 :: r2 :: nil) + | op_strength_reduction_case12: + forall (c: condition) (rl: list reg), + op_strength_reduction_cases (Ocmp c) rl + | op_strength_reduction_default: + forall (op: operation) (args: list reg), + op_strength_reduction_cases op args. + +Definition op_strength_reduction_match (op: operation) (args: list reg) := + match op as z1, args as z2 return op_strength_reduction_cases z1 z2 with + | Oadd, r1 :: r2 :: nil => + op_strength_reduction_case1 r1 r2 + | Osub, r1 :: r2 :: nil => + op_strength_reduction_case2 r1 r2 + | Omul, r1 :: r2 :: nil => + op_strength_reduction_case3 r1 r2 + | Odiv, r1 :: r2 :: nil => + op_strength_reduction_case4 r1 r2 + | Odivu, r1 :: r2 :: nil => + op_strength_reduction_case5 r1 r2 + | Oand, r1 :: r2 :: nil => + op_strength_reduction_case6 r1 r2 + | Oor, r1 :: r2 :: nil => + op_strength_reduction_case7 r1 r2 + | Oxor, r1 :: r2 :: nil => + op_strength_reduction_case8 r1 r2 + | Oshl, r1 :: r2 :: nil => + op_strength_reduction_case9 r1 r2 + | Oshr, r1 :: r2 :: nil => + op_strength_reduction_case10 r1 r2 + | Oshru, r1 :: r2 :: nil => + op_strength_reduction_case11 r1 r2 + | Ocmp c, rl => + op_strength_reduction_case12 c rl + | op, args => + op_strength_reduction_default op args + end. + +Definition op_strength_reduction (op: operation) (args: list reg) := + match op_strength_reduction_match op args with + | op_strength_reduction_case1 r1 r2 => (* Oadd *) + match intval r1, intval r2 with + | Some n, _ => make_addimm n r2 + | _, Some n => make_addimm n r1 + | _, _ => (op, args) + end + | op_strength_reduction_case2 r1 r2 => (* Osub *) + match intval r1, intval r2 with + | Some n, _ => (Osubimm n, r2 :: nil) + | _, Some n => make_addimm (Int.neg n) r1 + | _, _ => (op, args) + end + | op_strength_reduction_case3 r1 r2 => (* Omul *) + match intval r1, intval r2 with + | Some n, _ => make_mulimm n r2 + | _, Some n => make_mulimm n r1 + | _, _ => (op, args) + end + | op_strength_reduction_case4 r1 r2 => (* Odiv *) + match intval r2 with + | Some n => + match Int.is_power2 n with + | Some l => (Oshrximm l, r1 :: nil) + | None => (op, args) + end + | None => + (op, args) + end + | op_strength_reduction_case5 r1 r2 => (* Odivu *) + match intval r2 with + | Some n => + match Int.is_power2 n with + | Some l => make_shruimm l r1 + | None => (op, args) + end + | None => + (op, args) + end + | op_strength_reduction_case6 r1 r2 => (* Oand *) + match intval r1, intval r2 with + | Some n, _ => make_andimm n r2 + | _, Some n => make_andimm n r1 + | _, _ => (op, args) + end + | op_strength_reduction_case7 r1 r2 => (* Oor *) + match intval r1, intval r2 with + | Some n, _ => make_orimm n r2 + | _, Some n => make_orimm n r1 + | _, _ => (op, args) + end + | op_strength_reduction_case8 r1 r2 => (* Oxor *) + match intval r1, intval r2 with + | Some n, _ => make_xorimm n r2 + | _, Some n => make_xorimm n r1 + | _, _ => (op, args) + end + | op_strength_reduction_case9 r1 r2 => (* Oshl *) + match intval r2 with + | Some n => + if Int.ltu n (Int.repr 32) + then make_shlimm n r1 + else (op, args) + | _ => (op, args) + end + | op_strength_reduction_case10 r1 r2 => (* Oshr *) + match intval r2 with + | Some n => + if Int.ltu n (Int.repr 32) + then make_shrimm n r1 + else (op, args) + | _ => (op, args) + end + | op_strength_reduction_case11 r1 r2 => (* Oshru *) + match intval r2 with + | Some n => + if Int.ltu n (Int.repr 32) + then make_shruimm n r1 + else (op, args) + | _ => (op, args) + end + | op_strength_reduction_case12 c args => (* Ocmp *) + let (c', args') := cond_strength_reduction c args in + (Ocmp c', args') + | op_strength_reduction_default op args => (* default *) + (op, args) + end. + +Inductive addr_strength_reduction_cases: forall (addr: addressing) (args: list reg), Set := + | addr_strength_reduction_case1: + forall (r1: reg) (r2: reg), + addr_strength_reduction_cases (Aindexed2) (r1 :: r2 :: nil) + | addr_strength_reduction_case2: + forall (symb: ident) (ofs: int) (r1: reg), + addr_strength_reduction_cases (Abased symb ofs) (r1 :: nil) + | addr_strength_reduction_case3: + forall n r1, + addr_strength_reduction_cases (Aindexed n) (r1 :: nil) + | addr_strength_reduction_default: + forall (addr: addressing) (args: list reg), + addr_strength_reduction_cases addr args. + +Definition addr_strength_reduction_match (addr: addressing) (args: list reg) := + match addr as z1, args as z2 return addr_strength_reduction_cases z1 z2 with + | Aindexed2, r1 :: r2 :: nil => + addr_strength_reduction_case1 r1 r2 + | Abased symb ofs, r1 :: nil => + addr_strength_reduction_case2 symb ofs r1 + | Aindexed n, r1 :: nil => + addr_strength_reduction_case3 n r1 + | addr, args => + addr_strength_reduction_default addr args + end. + +Definition addr_strength_reduction (addr: addressing) (args: list reg) := + match addr_strength_reduction_match addr args with + | addr_strength_reduction_case1 r1 r2 => (* Aindexed2 *) + match D.get r1 approx, D.get r2 approx with + | S symb n1, I n2 => (Aglobal symb (Int.add n1 n2), nil) + | S symb n1, _ => (Abased symb n1, r2 :: nil) + | I n1, S symb n2 => (Aglobal symb (Int.add n1 n2), nil) + | I n1, _ => (Aindexed n1, r2 :: nil) + | _, S symb n2 => (Abased symb n2, r1 :: nil) + | _, I n2 => (Aindexed n2, r1 :: nil) + | _, _ => (addr, args) + end + | addr_strength_reduction_case2 symb ofs r1 => (* Abased *) + match intval r1 with + | Some n => (Aglobal symb (Int.add ofs n), nil) + | _ => (addr, args) + end + | addr_strength_reduction_case3 n r1 => (* Aindexed *) + match D.get r1 approx with + | S symb ofs => (Aglobal symb (Int.add ofs n), nil) + | _ => (addr, args) + end + | addr_strength_reduction_default addr args => (* default *) + (addr, args) + end. + +End STRENGTH_REDUCTION. + +(** ** Code transformation *) + +(** The code transformation proceeds instruction by instruction. + Operators whose arguments are all statically known are turned + into ``load integer constant'', ``load float constant'' or + ``load symbol address'' operations. Operators for which some + but not all arguments are known are subject to 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 => + match eval_static_operation op (approx_regs args approx) with + | I n => + Iop (Ointconst n) nil res s + | F n => + Iop (Ofloatconst n) nil res s + | S symb ofs => + Iop (Oaddrsymbol symb ofs) nil res s + | _ => + let (op', args') := op_strength_reduction approx op args in + Iop op' args' res s + end + | Iload chunk addr args dst s => + let (addr', args') := addr_strength_reduction approx addr args in + Iload chunk addr' args' dst s + | Istore chunk addr args src s => + let (addr', args') := addr_strength_reduction approx addr args in + Istore chunk addr' args' src s + | 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 => + match eval_static_condition cond (approx_regs args approx) with + | Some b => + if b then Inop s1 else Inop s2 + | None => + let (cond', args') := cond_strength_reduction approx cond args in + Icond cond' args' s1 s2 + end + | _ => + instr + end. + +Definition transf_code (approxs: PMap.t D.t) (instrs: code) : code := + PTree.map (fun pc instr => transf_instr approxs!!pc instr) instrs. + +Lemma transf_code_wf: + forall f approxs, + (forall pc, Plt pc f.(fn_nextpc) \/ f.(fn_code)!pc = None) -> + (forall pc, Plt pc f.(fn_nextpc) + \/ (transf_code approxs f.(fn_code))!pc = None). +Proof. + intros. + elim (H pc); intro. + left; auto. + right. unfold transf_code. rewrite PTree.gmap. + unfold option_map; rewrite H0. reflexivity. +Qed. + +Definition transf_function (f: function) : function := + 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 (fd: fundef) : fundef := + AST.transf_fundef transf_function fd. + +Definition transf_program (p: program) : program := + transform_program transf_fundef p. diff --git a/powerpc/Constpropproof.v b/powerpc/Constpropproof.v new file mode 100644 index 0000000..e16f322 --- /dev/null +++ b/powerpc/Constpropproof.v @@ -0,0 +1,954 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Correctness proof for constant propagation. *) + +Require Import Coqlib. +Require Import Maps. +Require Import AST. +Require Import Integers. +Require Import Floats. +Require Import Values. +Require Import Events. +Require Import Mem. +Require Import Globalenvs. +Require Import Smallstep. +Require Import Op. +Require Import Registers. +Require Import RTL. +Require Import Lattice. +Require Import Kildall. +Require Import Constprop. + +(** * Correctness of the static analysis *) + +Section ANALYSIS. + +Variable ge: genv. + +(** We first show that the dataflow analysis is correct with respect + to the dynamic semantics: the approximations (sets of values) + of a register at a program point predicted by the static analysis + are a superset of the values actually encountered during concrete + executions. We formalize this correspondence between run-time values and + compile-time approximations by the following predicate. *) + +Definition val_match_approx (a: approx) (v: val) : Prop := + match a with + | Unknown => True + | I p => v = Vint p + | F p => v = Vfloat p + | S symb ofs => exists b, Genv.find_symbol ge symb = Some b /\ v = Vptr b ofs + | _ => False + end. + +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. +Proof. + intros until v. + intros [A|[B|C]]. + subst a1. simpl. auto. + subst a2. simpl. tauto. + subst a2. auto. +Qed. + +Lemma regs_match_approx_increasing: + forall a1 a2 rs, + D.ge a1 a2 -> regs_match_approx a2 rs -> regs_match_approx a1 rs. +Proof. + unfold D.ge, regs_match_approx. intros. + apply val_match_approx_increasing with (D.get r a2); auto. +Qed. + +Lemma regs_match_approx_update: + forall ra rs a v r, + val_match_approx a v -> + regs_match_approx ra rs -> + regs_match_approx (D.set r a ra) (rs#r <- v). +Proof. + intros; red; intros. rewrite Regmap.gsspec. + case (peq r0 r); intro. + subst r0. rewrite D.gss. auto. + rewrite D.gso; auto. +Qed. + +Inductive val_list_match_approx: list approx -> list val -> Prop := + | vlma_nil: + val_list_match_approx nil nil + | vlma_cons: + forall a al v vl, + val_match_approx a v -> + val_list_match_approx al vl -> + val_list_match_approx (a :: al) (v :: vl). + +Lemma approx_regs_val_list: + forall ra rs rl, + regs_match_approx ra rs -> + val_list_match_approx (approx_regs rl ra) rs##rl. +Proof. + induction rl; simpl; intros. + constructor. + constructor. apply H. auto. +Qed. + +Ltac SimplVMA := + match goal with + | H: (val_match_approx (I _) ?v) |- _ => + simpl in H; (try subst v); SimplVMA + | H: (val_match_approx (F _) ?v) |- _ => + simpl in H; (try subst v); SimplVMA + | H: (val_match_approx (S _ _) ?v) |- _ => + simpl in H; + (try (elim H; + let b := fresh "b" in let A := fresh in let B := fresh in + (intros b [A B]; subst v; clear H))); + SimplVMA + | _ => + idtac + end. + +Ltac InvVLMA := + match goal with + | H: (val_list_match_approx nil ?vl) |- _ => + inversion H + | H: (val_list_match_approx (?a :: ?al) ?vl) |- _ => + inversion H; SimplVMA; InvVLMA + | _ => + idtac + end. + +(** We then show that [eval_static_operation] is a correct abstract + interpretations of [eval_operation]: if the concrete arguments match + the given approximations, the concrete results match the + approximations returned by [eval_static_operation]. *) + +Lemma eval_static_condition_correct: + forall cond al vl m b, + val_list_match_approx al vl -> + eval_static_condition cond al = Some b -> + eval_condition cond vl m = Some b. +Proof. + intros until b. + unfold eval_static_condition. + case (eval_static_condition_match cond al); intros; + InvVLMA; simpl; congruence. +Qed. + +Lemma eval_static_operation_correct: + forall op sp al vl m v, + val_list_match_approx al vl -> + eval_operation ge sp op vl m = Some v -> + val_match_approx (eval_static_operation op al) v. +Proof. + intros until v. + unfold eval_static_operation. + case (eval_static_operation_match op al); intros; + InvVLMA; simpl in *; FuncInv; try congruence. + + destruct (Genv.find_symbol ge s). exists b. intuition congruence. + congruence. + + rewrite <- H3. replace v0 with (Vint n1). reflexivity. congruence. + rewrite <- H3. replace v0 with (Vint n1). reflexivity. congruence. + + exists b. split. auto. congruence. + exists b. split. auto. congruence. + exists b. split. auto. congruence. + + replace n2 with i0. destruct (Int.eq i0 Int.zero). + discriminate. injection H0; intro; subst v. simpl. congruence. congruence. + + replace n2 with i0. destruct (Int.eq i0 Int.zero). + discriminate. injection H0; intro; subst v. simpl. congruence. congruence. + + subst v. unfold Int.not. congruence. + subst v. unfold Int.not. congruence. + subst v. unfold Int.not. congruence. + + replace n2 with i0. destruct (Int.ltu i0 (Int.repr 32)). + injection H0; intro; subst v. simpl. congruence. discriminate. congruence. + + replace n2 with i0. destruct (Int.ltu i0 (Int.repr 32)). + injection H0; intro; subst v. simpl. congruence. discriminate. congruence. + + destruct (Int.ltu n (Int.repr 32)). + injection H0; intro; subst v. simpl. congruence. discriminate. + + destruct (Int.ltu n (Int.repr 32)). + injection H0; intro; subst v. simpl. congruence. discriminate. + + replace n2 with i0. destruct (Int.ltu i0 (Int.repr 32)). + injection H0; intro; subst v. simpl. congruence. discriminate. congruence. + + rewrite <- H3. replace v0 with (Vfloat n1). reflexivity. congruence. + + caseEq (eval_static_condition c vl0). + 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. + + rewrite <- H3. replace v0 with (Vint n1). reflexivity. congruence. + rewrite <- H3. replace v0 with (Vint n1). reflexivity. congruence. + + 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 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 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; eauto. + elim (fn_code_wf f pc); intro. auto. + unfold successors in H0; rewrite H2 in H0; simpl; contradiction. + auto. + intros. rewrite PMap.gi. apply regs_match_approx_top. +Qed. + +Lemma analyze_correct_3: + forall f rs, + regs_match_approx (analyze f)!!(f.(fn_entrypoint)) rs. +Proof. + 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; eauto. auto with coqlib. + apply regs_match_approx_top. + intros. rewrite PMap.gi. apply regs_match_approx_top. +Qed. + +(** * Correctness of strength reduction *) + +(** We now show that strength reduction over operators and addressing + modes preserve semantics: the strength-reduced operations and + addressings evaluate to the same values as the original ones if the + actual arguments match the static approximations used for strength + reduction. *) + +Section STRENGTH_REDUCTION. + +Variable approx: D.t. +Variable sp: val. +Variable rs: regset. +Hypothesis MATCH: regs_match_approx approx rs. + +Lemma intval_correct: + forall r n, + intval approx r = Some n -> rs#r = Vint n. +Proof. + intros until n. + unfold intval. caseEq (D.get r approx); intros; try discriminate. + generalize (MATCH r). unfold val_match_approx. rewrite H. + congruence. +Qed. + +Lemma cond_strength_reduction_correct: + forall cond args m, + let (cond', args') := cond_strength_reduction approx cond args in + 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. + caseEq (intval approx r1); intros. + simpl. rewrite (intval_correct _ _ H). + destruct (rs#r2); auto. rewrite Int.swap_cmp. auto. + destruct c; reflexivity. + caseEq (intval approx r2); intros. + simpl. rewrite (intval_correct _ _ H0). auto. + auto. + caseEq (intval approx r1); intros. + simpl. rewrite (intval_correct _ _ H). + destruct (rs#r2); auto. rewrite Int.swap_cmpu. auto. + caseEq (intval approx r2); intros. + simpl. rewrite (intval_correct _ _ H0). auto. + auto. + auto. +Qed. + +Lemma make_addimm_correct: + forall n r m v, + let (op, args) := make_addimm n r in + 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. + subst n. simpl in *. FuncInv. rewrite Int.add_zero in H. congruence. + rewrite Int.add_zero in H. congruence. + exact H0. +Qed. + +Lemma make_shlimm_correct: + forall n r m v, + let (op, args) := make_shlimm n r in + 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. + subst n. simpl in *. FuncInv. rewrite Int.shl_zero in H. congruence. + simpl in *. FuncInv. caseEq (Int.ltu n (Int.repr 32)); intros. + rewrite H1 in H0. rewrite Int.shl_rolm in H0. auto. exact H1. + rewrite H1 in H0. discriminate. +Qed. + +Lemma make_shrimm_correct: + forall n r m v, + let (op, args) := make_shrimm n r in + 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. + subst n. simpl in *. FuncInv. rewrite Int.shr_zero in H. congruence. + assumption. +Qed. + +Lemma make_shruimm_correct: + forall n r m v, + let (op, args) := make_shruimm n r in + 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. + subst n. simpl in *. FuncInv. rewrite Int.shru_zero in H. congruence. + simpl in *. FuncInv. caseEq (Int.ltu n (Int.repr 32)); intros. + rewrite H1 in H0. rewrite Int.shru_rolm in H0. auto. exact H1. + rewrite H1 in H0. discriminate. +Qed. + +Lemma make_mulimm_correct: + forall n r m v, + let (op, args) := make_mulimm n r in + 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. + subst n. simpl in H0. FuncInv. rewrite Int.mul_zero in H. simpl. congruence. + 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) 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. + destruct rs#r; auto. rewrite (Int.mul_pow2 i0 _ _ H1). auto. + exact H2. +Qed. + +Lemma make_andimm_correct: + forall n r m v, + let (op, args) := make_andimm n r in + 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. + subst n. simpl in *. FuncInv. rewrite Int.and_zero in H. congruence. + generalize (Int.eq_spec n Int.mone); case (Int.eq n Int.mone); intros. + subst n. simpl in *. FuncInv. rewrite Int.and_mone in H0. congruence. + exact H1. +Qed. + +Lemma make_orimm_correct: + forall n r m v, + let (op, args) := make_orimm n r in + 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. + subst n. simpl in *. FuncInv. rewrite Int.or_zero in H. congruence. + generalize (Int.eq_spec n Int.mone); case (Int.eq n Int.mone); intros. + subst n. simpl in *. FuncInv. rewrite Int.or_mone in H0. congruence. + exact H1. +Qed. + +Lemma make_xorimm_correct: + forall n r m v, + let (op, args) := make_xorimm n r in + 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. + subst n. simpl in *. FuncInv. rewrite Int.xor_zero in H. congruence. + exact H0. +Qed. + +Lemma op_strength_reduction_correct: + forall op args m v, + let (op', args') := op_strength_reduction approx op args in + 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) 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. + rewrite (intval_correct _ _ H0). apply make_addimm_correct. + assumption. + (* Osub *) + caseEq (intval approx r1); intros. + 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) 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) 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. + rewrite (intval_correct _ _ H0). apply make_mulimm_correct. + assumption. + (* Odiv *) + caseEq (intval approx r2); intros. + caseEq (Int.is_power2 i); intros. + rewrite (intval_correct _ _ H) in H1. + simpl in *; FuncInv. destruct (Int.eq i Int.zero). congruence. + change 32 with (Z_of_nat wordsize). + rewrite (Int.is_power2_range _ _ H0). + rewrite (Int.divs_pow2 i1 _ _ H0) in H1. auto. + assumption. + assumption. + (* Odivu *) + 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) 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). + rewrite (Int.is_power2_range _ _ H0). + generalize (Int.eq_spec i Int.zero); case (Int.eq i Int.zero); intros. + subst i. discriminate. + rewrite (Int.divu_pow2 i1 _ _ H0). auto. + assumption. + assumption. + (* Oand *) + caseEq (intval approx r1); intros. + rewrite (intval_correct _ _ H). + 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. + rewrite (intval_correct _ _ H0). apply make_andimm_correct. + assumption. + (* Oor *) + caseEq (intval approx r1); intros. + rewrite (intval_correct _ _ H). + 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. + rewrite (intval_correct _ _ H0). apply make_orimm_correct. + assumption. + (* Oxor *) + caseEq (intval approx r1); intros. + rewrite (intval_correct _ _ H). + 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. + rewrite (intval_correct _ _ H0). apply make_xorimm_correct. + assumption. + (* Oshl *) + caseEq (intval approx r2); intros. + caseEq (Int.ltu i (Int.repr 32)); intros. + rewrite (intval_correct _ _ H). apply make_shlimm_correct. + assumption. + assumption. + (* Oshr *) + caseEq (intval approx r2); intros. + caseEq (Int.ltu i (Int.repr 32)); intros. + rewrite (intval_correct _ _ H). apply make_shrimm_correct. + assumption. + assumption. + (* Oshru *) + caseEq (intval approx r2); intros. + caseEq (Int.ltu i (Int.repr 32)); intros. + rewrite (intval_correct _ _ H). apply make_shruimm_correct. + assumption. + assumption. + (* Ocmp *) + generalize (cond_strength_reduction_correct c rl). + destruct (cond_strength_reduction approx c rl). + simpl. intro. rewrite H. auto. + (* default *) + assumption. +Qed. + +Ltac KnownApprox := + match goal with + | MATCH: (regs_match_approx ?approx ?rs), + H: (D.get ?r ?approx = ?a) |- _ => + generalize (MATCH r); rewrite H; intro; clear H; KnownApprox + | _ => idtac + end. + +Lemma addr_strength_reduction_correct: + forall addr args, + let (addr', args') := addr_strength_reduction approx addr args in + eval_addressing ge sp addr' rs##args' = eval_addressing ge sp addr rs##args. +Proof. + intros. + + (* Useful lemmas *) + assert (A0: forall r1 r2, + eval_addressing ge sp Aindexed2 (rs ## (r1 :: r2 :: nil)) = + eval_addressing ge sp Aindexed2 (rs ## (r2 :: r1 :: nil))). + intros. simpl. destruct (rs#r1); destruct (rs#r2); auto; + rewrite Int.add_commut; auto. + + assert (A1: forall r1 r2 n, + val_match_approx (I n) rs#r2 -> + eval_addressing ge sp (Aindexed n) (rs ## (r1 :: nil)) = + eval_addressing ge sp Aindexed2 (rs ## (r1 :: r2 :: nil))). + intros; simpl in *. rewrite H. auto. + + assert (A2: forall r1 r2 n, + val_match_approx (I n) rs#r1 -> + eval_addressing ge sp (Aindexed n) (rs ## (r2 :: nil)) = + eval_addressing ge sp Aindexed2 (rs ## (r1 :: r2 :: nil))). + intros. rewrite A0. apply A1. auto. + + assert (A3: forall r1 r2 id ofs, + val_match_approx (S id ofs) rs#r1 -> + eval_addressing ge sp (Abased id ofs) (rs ## (r2 :: nil)) = + eval_addressing ge sp Aindexed2 (rs ## (r1 :: r2 :: nil))). + intros. elim H. intros b [A B]. simpl. rewrite A; rewrite B. auto. + + assert (A4: forall r1 r2 id ofs, + val_match_approx (S id ofs) rs#r2 -> + eval_addressing ge sp (Abased id ofs) (rs ## (r1 :: nil)) = + eval_addressing ge sp Aindexed2 (rs ## (r1 :: r2 :: nil))). + intros. rewrite A0. apply A3. auto. + + assert (A5: forall r1 r2 id ofs n, + val_match_approx (S id ofs) rs#r1 -> + val_match_approx (I n) rs#r2 -> + eval_addressing ge sp (Aglobal id (Int.add ofs n)) nil = + eval_addressing ge sp Aindexed2 (rs ## (r1 :: r2 :: nil))). + intros. elim H. intros b [A B]. simpl. rewrite A; rewrite B. + simpl in H0. rewrite H0. auto. + + unfold addr_strength_reduction; + case (addr_strength_reduction_match addr args); intros. + + (* Aindexed2 *) + caseEq (D.get r1 approx); intros; + caseEq (D.get r2 approx); intros; + try reflexivity; KnownApprox; auto. + rewrite A0. rewrite Int.add_commut. apply A5; auto. + + (* Abased *) + caseEq (intval approx r1); intros. + simpl; rewrite (intval_correct _ _ H). auto. + auto. + + (* Aindexed *) + caseEq (D.get r1 approx); intros; auto. + simpl; KnownApprox. + elim H0. intros b [A B]. rewrite A; rewrite B. auto. + + (* default *) + reflexivity. +Qed. + +End STRENGTH_REDUCTION. + +End ANALYSIS. + +(** * Correctness of the code transformation *) + +(** We now show that the transformed code after constant propagation + has the same semantics as the original code. *) + +Section PRESERVATION. + +Variable prog: program. +Let tprog := transf_program prog. +Let ge := Genv.globalenv prog. +Let tge := Genv.globalenv tprog. + +Lemma symbols_preserved: + forall (s: ident), Genv.find_symbol tge s = Genv.find_symbol ge s. +Proof. + intros; unfold ge, tge, tprog, transf_program. + apply Genv.find_symbol_transf. +Qed. + +Lemma functions_translated: + forall (v: val) (f: fundef), + Genv.find_funct ge v = Some f -> + Genv.find_funct tge v = Some (transf_fundef f). +Proof. + intros. + exact (Genv.find_funct_transf transf_fundef H). +Qed. + +Lemma function_ptr_translated: + forall (b: block) (f: fundef), + Genv.find_funct_ptr ge b = Some f -> + Genv.find_funct_ptr tge b = Some (transf_fundef f). +Proof. + intros. + exact (Genv.find_funct_ptr_transf transf_fundef H). +Qed. + +Lemma sig_function_translated: + forall f, + funsig (transf_fundef f) = funsig f. +Proof. + 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: +<< + st1 --------------- st2 + | | + t| |t + | | + v v + st1'--------------- st2' +>> + The left vertical arrow represents a transition in the + 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 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), 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 proof of simulation proceeds by case analysis on the transition + taken in the source code. *) + +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. + induction 1; intros; inv MS. + + (* Inop *) + 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 *) + 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' m = Some v). + rewrite (eval_operation_preserved symbols_preserved). + 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 (analyze f)!!pc) rs##args m v + (approx_regs_val_list _ _ _ args MATCH) H0). + case (eval_static_operation op (approx_regs args (analyze f)!!pc)); intros; + simpl in H2; + eapply exec_Iop; eauto; simpl. + 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 *) + 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 (analyze f)!!pc sp rs + MATCH addr args). + rewrite ASR; simpl. congruence. + TransfInstr. rewrite ASR. intro. + exists (State s' (transf_code (analyze f) (fn_code f)) sp pc' (rs#dst <- v) m); split. + 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 *) + 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 (analyze f)!!pc sp rs + MATCH addr args). + rewrite ASR; simpl. congruence. + TransfInstr. rewrite ASR. intro. + exists (State s' (transf_code (analyze f) (fn_code f)) sp pc' rs m'); split. + 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 *) + 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 *) + 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 *) + 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' m = Some true). + generalize (cond_strength_reduction_correct + ge (analyze f)!!pc rs MATCH cond args m). + rewrite CSR. intro. congruence. + TransfInstr. rewrite CSR. + caseEq (eval_static_condition cond (approx_regs args (analyze f)!!pc)). + intros b ESC. + 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. + econstructor; eauto. + apply analyze_correct_1 with pc; auto. + unfold successors; rewrite H; auto with coqlib. + unfold transfer; rewrite H; auto. + + (* Icond, false *) + 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' m = Some false). + generalize (cond_strength_reduction_correct + ge (analyze f)!!pc rs MATCH cond args m). + rewrite CSR. intro. congruence. + TransfInstr. rewrite CSR. + caseEq (eval_static_condition cond (approx_regs args (analyze f)!!pc)). + intros b ESC. + 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. + 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 *) + simpl. unfold transf_function. + econstructor; split. + eapply exec_function_internal; simpl; eauto. + simpl. econstructor; eauto. + apply analyze_correct_3; auto. + + (* external function *) + 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, using the generic preservation theorem + [Smallstep.simulation_step_preservation]. *) + +Theorem transf_program_correct: + 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/powerpc/Machregs.v b/powerpc/Machregs.v new file mode 100644 index 0000000..260a0e8 --- /dev/null +++ b/powerpc/Machregs.v @@ -0,0 +1,107 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +Require Import Coqlib. +Require Import Maps. +Require Import AST. + +(** ** Machine registers *) + +(** The following type defines the machine registers that can be referenced + as locations. These include: +- Integer registers that can be allocated to RTL pseudo-registers ([Rxx]). +- Floating-point registers that can be allocated to RTL pseudo-registers + ([Fxx]). +- Two integer registers, not allocatable, reserved as temporaries for + spilling and reloading ([IT1, IT2]). +- Two float registers, not allocatable, reserved as temporaries for + spilling and reloading ([FT1, FT2]). + + The type [mreg] does not include special-purpose machine registers + such as the stack pointer and the condition codes. *) + +Inductive mreg: Set := + (** Allocatable integer regs *) + | R3: mreg | R4: mreg | R5: mreg | R6: mreg + | R7: mreg | R8: mreg | R9: mreg | R10: mreg + | R13: mreg | R14: mreg | R15: mreg | R16: mreg + | R17: mreg | R18: mreg | R19: mreg | R20: mreg + | R21: mreg | R22: mreg | R23: mreg | R24: mreg + | R25: mreg | R26: mreg | R27: mreg | R28: mreg + | R29: mreg | R30: mreg | R31: mreg + (** Allocatable float regs *) + | F1: mreg | F2: mreg | F3: mreg | F4: mreg + | F5: mreg | F6: mreg | F7: mreg | F8: mreg + | F9: mreg | F10: mreg | F14: mreg | F15: mreg + | F16: mreg | F17: mreg | F18: mreg | F19: mreg + | F20: mreg | F21: mreg | F22: mreg | F23: mreg + | F24: mreg | F25: mreg | F26: mreg | F27: mreg + | F28: mreg | F29: mreg | F30: mreg | F31: mreg + (** Integer temporaries *) + | IT1: mreg (* R11 *) | IT2: mreg (* R0 *) + (** Float temporaries *) + | FT1: mreg (* F11 *) | FT2: mreg (* F12 *) | FT3: mreg (* F0 *). + +Lemma mreg_eq: forall (r1 r2: mreg), {r1 = r2} + {r1 <> r2}. +Proof. decide equality. Qed. + +Definition mreg_type (r: mreg): typ := + match r with + | R3 => Tint | R4 => Tint | R5 => Tint | R6 => Tint + | R7 => Tint | R8 => Tint | R9 => Tint | R10 => Tint + | R13 => Tint | R14 => Tint | R15 => Tint | R16 => Tint + | R17 => Tint | R18 => Tint | R19 => Tint | R20 => Tint + | R21 => Tint | R22 => Tint | R23 => Tint | R24 => Tint + | R25 => Tint | R26 => Tint | R27 => Tint | R28 => Tint + | R29 => Tint | R30 => Tint | R31 => Tint + | F1 => Tfloat | F2 => Tfloat | F3 => Tfloat | F4 => Tfloat + | F5 => Tfloat | F6 => Tfloat | F7 => Tfloat | F8 => Tfloat + | F9 => Tfloat | F10 => Tfloat | F14 => Tfloat | F15 => Tfloat + | F16 => Tfloat | F17 => Tfloat | F18 => Tfloat | F19 => Tfloat + | F20 => Tfloat | F21 => Tfloat | F22 => Tfloat | F23 => Tfloat + | F24 => Tfloat | F25 => Tfloat | F26 => Tfloat | F27 => Tfloat + | F28 => Tfloat | F29 => Tfloat | F30 => Tfloat | F31 => Tfloat + | IT1 => Tint | IT2 => Tint + | FT1 => Tfloat | FT2 => Tfloat | FT3 => Tfloat + end. + +Open Scope positive_scope. + +Module IndexedMreg <: INDEXED_TYPE. + Definition t := mreg. + Definition eq := mreg_eq. + Definition index (r: mreg): positive := + match r with + | R3 => 1 | R4 => 2 | R5 => 3 | R6 => 4 + | R7 => 5 | R8 => 6 | R9 => 7 | R10 => 8 + | R13 => 9 | R14 => 10 | R15 => 11 | R16 => 12 + | R17 => 13 | R18 => 14 | R19 => 15 | R20 => 16 + | R21 => 17 | R22 => 18 | R23 => 19 | R24 => 20 + | R25 => 21 | R26 => 22 | R27 => 23 | R28 => 24 + | R29 => 25 | R30 => 26 | R31 => 27 + | F1 => 28 | F2 => 29 | F3 => 30 | F4 => 31 + | F5 => 32 | F6 => 33 | F7 => 34 | F8 => 35 + | F9 => 36 | F10 => 37 | F14 => 38 | F15 => 39 + | F16 => 40 | F17 => 41 | F18 => 42 | F19 => 43 + | F20 => 44 | F21 => 45 | F22 => 46 | F23 => 47 + | F24 => 48 | F25 => 49 | F26 => 50 | F27 => 51 + | F28 => 52 | F29 => 53 | F30 => 54 | F31 => 55 + | IT1 => 56 | IT2 => 57 + | FT1 => 58 | FT2 => 59 | FT3 => 60 + end. + Lemma index_inj: + forall r1 r2, index r1 = index r2 -> r1 = r2. + Proof. + destruct r1; destruct r2; simpl; intro; discriminate || reflexivity. + Qed. +End IndexedMreg. + diff --git a/powerpc/Op.v b/powerpc/Op.v new file mode 100644 index 0000000..20ebf70 --- /dev/null +++ b/powerpc/Op.v @@ -0,0 +1,925 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Operators and addressing modes. The abstract syntax and dynamic + 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; +- [addressing]: addressing modes for load and store operations. + + These types are PowerPC-specific and correspond roughly to what the + 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 Cminor language. +*) + +Require Import Coqlib. +Require Import AST. +Require Import Integers. +Require Import Floats. +Require Import Values. +Require Import Mem. +Require Import Globalenvs. + +Set Implicit Arguments. + +(** Conditions (boolean-valued operators). *) + +Inductive condition : Set := + | Ccomp: comparison -> condition (**r signed integer comparison *) + | Ccompu: comparison -> condition (**r unsigned integer comparison *) + | Ccompimm: comparison -> int -> condition (**r signed integer comparison with a constant *) + | Ccompuimm: comparison -> int -> condition (**r unsigned integer comparison with a constant *) + | Ccompf: comparison -> condition (**r floating-point comparison *) + | Cnotcompf: comparison -> condition (**r negation of a floating-point comparison *) + | Cmaskzero: int -> condition (**r test [(arg & constant) == 0] *) + | Cmasknotzero: int -> condition. (**r test [(arg & constant) != 0] *) + +(** Arithmetic and logical operations. In the descriptions, [rd] is the + result of the operation and [r1], [r2], etc, are the arguments. *) + +Inductive operation : Set := + | Omove: operation (**r [rd = r1] *) + | Ointconst: int -> operation (**r [rd] is set to the given integer constant *) + | 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 *) +(*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] *) + | Ocast16signed: operation (**r [rd] is 16-bit sign extension of [r1] *) + | Ocast16unsigned: operation (**r [rd] is 16-bit zero extension of [r1] *) + | Oadd: operation (**r [rd = r1 + r2] *) + | Oaddimm: int -> operation (**r [rd = r1 + n] *) + | Osub: operation (**r [rd = r1 - r2] *) + | Osubimm: int -> operation (**r [rd = n - r1] *) + | Omul: operation (**r [rd = r1 * r2] *) + | Omulimm: int -> operation (**r [rd = r1 * n] *) + | Odiv: operation (**r [rd = r1 / r2] (signed) *) + | Odivu: operation (**r [rd = r1 / r2] (unsigned) *) + | Oand: operation (**r [rd = r1 & r2] *) + | Oandimm: int -> operation (**r [rd = r1 & n] *) + | Oor: operation (**r [rd = r1 | r2] *) + | Oorimm: int -> operation (**r [rd = r1 | n] *) + | Oxor: operation (**r [rd = r1 ^ r2] *) + | Oxorimm: int -> operation (**r [rd = r1 ^ n] *) + | Onand: operation (**r [rd = ~(r1 & r2)] *) + | Onor: operation (**r [rd = ~(r1 | r2)] *) + | Onxor: operation (**r [rd = ~(r1 ^ r2)] *) + | Oshl: operation (**r [rd = r1 << r2] *) + | Oshr: operation (**r [rd = r1 >> r2] (signed) *) + | Oshrimm: int -> operation (**r [rd = r1 >> n] (signed) *) + | Oshrximm: int -> operation (**r [rd = r1 / 2^n] (signed) *) + | Oshru: operation (**r [rd = r1 >> r2] (unsigned) *) + | Orolm: int -> int -> operation (**r rotate left and mask *) +(*c Floating-point arithmetic: *) + | Onegf: operation (**r [rd = - r1] *) + | Oabsf: operation (**r [rd = abs(r1)] *) + | Oaddf: operation (**r [rd = r1 + r2] *) + | Osubf: operation (**r [rd = r1 - r2] *) + | Omulf: operation (**r [rd = r1 * r2] *) + | Odivf: operation (**r [rd = r1 / r2] *) + | Omuladdf: operation (**r [rd = r1 * r2 + r3] *) + | Omulsubf: operation (**r [rd = r1 * r2 - r3] *) + | Osingleoffloat: operation (**r [rd] is [r1] truncated to single-precision float *) +(*c Conversions between int and float: *) + | Ointoffloat: operation (**r [rd = signed_int_of_float(r1)] *) + | Ointuoffloat: operation (**r [rd = unsigned_int_of_float(r1)] *) + | Ofloatofint: operation (**r [rd = float_of_signed_int(r1)] *) + | Ofloatofintu: operation (**r [rd = float_of_unsigned_int(r1)] *) +(*c Boolean tests: *) + | Ocmp: condition -> operation. (**r [rd = 1] if condition holds, [rd = 0] otherwise. *) + +(** Addressing modes. [r1], [r2], etc, are the arguments to the + addressing. *) + +Inductive addressing: Set := + | Aindexed: int -> addressing (**r Address is [r1 + offset] *) + | Aindexed2: addressing (**r Address is [r1 + r2] *) + | Aglobal: ident -> int -> addressing (**r Address is [symbol + offset] *) + | Abased: ident -> int -> addressing (**r Address is [symbol + offset + r1] *) + | Ainstack: int -> addressing. (**r Address is [stack_pointer + offset] *) + +(** Comparison functions (used in module [CSE]). *) + +Definition eq_operation (x y: operation): {x=y} + {x<>y}. +Proof. + generalize Int.eq_dec; intro. + generalize Float.eq_dec; intro. + assert (forall (x y: ident), {x=y}+{x<>y}). exact peq. + assert (forall (x y: comparison), {x=y}+{x<>y}). decide equality. + assert (forall (x y: condition), {x=y}+{x<>y}). decide equality. + decide equality. +Qed. + +Definition eq_addressing (x y: addressing) : {x=y} + {x<>y}. +Proof. + generalize Int.eq_dec; intro. + assert (forall (x y: ident), {x=y}+{x<>y}). exact peq. + decide equality. +Qed. + +(** Evaluation of conditions, operators and addressing modes applied + to lists of values. Return [None] when the computation is undefined: + wrong number of arguments, arguments of the wrong types, undefined + operations such as division by zero. [eval_condition] returns a boolean, + [eval_operation] and [eval_addressing] return a value. *) + +Definition eval_compare_mismatch (c: comparison) : option bool := + match c with Ceq => Some false | Cne => Some true | _ => None end. + +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 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 eval_compare_mismatch c + else None + | Ccomp c, Vptr b1 n1 :: Vint n2 :: nil => + if Int.eq n2 Int.zero then eval_compare_mismatch c else None + | Ccomp c, Vint n1 :: Vptr b2 n2 :: nil => + if Int.eq n1 Int.zero then eval_compare_mismatch c else None + | Ccompu c, Vint n1 :: Vint n2 :: nil => + Some (Int.cmpu c n1 n2) + | Ccompimm c n, Vint n1 :: nil => + Some (Int.cmp c n1 n) + | Ccompimm c n, Vptr b1 n1 :: nil => + if Int.eq n Int.zero then eval_compare_mismatch c else None + | Ccompuimm c n, Vint n1 :: nil => + Some (Int.cmpu c n1 n) + | Ccompf c, Vfloat f1 :: Vfloat f2 :: nil => + Some (Float.cmp c f1 f2) + | Cnotcompf c, Vfloat f1 :: Vfloat f2 :: nil => + Some (negb (Float.cmp c f1 f2)) + | Cmaskzero n, Vint n1 :: nil => + Some (Int.eq (Int.and n1 n) Int.zero) + | Cmasknotzero n, Vint n1 :: nil => + Some (negb (Int.eq (Int.and n1 n) Int.zero)) + | _, _ => + None + end. + +Definition offset_sp (sp: val) (delta: int) : option val := + match sp with + | Vptr b n => Some (Vptr b (Int.add n delta)) + | _ => None + end. + +Definition eval_operation + (F: Set) (genv: Genv.t F) (sp: 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) + | Ofloatconst n, nil => Some (Vfloat n) + | Oaddrsymbol s ofs, nil => + match Genv.find_symbol genv s with + | None => None + | Some b => Some (Vptr b ofs) + end + | Oaddrstack ofs, nil => offset_sp sp ofs + | Ocast8signed, v1 :: nil => Some (Val.sign_ext 8 v1) + | Ocast8unsigned, v1 :: nil => Some (Val.zero_ext 8 v1) + | Ocast16signed, v1 :: nil => Some (Val.sign_ext 16 v1) + | Ocast16unsigned, v1 :: nil => Some (Val.zero_ext 16 v1) + | 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)) + | Oaddimm n, Vint n1 :: nil => Some (Vint (Int.add n1 n)) + | Oaddimm n, Vptr b1 n1 :: nil => Some (Vptr b1 (Int.add n1 n)) + | 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 + | Osubimm n, Vint n1 :: nil => Some (Vint (Int.sub n n1)) + | Omul, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.mul n1 n2)) + | Omulimm n, Vint n1 :: nil => Some (Vint (Int.mul n1 n)) + | 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)) + | Oand, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.and n1 n2)) + | Oandimm n, Vint n1 :: nil => Some (Vint (Int.and n1 n)) + | Oor, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.or n1 n2)) + | Oorimm n, Vint n1 :: nil => Some (Vint (Int.or n1 n)) + | Oxor, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.xor n1 n2)) + | Oxorimm n, Vint n1 :: nil => Some (Vint (Int.xor n1 n)) + | Onand, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.not (Int.and n1 n2))) + | Onor, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.not (Int.or n1 n2))) + | Onxor, Vint n1 :: Vint n2 :: nil => Some (Vint (Int.not (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 + | Oshrimm n, Vint n1 :: nil => + if Int.ltu n (Int.repr 32) then Some (Vint (Int.shr n1 n)) else None + | Oshrximm n, Vint n1 :: nil => + if Int.ltu n (Int.repr 32) then Some (Vint (Int.shrx n1 n)) else None + | Oshru, Vint n1 :: Vint n2 :: nil => + if Int.ltu n2 (Int.repr 32) then Some (Vint (Int.shru n1 n2)) else None + | Orolm amount mask, Vint n1 :: nil => + Some (Vint (Int.rolm n1 amount mask)) + | 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)) + | Omuladdf, Vfloat f1 :: Vfloat f2 :: Vfloat f3 :: nil => + Some (Vfloat (Float.add (Float.mul f1 f2) f3)) + | Omulsubf, Vfloat f1 :: Vfloat f2 :: Vfloat f3 :: nil => + Some (Vfloat (Float.sub (Float.mul f1 f2) f3)) + | Osingleoffloat, v1 :: nil => + Some (Val.singleoffloat v1) + | Ointoffloat, Vfloat f1 :: nil => + Some (Vint (Float.intoffloat f1)) + | Ointuoffloat, Vfloat f1 :: nil => + Some (Vint (Float.intuoffloat f1)) + | Ofloatofint, Vint n1 :: nil => + Some (Vfloat (Float.floatofint n1)) + | Ofloatofintu, Vint n1 :: nil => + Some (Vfloat (Float.floatofintu n1)) + | Ocmp c, _ => + match eval_condition c vl m with + | None => None + | Some false => Some Vfalse + | Some true => Some Vtrue + end + | _, _ => None + end. + +Definition eval_addressing + (F: Set) (genv: Genv.t F) (sp: val) + (addr: addressing) (vl: list val) : option val := + match addr, vl with + | Aindexed n, Vptr b1 n1 :: nil => + Some (Vptr b1 (Int.add n1 n)) + | Aindexed2, Vptr b1 n1 :: Vint n2 :: nil => + Some (Vptr b1 (Int.add n1 n2)) + | Aindexed2, Vint n1 :: Vptr b2 n2 :: nil => + Some (Vptr b2 (Int.add n2 n1)) + | Aglobal s ofs, nil => + match Genv.find_symbol genv s with + | None => None + | Some b => Some (Vptr b ofs) + end + | Abased s ofs, Vint n1 :: nil => + match Genv.find_symbol genv s with + | None => None + | Some b => Some (Vptr b (Int.add ofs n1)) + end + | Ainstack ofs, nil => + offset_sp sp ofs + | _, _ => None + end. + +Definition negate_condition (cond: condition): condition := + match cond with + | Ccomp c => Ccomp(negate_comparison c) + | Ccompu c => Ccompu(negate_comparison c) + | Ccompimm c n => Ccompimm (negate_comparison c) n + | Ccompuimm c n => Ccompuimm (negate_comparison c) n + | Ccompf c => Cnotcompf c + | Cnotcompf c => Ccompf c + | Cmaskzero n => Cmasknotzero n + | Cmasknotzero n => Cmaskzero n + end. + +Ltac FuncInv := + match goal with + | H: (match ?x with nil => _ | _ :: _ => _ end = Some _) |- _ => + destruct x; simpl in H; try discriminate; FuncInv + | H: (match ?v with Vundef => _ | Vint _ => _ | Vfloat _ => _ | Vptr _ _ => _ end = Some _) |- _ => + destruct v; simpl in H; try discriminate; FuncInv + | H: (Some _ = Some _) |- _ => + injection H; intros; clear H; FuncInv + | _ => + idtac + end. + +Remark eval_negate_compare_mismatch: + forall c b, + eval_compare_mismatch c = Some b -> + eval_compare_mismatch (negate_comparison c) = Some (negb b). +Proof. + intros until b. unfold eval_compare_mismatch. + destruct c; intro EQ; inv EQ; auto. +Qed. + +Lemma eval_negate_condition: + 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. + destruct (Int.eq i Int.zero). apply eval_negate_compare_mismatch; auto. discriminate. + destruct (Int.eq i0 Int.zero). apply eval_negate_compare_mismatch; auto. discriminate. + 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. + apply eval_negate_compare_mismatch; auto. + discriminate. + rewrite Int.negate_cmpu. auto. + rewrite Int.negate_cmp. auto. + destruct (Int.eq i Int.zero). apply eval_negate_compare_mismatch; auto. discriminate. + rewrite Int.negate_cmpu. auto. + auto. + rewrite negb_elim. auto. + auto. + rewrite negb_elim. auto. +Qed. + +(** [eval_operation] and [eval_addressing] depend on a global environment + for resolving references to global symbols. We show that they give + the same results if a global environment is replaced by another that + assigns the same addresses to the same symbols. *) + +Section GENV_TRANSF. + +Variable F1 F2: Set. +Variable ge1: Genv.t F1. +Variable ge2: Genv.t F2. +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 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; + reflexivity. +Qed. + +Lemma eval_addressing_preserved: + forall sp addr vl, + eval_addressing ge2 sp addr vl = eval_addressing ge1 sp addr vl. +Proof. + intros. + unfold eval_addressing; destruct addr; try rewrite agree_on_symbols; + reflexivity. +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 + (A: Set) (op: operation) (args: list A) : option A := + match op, args with + | Omove, arg :: nil => Some arg + | _, _ => None + end. + +Lemma is_move_operation_correct: + forall (A: Set) (op: operation) (args: list A) (a: A), + is_move_operation op args = Some a -> + op = Omove /\ args = a :: nil. +Proof. + intros until a. unfold is_move_operation; destruct op; + try (intros; discriminate). + destruct args. intros; discriminate. + destruct args. intros. intuition congruence. + intros; discriminate. +Qed. + +(** Static typing of conditions, operators and addressing modes. *) + +Definition type_of_condition (c: condition) : list typ := + match c with + | Ccomp _ => Tint :: Tint :: nil + | Ccompu _ => Tint :: Tint :: nil + | Ccompimm _ _ => Tint :: nil + | Ccompuimm _ _ => Tint :: nil + | Ccompf _ => Tfloat :: Tfloat :: nil + | Cnotcompf _ => Tfloat :: Tfloat :: nil + | Cmaskzero _ => Tint :: nil + | Cmasknotzero _ => Tint :: nil + end. + +Definition type_of_operation (op: operation) : list typ * typ := + match op with + | Omove => (nil, Tint) (* treated specially *) + | Ointconst _ => (nil, Tint) + | Ofloatconst _ => (nil, Tfloat) + | Oaddrsymbol _ _ => (nil, Tint) + | Oaddrstack _ => (nil, Tint) + | Ocast8signed => (Tint :: nil, Tint) + | Ocast8unsigned => (Tint :: nil, Tint) + | Ocast16signed => (Tint :: nil, Tint) + | Ocast16unsigned => (Tint :: nil, Tint) + | Oadd => (Tint :: Tint :: nil, Tint) + | Oaddimm _ => (Tint :: nil, Tint) + | Osub => (Tint :: Tint :: nil, Tint) + | Osubimm _ => (Tint :: nil, Tint) + | Omul => (Tint :: Tint :: nil, Tint) + | Omulimm _ => (Tint :: nil, Tint) + | Odiv => (Tint :: Tint :: nil, Tint) + | Odivu => (Tint :: Tint :: nil, Tint) + | Oand => (Tint :: Tint :: nil, Tint) + | Oandimm _ => (Tint :: nil, Tint) + | Oor => (Tint :: Tint :: nil, Tint) + | Oorimm _ => (Tint :: nil, Tint) + | Oxor => (Tint :: Tint :: nil, Tint) + | Oxorimm _ => (Tint :: nil, Tint) + | Onand => (Tint :: Tint :: nil, Tint) + | Onor => (Tint :: Tint :: nil, Tint) + | Onxor => (Tint :: Tint :: nil, Tint) + | Oshl => (Tint :: Tint :: nil, Tint) + | Oshr => (Tint :: Tint :: nil, Tint) + | Oshrimm _ => (Tint :: nil, Tint) + | Oshrximm _ => (Tint :: nil, Tint) + | Oshru => (Tint :: Tint :: nil, Tint) + | Orolm _ _ => (Tint :: nil, Tint) + | Onegf => (Tfloat :: nil, Tfloat) + | Oabsf => (Tfloat :: nil, Tfloat) + | Oaddf => (Tfloat :: Tfloat :: nil, Tfloat) + | Osubf => (Tfloat :: Tfloat :: nil, Tfloat) + | Omulf => (Tfloat :: Tfloat :: nil, Tfloat) + | Odivf => (Tfloat :: Tfloat :: nil, Tfloat) + | Omuladdf => (Tfloat :: Tfloat :: Tfloat :: nil, Tfloat) + | Omulsubf => (Tfloat :: Tfloat :: Tfloat :: nil, Tfloat) + | Osingleoffloat => (Tfloat :: nil, Tfloat) + | Ointoffloat => (Tfloat :: nil, Tint) + | Ointuoffloat => (Tfloat :: nil, Tint) + | Ofloatofint => (Tint :: nil, Tfloat) + | Ofloatofintu => (Tint :: nil, Tfloat) + | Ocmp c => (type_of_condition c, Tint) + end. + +Definition type_of_addressing (addr: addressing) : list typ := + match addr with + | Aindexed _ => Tint :: nil + | Aindexed2 => Tint :: Tint :: nil + | Aglobal _ _ => nil + | Abased _ _ => Tint :: nil + | Ainstack _ => nil + end. + +Definition type_of_chunk (c: memory_chunk) : typ := + match c with + | Mint8signed => Tint + | Mint8unsigned => Tint + | Mint16signed => Tint + | Mint16unsigned => Tint + | Mint32 => Tint + | Mfloat32 => Tfloat + | Mfloat64 => Tfloat + end. + +(** Weak type soundness results for [eval_operation]: + the result values, when defined, are always of the type predicted + by [type_of_operation]. *) + +Section SOUNDNESS. + +Variable A: Set. +Variable genv: Genv.t A. + +Lemma type_of_operation_sound: + 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 H0; FuncInv; try subst v; try exact I. + congruence. + 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 H0; intro; subst v; exact I. + discriminate. + destruct (Int.eq i0 Int.zero). discriminate. + injection H0; intro; subst v; exact I. + destruct (Int.eq i0 Int.zero). discriminate. + injection H0; intro; subst v; exact I. + destruct (Int.ltu i0 (Int.repr 32)). + injection H0; intro; subst v; exact I. discriminate. + destruct (Int.ltu i0 (Int.repr 32)). + injection H0; intro; subst v; exact I. discriminate. + destruct (Int.ltu i (Int.repr 32)). + injection H0; intro; subst v; exact I. discriminate. + destruct (Int.ltu i (Int.repr 32)). + injection H0; intro; subst v; exact I. discriminate. + destruct (Int.ltu i0 (Int.repr 32)). + injection H0; intro; subst v; exact I. discriminate. + destruct v0; exact I. + destruct (eval_condition c vl). + destruct b; injection H0; intro; subst v; exact I. + discriminate. +Qed. + +Lemma type_of_chunk_correct: + forall chunk m addr v, + Mem.loadv chunk m addr = Some v -> + Val.has_type v (type_of_chunk chunk). +Proof. + intro chunk. + assert (forall v, Val.has_type (Val.load_result chunk v) (type_of_chunk chunk)). + destruct v; destruct chunk; exact I. + intros until v. unfold Mem.loadv. + destruct addr; intros; try discriminate. + generalize (Mem.load_inv _ _ _ _ _ H0). + intros [X Y]. subst v. apply H. +Qed. + +End SOUNDNESS. + +(** Alternate definition of [eval_condition], [eval_op], [eval_addressing] + as total functions that return [Vundef] when not applicable + (instead of [None]). Used in the proof of [PPCgen]. *) + +Section EVAL_OP_TOTAL. + +Variable F: Set. +Variable genv: Genv.t F. + +Definition find_symbol_offset (id: ident) (ofs: int) : val := + match Genv.find_symbol genv id with + | Some b => Vptr b ofs + | None => Vundef + end. + +Definition eval_condition_total (cond: condition) (vl: list val) : val := + match cond, vl with + | Ccomp c, v1::v2::nil => Val.cmp c v1 v2 + | Ccompu c, v1::v2::nil => Val.cmpu c v1 v2 + | Ccompimm c n, v1::nil => Val.cmp c v1 (Vint n) + | Ccompuimm c n, v1::nil => Val.cmpu c v1 (Vint n) + | Ccompf c, v1::v2::nil => Val.cmpf c v1 v2 + | Cnotcompf c, v1::v2::nil => Val.notbool(Val.cmpf c v1 v2) + | Cmaskzero n, v1::nil => Val.notbool (Val.and v1 (Vint n)) + | Cmasknotzero n, v1::nil => Val.notbool(Val.notbool (Val.and v1 (Vint n))) + | _, _ => Vundef + end. + +Definition eval_operation_total (sp: val) (op: operation) (vl: list val) : val := + match op, vl with + | Omove, v1::nil => v1 + | Ointconst n, nil => Vint n + | Ofloatconst n, nil => Vfloat n + | Oaddrsymbol s ofs, nil => find_symbol_offset s ofs + | Oaddrstack ofs, nil => Val.add sp (Vint ofs) + | Ocast8signed, v1::nil => Val.sign_ext 8 v1 + | Ocast8unsigned, v1::nil => Val.zero_ext 8 v1 + | Ocast16signed, v1::nil => Val.sign_ext 16 v1 + | Ocast16unsigned, v1::nil => Val.zero_ext 16 v1 + | Oadd, v1::v2::nil => Val.add v1 v2 + | Oaddimm n, v1::nil => Val.add v1 (Vint n) + | Osub, v1::v2::nil => Val.sub v1 v2 + | Osubimm n, v1::nil => Val.sub (Vint n) v1 + | Omul, v1::v2::nil => Val.mul v1 v2 + | Omulimm n, v1::nil => Val.mul v1 (Vint n) + | Odiv, v1::v2::nil => Val.divs v1 v2 + | Odivu, v1::v2::nil => Val.divu v1 v2 + | Oand, v1::v2::nil => Val.and v1 v2 + | Oandimm n, v1::nil => Val.and v1 (Vint n) + | Oor, v1::v2::nil => Val.or v1 v2 + | Oorimm n, v1::nil => Val.or v1 (Vint n) + | Oxor, v1::v2::nil => Val.xor v1 v2 + | Oxorimm n, v1::nil => Val.xor v1 (Vint n) + | Onand, v1::v2::nil => Val.notint(Val.and v1 v2) + | Onor, v1::v2::nil => Val.notint(Val.or v1 v2) + | Onxor, v1::v2::nil => Val.notint(Val.xor v1 v2) + | Oshl, v1::v2::nil => Val.shl v1 v2 + | Oshr, v1::v2::nil => Val.shr v1 v2 + | Oshrimm n, v1::nil => Val.shr v1 (Vint n) + | Oshrximm n, v1::nil => Val.shrx v1 (Vint n) + | Oshru, v1::v2::nil => Val.shru v1 v2 + | Orolm amount mask, v1::nil => Val.rolm v1 amount mask + | Onegf, v1::nil => Val.negf v1 + | Oabsf, v1::nil => Val.absf v1 + | Oaddf, v1::v2::nil => Val.addf v1 v2 + | Osubf, v1::v2::nil => Val.subf v1 v2 + | Omulf, v1::v2::nil => Val.mulf v1 v2 + | Odivf, v1::v2::nil => Val.divf v1 v2 + | Omuladdf, v1::v2::v3::nil => Val.addf (Val.mulf v1 v2) v3 + | Omulsubf, v1::v2::v3::nil => Val.subf (Val.mulf v1 v2) v3 + | Osingleoffloat, v1::nil => Val.singleoffloat v1 + | Ointoffloat, v1::nil => Val.intoffloat v1 + | Ointuoffloat, v1::nil => Val.intuoffloat v1 + | Ofloatofint, v1::nil => Val.floatofint v1 + | Ofloatofintu, v1::nil => Val.floatofintu v1 + | Ocmp c, _ => eval_condition_total c vl + | _, _ => Vundef + end. + +Definition eval_addressing_total + (sp: val) (addr: addressing) (vl: list val) : val := + match addr, vl with + | Aindexed n, v1::nil => Val.add v1 (Vint n) + | Aindexed2, v1::v2::nil => Val.add v1 v2 + | Aglobal s ofs, nil => find_symbol_offset s ofs + | Abased s ofs, v1::nil => Val.add (find_symbol_offset s ofs) v1 + | Ainstack ofs, nil => Val.add sp (Vint ofs) + | _, _ => Vundef + end. + +Lemma eval_compare_mismatch_weaken: + forall c b, + eval_compare_mismatch c = Some b -> + Val.cmp_mismatch c = Val.of_bool b. +Proof. + unfold eval_compare_mismatch. intros. destruct c; inv H; auto. +Qed. + +Lemma eval_compare_null_weaken: + forall n c b, + (if Int.eq n Int.zero then eval_compare_mismatch c else None) = Some b -> + (if Int.eq n Int.zero then Val.cmp_mismatch c else Vundef) = Val.of_bool b. +Proof. + intros. destruct (Int.eq n Int.zero). apply eval_compare_mismatch_weaken. auto. + discriminate. +Qed. + +Lemma eval_condition_weaken: + 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. + apply eval_compare_mismatch_weaken; auto. + discriminate. + symmetry. apply Val.notbool_negb_1. + symmetry. apply Val.notbool_negb_1. +Qed. + +Lemma eval_operation_weaken: + forall sp op vl m v, + eval_operation genv sp op vl m = Some v -> + eval_operation_total sp op vl = v. +Proof. + intros. + unfold eval_operation in H; destruct op; FuncInv; + try subst v; try reflexivity; simpl. + unfold find_symbol_offset. + destruct (Genv.find_symbol genv i); try discriminate. + congruence. + unfold offset_sp in H. + destruct sp; try discriminate. simpl. congruence. + unfold eq_block in H. destruct (zeq b b0); congruence. + destruct (Int.eq i0 Int.zero); congruence. + destruct (Int.eq i0 Int.zero); congruence. + destruct (Int.ltu i0 (Int.repr 32)); congruence. + destruct (Int.ltu i0 (Int.repr 32)); congruence. + 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 m); intros; rewrite H0 in H. + replace v with (Val.of_bool b). + eapply eval_condition_weaken; eauto. + destruct b; simpl; congruence. + discriminate. +Qed. + +Lemma eval_addressing_weaken: + forall sp addr vl v, + eval_addressing genv sp addr vl = Some v -> + eval_addressing_total sp addr vl = v. +Proof. + intros. + unfold eval_addressing in H; destruct addr; FuncInv; + try subst v; simpl; try reflexivity. + unfold find_symbol_offset. + destruct (Genv.find_symbol genv i); congruence. + unfold find_symbol_offset. + destruct (Genv.find_symbol genv i); try congruence. + inversion H. reflexivity. + unfold offset_sp in H. destruct sp; simpl; congruence. +Qed. + +Lemma eval_condition_total_is_bool: + forall cond vl, Val.is_bool (eval_condition_total cond vl). +Proof. + intros; destruct cond; + destruct vl; try apply Val.undef_is_bool; + destruct vl; try apply Val.undef_is_bool; + try (destruct vl; try apply Val.undef_is_bool); simpl. + apply Val.cmp_is_bool. + apply Val.cmpu_is_bool. + apply Val.cmp_is_bool. + apply Val.cmpu_is_bool. + apply Val.cmpf_is_bool. + apply Val.notbool_is_bool. + apply Val.notbool_is_bool. + apply Val.notbool_is_bool. +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. + rewrite (Mem.valid_pointer_lessdef _ _ _ _ MEM H1). + rewrite (Mem.valid_pointer_lessdef _ _ _ _ MEM H). simpl. + 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.sign_ext 8 v2); split. auto. apply Val.sign_ext_lessdef; auto. + exists (Val.zero_ext 8 v2); split. auto. apply Val.zero_ext_lessdef; auto. + exists (Val.sign_ext 16 v2); split. auto. apply Val.sign_ext_lessdef; auto. + exists (Val.zero_ext 16 v2); split. auto. apply Val.zero_ext_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. + +(** Transformation of addressing modes with two operands or more + into an equivalent arithmetic operation. This is used in the [Reload] + pass when a store instruction cannot be reloaded directly because + it runs out of temporary registers. *) + +(** For the PowerPC, there is only one binary addressing mode: [Aindexed2]. + The corresponding operation is [Oadd]. *) + +Definition op_for_binary_addressing (addr: addressing) : operation := Oadd. + +Lemma eval_op_for_binary_addressing: + forall (F: Set) (ge: Genv.t F) sp addr args m v, + (length args >= 2)%nat -> + eval_addressing ge sp addr args = Some v -> + eval_operation ge sp (op_for_binary_addressing addr) args m = Some v. +Proof. + intros. + unfold eval_addressing in H0; destruct addr; FuncInv; simpl in H; try omegaContradiction; + simpl; congruence. +Qed. + +Lemma type_op_for_binary_addressing: + forall addr, + (length (type_of_addressing addr) >= 2)%nat -> + type_of_operation (op_for_binary_addressing addr) = (type_of_addressing addr, Tint). +Proof. + intros. destruct addr; simpl in H; reflexivity || omegaContradiction. +Qed. diff --git a/powerpc/PrintAsm.ml b/powerpc/PrintAsm.ml new file mode 100644 index 0000000..0e45c84 --- /dev/null +++ b/powerpc/PrintAsm.ml @@ -0,0 +1,532 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(* Printing PPC assembly code in asm syntax *) + +open Printf +open Datatypes +open CList +open Camlcoq +open AST +open Asm + +(* On-the-fly label renaming *) + +let next_label = ref 100 + +let new_label() = + let lbl = !next_label in incr next_label; lbl + +let current_function_labels = (Hashtbl.create 39 : (label, int) Hashtbl.t) + +let label_for_label lbl = + try + Hashtbl.find current_function_labels lbl + with Not_found -> + let lbl' = new_label() in + Hashtbl.add current_function_labels lbl lbl'; + lbl' + +(* Record identifiers of external functions *) + +module IdentSet = Set.Make(struct type t = ident let compare = compare end) + +let extfuns = ref IdentSet.empty + +let record_extfun (Coq_pair(name, defn)) = + match defn with + | Internal _ -> () + | External _ -> extfuns := IdentSet.add name !extfuns + +(* Basic printing functions *) + +let print_symb oc symb = + if IdentSet.mem symb !extfuns + then fprintf oc "L%s$stub" (extern_atom symb) + else fprintf oc "_%s" (extern_atom symb) + +let print_label oc lbl = + fprintf oc "L%d" (label_for_label lbl) + +let print_symb_ofs oc (symb, ofs) = + print_symb oc symb; + if ofs <> 0l then fprintf oc " + %ld" ofs + +let print_constant oc = function + | Cint n -> + fprintf oc "%ld" (camlint_of_coqint n) + | Csymbol_low(s, n) -> + fprintf oc "lo16(%a)" print_symb_ofs (s, camlint_of_coqint n) + | Csymbol_high(s, n) -> + fprintf oc "ha16(%a)" print_symb_ofs (s, camlint_of_coqint n) + +let num_crbit = function + | CRbit_0 -> 0 + | CRbit_1 -> 1 + | CRbit_2 -> 2 + | CRbit_3 -> 3 + +let print_crbit oc bit = + fprintf oc "%d" (num_crbit bit) + +let print_coqint oc n = + fprintf oc "%ld" (camlint_of_coqint n) + +let int_reg_name = function + | GPR0 -> "r0" | GPR1 -> "r1" | GPR2 -> "r2" | GPR3 -> "r3" + | GPR4 -> "r4" | GPR5 -> "r5" | GPR6 -> "r6" | GPR7 -> "r7" + | GPR8 -> "r8" | GPR9 -> "r9" | GPR10 -> "r10" | GPR11 -> "r11" + | GPR12 -> "r12" | GPR13 -> "r13" | GPR14 -> "r14" | GPR15 -> "r15" + | GPR16 -> "r16" | GPR17 -> "r17" | GPR18 -> "r18" | GPR19 -> "r19" + | GPR20 -> "r20" | GPR21 -> "r21" | GPR22 -> "r22" | GPR23 -> "r23" + | GPR24 -> "r24" | GPR25 -> "r25" | GPR26 -> "r26" | GPR27 -> "r27" + | GPR28 -> "r28" | GPR29 -> "r29" | GPR30 -> "r30" | GPR31 -> "r31" + +let float_reg_name = function + | FPR0 -> "f0" | FPR1 -> "f1" | FPR2 -> "f2" | FPR3 -> "f3" + | FPR4 -> "f4" | FPR5 -> "f5" | FPR6 -> "f6" | FPR7 -> "f7" + | FPR8 -> "f8" | FPR9 -> "f9" | FPR10 -> "f10" | FPR11 -> "f11" + | FPR12 -> "f12" | FPR13 -> "f13" | FPR14 -> "f14" | FPR15 -> "f15" + | FPR16 -> "f16" | FPR17 -> "f17" | FPR18 -> "f18" | FPR19 -> "f19" + | FPR20 -> "f20" | FPR21 -> "f21" | FPR22 -> "f22" | FPR23 -> "f23" + | FPR24 -> "f24" | FPR25 -> "f25" | FPR26 -> "f26" | FPR27 -> "f27" + | FPR28 -> "f28" | FPR29 -> "f29" | FPR30 -> "f30" | FPR31 -> "f31" + +let ireg oc r = output_string oc (int_reg_name r) +let ireg_or_zero oc r = if r = GPR0 then output_string oc "0" else ireg oc r +let freg oc r = output_string oc (float_reg_name r) + +(* Printing of instructions *) + +module Labelset = Set.Make(struct type t = label let compare = compare end) + +let print_instruction oc labels = function + | Padd(r1, r2, r3) -> + fprintf oc " add %a, %a, %a\n" ireg r1 ireg r2 ireg r3 + | Paddi(r1, r2, c) -> + fprintf oc " addi %a, %a, %a\n" ireg r1 ireg_or_zero r2 print_constant c + | Paddis(r1, r2, c) -> + fprintf oc " addis %a, %a, %a\n" ireg r1 ireg_or_zero r2 print_constant c + | Paddze(r1, r2) -> + fprintf oc " addze %a, %a\n" ireg r1 ireg r2 + | Pallocblock -> + fprintf oc " bl _compcert_alloc\n" + | Pallocframe(lo, hi, ofs) -> + let lo = camlint_of_coqint lo + and hi = camlint_of_coqint hi + and ofs = camlint_of_coqint ofs in + let sz = Int32.sub hi lo in + (* Keep stack 16-aligned *) + let sz16 = Int32.logand (Int32.add sz 15l) 0xFFFF_FFF0l in + assert (ofs = 0l); + fprintf oc " stwu r1, %ld(r1)\n" (Int32.neg sz16) + | Pand_(r1, r2, r3) -> + fprintf oc " and. %a, %a, %a\n" ireg r1 ireg r2 ireg r3 + | Pandc(r1, r2, r3) -> + fprintf oc " andc %a, %a, %a\n" ireg r1 ireg r2 ireg r3 + | Pandi_(r1, r2, c) -> + fprintf oc " andi. %a, %a, %a\n" ireg r1 ireg r2 print_constant c + | Pandis_(r1, r2, c) -> + fprintf oc " andis. %a, %a, %a\n" ireg r1 ireg r2 print_constant c + | Pb lbl -> + fprintf oc " b %a\n" print_label lbl + | Pbctr -> + fprintf oc " bctr\n" + | Pbctrl -> + fprintf oc " bctrl\n" + | Pbf(bit, lbl) -> + 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) -> + fprintf oc " bt %a, %a\n" print_crbit bit print_label lbl + | Pcmplw(r1, r2) -> + fprintf oc " cmplw cr0, %a, %a\n" ireg r1 ireg r2 + | Pcmplwi(r1, c) -> + fprintf oc " cmplwi cr0, %a, %a\n" ireg r1 print_constant c + | Pcmpw(r1, r2) -> + fprintf oc " cmpw cr0, %a, %a\n" ireg r1 ireg r2 + | Pcmpwi(r1, c) -> + fprintf oc " cmpwi cr0, %a, %a\n" ireg r1 print_constant c + | Pcror(c1, c2, c3) -> + fprintf oc " cror %a, %a, %a\n" print_crbit c1 print_crbit c2 print_crbit c3 + | Pdivw(r1, r2, r3) -> + fprintf oc " divw %a, %a, %a\n" ireg r1 ireg r2 ireg r3 + | Pdivwu(r1, r2, r3) -> + fprintf oc " divwu %a, %a, %a\n" ireg r1 ireg r2 ireg r3 + | Peqv(r1, r2, r3) -> + fprintf oc " eqv %a, %a, %a\n" ireg r1 ireg r2 ireg r3 + | Pextsb(r1, r2) -> + fprintf oc " extsb %a, %a\n" ireg r1 ireg r2 + | Pextsh(r1, r2) -> + fprintf oc " extsh %a, %a\n" ireg r1 ireg r2 + | Pfreeframe ofs -> + fprintf oc " lwz r1, %ld(r1)\n" (camlint_of_coqint ofs) + | Pfabs(r1, r2) -> + fprintf oc " fabs %a, %a\n" freg r1 freg r2 + | Pfadd(r1, r2, r3) -> + fprintf oc " fadd %a, %a, %a\n" freg r1 freg r2 freg r3 + | Pfcmpu(r1, r2) -> + fprintf oc " fcmpu cr0, %a, %a\n" freg r1 freg r2 + | Pfcti(r1, r2) -> + fprintf oc " fctiwz f13, %a\n" freg r2; + fprintf oc " stfd f13, -8(r1)\n"; + fprintf oc " lwz %a, -4(r1)\n" ireg r1 + | Pfctiu(r1, r2) -> + let lbl1 = new_label() in + let lbl2 = new_label() in + let lbl3 = new_label() in + fprintf oc " addis r12, 0, ha16(L%d)\n" lbl1; + fprintf oc " lfd f13, lo16(L%d)(r12)\n" lbl1; + fprintf oc " fcmpu cr7, %a, f13\n" freg r2; + fprintf oc " cror 30, 29, 30\n"; + fprintf oc " beq cr7, L%d\n" lbl2; + fprintf oc " fctiwz f13, %a\n" freg r2; + fprintf oc " stfdu f13, -8(r1)\n"; + fprintf oc " lwz %a, 4(r1)\n" ireg r1; + fprintf oc " b L%d\n" lbl3; + fprintf oc "L%d: fsub f13, %a, f13\n" lbl2 freg r2; + fprintf oc " fctiwz f13, f13\n"; + fprintf oc " stfdu f13, -8(r1)\n"; + fprintf oc " lwz %a, 4(r1)\n" ireg r1; + fprintf oc " addis %a, %a, 0x8000\n" ireg r1 ireg r1; + fprintf oc "L%d: addi r1, r1, 8\n" lbl3; + fprintf oc " .const_data\n"; + fprintf oc "L%d: .long 0x41e00000, 0x00000000\n" lbl1; + fprintf oc " .text\n" + | Pfdiv(r1, r2, r3) -> + fprintf oc " fdiv %a, %a, %a\n" freg r1 freg r2 freg r3 + | Pfmadd(r1, r2, r3, r4) -> + fprintf oc " fmadd %a, %a, %a, %a\n" freg r1 freg r2 freg r3 freg r4 + | Pfmr(r1, r2) -> + fprintf oc " fmr %a, %a\n" freg r1 freg r2 + | Pfmsub(r1, r2, r3, r4) -> + fprintf oc " fmsub %a, %a, %a, %a\n" freg r1 freg r2 freg r3 freg r4 + | Pfmul(r1, r2, r3) -> + fprintf oc " fmul %a, %a, %a\n" freg r1 freg r2 freg r3 + | Pfneg(r1, r2) -> + fprintf oc " fneg %a, %a\n" freg r1 freg r2 + | Pfrsp(r1, r2) -> + fprintf oc " frsp %a, %a\n" freg r1 freg r2 + | Pfsub(r1, r2, r3) -> + fprintf oc " fsub %a, %a, %a\n" freg r1 freg r2 freg r3 + | Pictf(r1, r2) -> + let lbl = new_label() in + fprintf oc " addis r12, 0, 0x4330\n"; + fprintf oc " stw r12, -8(r1)\n"; + fprintf oc " addis r12, %a, 0x8000\n" ireg r2; + fprintf oc " stw r12, -4(r1)\n"; + fprintf oc " addis r12, 0, ha16(L%d)\n" lbl; + fprintf oc " lfd f13, lo16(L%d)(r12)\n" lbl; + fprintf oc " lfd %a, -8(r1)\n" freg r1; + fprintf oc " fsub %a, %a, f13\n" freg r1 freg r1; + fprintf oc " .const_data\n"; + fprintf oc "L%d: .long 0x43300000, 0x80000000\n" lbl; + fprintf oc " .text\n" + | Piuctf(r1, r2) -> + let lbl = new_label() in + fprintf oc " addis r12, 0, 0x4330\n"; + fprintf oc " stw r12, -8(r1)\n"; + fprintf oc " stw %a, -4(r1)\n" ireg r2; + fprintf oc " addis r12, 0, ha16(L%d)\n" lbl; + fprintf oc " lfd f13, lo16(L%d)(r12)\n" lbl; + fprintf oc " lfd %a, -8(r1)\n" freg r1; + fprintf oc " fsub %a, %a, f13\n" freg r1 freg r1; + fprintf oc " .const_data\n"; + fprintf oc "L%d: .long 0x43300000, 0x00000000\n" lbl; + fprintf oc " .text\n" + | Plbz(r1, c, r2) -> + fprintf oc " lbz %a, %a(%a)\n" ireg r1 print_constant c ireg r2 + | Plbzx(r1, r2, r3) -> + fprintf oc " lbzx %a, %a, %a\n" ireg r1 ireg r2 ireg r3 + | Plfd(r1, c, r2) -> + fprintf oc " lfd %a, %a(%a)\n" freg r1 print_constant c ireg r2 + | Plfdx(r1, r2, r3) -> + fprintf oc " lfdx %a, %a, %a\n" freg r1 ireg r2 ireg r3 + | Plfi(r1, c) -> + let lbl = new_label() in + fprintf oc " addis r12, 0, ha16(L%d)\n" lbl; + fprintf oc " lfd %a, lo16(L%d)(r12)\n" freg r1 lbl; + fprintf oc " .const_data\n"; + let n = Int64.bits_of_float c in + let nlo = Int64.to_int32 n + and nhi = Int64.to_int32(Int64.shift_right_logical n 32) in + fprintf oc "L%d: .long 0x%lx, 0x%lx ; %f\n" lbl nhi nlo c; + fprintf oc " .text\n" + | Plfs(r1, c, r2) -> + fprintf oc " lfs %a, %a(%a)\n" freg r1 print_constant c ireg r2 + | Plfsx(r1, r2, r3) -> + fprintf oc " lfsx %a, %a, %a\n" freg r1 ireg r2 ireg r3 + | Plha(r1, c, r2) -> + fprintf oc " lha %a, %a(%a)\n" ireg r1 print_constant c ireg r2 + | Plhax(r1, r2, r3) -> + fprintf oc " lhax %a, %a, %a\n" ireg r1 ireg r2 ireg r3 + | Plhz(r1, c, r2) -> + fprintf oc " lhz %a, %a(%a)\n" ireg r1 print_constant c ireg r2 + | Plhzx(r1, r2, r3) -> + fprintf oc " lhzx %a, %a, %a\n" ireg r1 ireg r2 ireg r3 + | Plwz(r1, c, r2) -> + fprintf oc " lwz %a, %a(%a)\n" ireg r1 print_constant c ireg r2 + | Plwzx(r1, r2, r3) -> + fprintf oc " lwzx %a, %a, %a\n" ireg r1 ireg r2 ireg r3 + | Pmfcrbit(r1, bit) -> + fprintf oc " mfcr r2\n"; + fprintf oc " rlwinm %a, r2, %d, 1\n" ireg r1 (1 + num_crbit bit) + | Pmflr(r1) -> + fprintf oc " mflr %a\n" ireg r1 + | Pmr(r1, r2) -> + fprintf oc " mr %a, %a\n" ireg r1 ireg r2 + | Pmtctr(r1) -> + fprintf oc " mtctr %a\n" ireg r1 + | Pmtlr(r1) -> + fprintf oc " mtlr %a\n" ireg r1 + | Pmulli(r1, r2, c) -> + fprintf oc " mulli %a, %a, %a\n" ireg r1 ireg r2 print_constant c + | Pmullw(r1, r2, r3) -> + fprintf oc " mullw %a, %a, %a\n" ireg r1 ireg r2 ireg r3 + | Pnand(r1, r2, r3) -> + fprintf oc " nand %a, %a, %a\n" ireg r1 ireg r2 ireg r3 + | Pnor(r1, r2, r3) -> + fprintf oc " nor %a, %a, %a\n" ireg r1 ireg r2 ireg r3 + | Por(r1, r2, r3) -> + fprintf oc " or %a, %a, %a\n" ireg r1 ireg r2 ireg r3 + | Porc(r1, r2, r3) -> + fprintf oc " orc %a, %a, %a\n" ireg r1 ireg r2 ireg r3 + | Pori(r1, r2, c) -> + fprintf oc " ori %a, %a, %a\n" ireg r1 ireg r2 print_constant c + | Poris(r1, r2, c) -> + fprintf oc " oris %a, %a, %a\n" ireg r1 ireg r2 print_constant c + | Prlwinm(r1, r2, c1, c2) -> + fprintf oc " rlwinm %a, %a, %ld, 0x%lx\n" + ireg r1 ireg r2 (camlint_of_coqint c1) (camlint_of_coqint c2) + | Pslw(r1, r2, r3) -> + fprintf oc " slw %a, %a, %a\n" ireg r1 ireg r2 ireg r3 + | Psraw(r1, r2, r3) -> + fprintf oc " sraw %a, %a, %a\n" ireg r1 ireg r2 ireg r3 + | Psrawi(r1, r2, c) -> + fprintf oc " srawi %a, %a, %ld\n" ireg r1 ireg r2 (camlint_of_coqint c) + | Psrw(r1, r2, r3) -> + fprintf oc " srw %a, %a, %a\n" ireg r1 ireg r2 ireg r3 + | Pstb(r1, c, r2) -> + fprintf oc " stb %a, %a(%a)\n" ireg r1 print_constant c ireg r2 + | Pstbx(r1, r2, r3) -> + fprintf oc " stbx %a, %a, %a\n" ireg r1 ireg r2 ireg r3 + | Pstfd(r1, c, r2) -> + fprintf oc " stfd %a, %a(%a)\n" freg r1 print_constant c ireg r2 + | Pstfdx(r1, r2, r3) -> + fprintf oc " stfdx %a, %a, %a\n" freg r1 ireg r2 ireg r3 + | Pstfs(r1, c, r2) -> + fprintf oc " stfs %a, %a(%a)\n" freg r1 print_constant c ireg r2 + | Pstfsx(r1, r2, r3) -> + fprintf oc " stfsx %a, %a, %a\n" freg r1 ireg r2 ireg r3 + | Psth(r1, c, r2) -> + fprintf oc " sth %a, %a(%a)\n" ireg r1 print_constant c ireg r2 + | Psthx(r1, r2, r3) -> + fprintf oc " sthx %a, %a, %a\n" ireg r1 ireg r2 ireg r3 + | Pstw(r1, c, r2) -> + fprintf oc " stw %a, %a(%a)\n" ireg r1 print_constant c ireg r2 + | Pstwx(r1, r2, r3) -> + fprintf oc " stwx %a, %a, %a\n" ireg r1 ireg r2 ireg r3 + | Psubfc(r1, r2, r3) -> + fprintf oc " subfc %a, %a, %a\n" ireg r1 ireg r2 ireg r3 + | Psubfic(r1, r2, c) -> + fprintf oc " subfic %a, %a, %a\n" ireg r1 ireg r2 print_constant c + | Pxor(r1, r2, r3) -> + fprintf oc " xor %a, %a, %a\n" ireg r1 ireg r2 ireg r3 + | Pxori(r1, r2, c) -> + fprintf oc " xori %a, %a, %a\n" ireg r1 ireg r2 print_constant c + | Pxoris(r1, r2, c) -> + 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 + +let rec labels_of_code = function + | [] -> Labelset.empty + | (Pb lbl | Pbf(_, lbl) | Pbt(_, lbl)) :: c -> + Labelset.add lbl (labels_of_code c) + | _ :: c -> labels_of_code c + +let print_function oc name code = + Hashtbl.clear current_function_labels; + fprintf oc " .text\n"; + fprintf oc " .align 2\n"; + fprintf oc " .globl %a\n" print_symb name; + fprintf oc "%a:\n" print_symb name; + List.iter (print_instruction oc (labels_of_code code)) code + +(* Generation of stub code for variadic functions, e.g. printf. + Calling conventions for variadic functions are: + - always reserve 8 stack words (offsets 24 to 52) so that the + variadic function can save there the integer registers parameters + r3 ... r10 + - treat float arguments as pairs of integers, i.e. if we + must pass them in registers, use a pair of integer registers + for this purpose. + The code we generate is: + - allocate large enough stack frame + - save return address + - copy our arguments (registers and stack) to the stack frame, + starting at offset 24 + - load relevant integer parameter registers r3...r10 from the + stack frame, limited by the actual number of arguments + - call the variadic thing + - deallocate stack frame and return +*) + +let variadic_stub oc stub_name fun_name ty_args = + (* Compute total size of arguments *) + let arg_size = + CList.fold_left + (fun sz ty -> match ty with Tint -> sz + 4 | Tfloat -> sz + 8) + ty_args 0 in + (* Stack size is linkage area + argument size, with a minimum of 56 bytes *) + let frame_size = max 56 (24 + arg_size) in + fprintf oc " mflr r0\n"; + fprintf oc " stwu r1, %d(r1)\n" (-frame_size); + fprintf oc " stw r0, %d(r1)\n" (frame_size + 4); + (* Copy our parameters to our stack frame. + As an optimization, don't copy parameters that are already in + integer registers, since these stay in place. *) + let rec copy gpr fpr src_ofs dst_ofs = function + | [] -> () + | Tint :: rem -> + if gpr > 10 then begin + fprintf oc " lwz r0, %d(r1)\n" src_ofs; + fprintf oc " stw r0, %d(r1)\n" dst_ofs + end; + copy (gpr + 1) fpr (src_ofs + 4) (dst_ofs + 4) rem + | Tfloat :: rem -> + if fpr <= 10 then begin + fprintf oc " stfd f%d, %d(r1)\n" fpr dst_ofs + end else begin + fprintf oc " lfd f0, %d(r1)\n" src_ofs; + fprintf oc " stfd f0, %d(r1)\n" dst_ofs + end; + copy (gpr + 2) (fpr + 1) (src_ofs + 8) (dst_ofs + 8) rem + in copy 3 1 (frame_size + 24) 24 ty_args; + (* Load the first parameters into integer registers. + As an optimization, don't load parameters that are already + in the correct integer registers. *) + let rec load gpr ofs = function + | [] -> () + | Tint :: rem -> + load (gpr + 1) (ofs + 4) rem + | Tfloat :: rem -> + if gpr <= 10 then + fprintf oc " lwz r%d, %d(r1)\n" gpr ofs; + if gpr + 1 <= 10 then + fprintf oc " lwz r%d, %d(r1)\n" (gpr + 1) (ofs + 4); + load (gpr + 2) (ofs + 8) rem + in load 3 24 ty_args; + (* Call the function *) + fprintf oc " addis r11, 0, ha16(L%s$ptr)\n" stub_name; + fprintf oc " lwz r11, lo16(L%s$ptr)(r11)\n" stub_name; + fprintf oc " mtctr r11\n"; + fprintf oc " bctrl\n"; + (* Free our frame and return *) + fprintf oc " lwz r0, %d(r1)\n" (frame_size + 4); + fprintf oc " mtlr r0\n"; + fprintf oc " addi r1, r1, %d\n" frame_size; + fprintf oc " blr\n"; + (* The function pointer *) + fprintf oc " .non_lazy_symbol_pointer\n"; + fprintf oc "L%s$ptr:\n" stub_name; + fprintf oc " .indirect_symbol _%s\n" fun_name; + fprintf oc " .long 0\n" + +(* Stubs for fixed-type functions are much simpler *) + +let non_variadic_stub oc name = + fprintf oc " addis r11, 0, ha16(L%s$ptr)\n" name; + fprintf oc " lwz r11, lo16(L%s$ptr)(r11)\n" name; + fprintf oc " mtctr r11\n"; + fprintf oc " bctr\n"; + fprintf oc " .non_lazy_symbol_pointer\n"; + fprintf oc "L%s$ptr:\n" name; + fprintf oc " .indirect_symbol _%s\n" name; + fprintf oc " .long 0\n" + +let re_variadic_stub = Str.regexp "\\(.*\\)\\$[if]*$" + +let print_external_function oc name ef = + let name = extern_atom name in + fprintf oc " .text\n"; + fprintf oc " .align 2\n"; + fprintf oc "L%s$stub:\n" name; + if Str.string_match re_variadic_stub name 0 + then variadic_stub oc name (Str.matched_group 1 name) ef.ef_sig.sig_args + else non_variadic_stub oc name + +let print_fundef oc (Coq_pair(name, defn)) = + match defn with + | Internal code -> print_function oc name code + | External ef -> print_external_function oc name ef + +let init_data_queue = ref [] + +let print_init oc = function + | Init_int8 n -> + fprintf oc " .byte %ld\n" (camlint_of_coqint n) + | Init_int16 n -> + fprintf oc " .short %ld\n" (camlint_of_coqint n) + | Init_int32 n -> + fprintf oc " .long %ld\n" (camlint_of_coqint n) + | Init_float32 n -> + fprintf oc " .long %ld ; %g \n" (Int32.bits_of_float n) n + | Init_float64 n -> + (* .quad not working on all versions of the MacOSX assembler *) + let b = Int64.bits_of_float n in + fprintf oc " .long %Ld, %Ld ; %g \n" + (Int64.shift_right_logical b 32) + (Int64.logand b 0xFFFFFFFFL) + n + | Init_space n -> + let n = camlint_of_z n in + if n > 0l then fprintf oc " .space %ld\n" n + | Init_pointer id -> + let lbl = new_label() in + fprintf oc " .long L%d\n" lbl; + init_data_queue := (lbl, id) :: !init_data_queue + +let print_init_data oc id = + init_data_queue := []; + List.iter (print_init oc) id; + let rec print_remainder () = + match !init_data_queue with + | [] -> () + | (lbl, id) :: rem -> + init_data_queue := rem; + fprintf oc "L%d:\n" lbl; + List.iter (print_init oc) id; + print_remainder() + in print_remainder() + +let print_var oc (Coq_pair(Coq_pair(name, init_data), _)) = + match init_data with + | [] -> () + | _ -> + fprintf oc " .data\n"; + fprintf oc " .align 3\n"; + fprintf oc " .globl %a\n" print_symb name; + fprintf oc "%a:\n" print_symb name; + print_init_data oc init_data + +let print_program oc p = + extfuns := IdentSet.empty; + List.iter record_extfun p.prog_funct; + List.iter (print_var oc) p.prog_vars; + List.iter (print_fundef oc) p.prog_funct + diff --git a/powerpc/PrintAsm.mli b/powerpc/PrintAsm.mli new file mode 100644 index 0000000..aefe3a0 --- /dev/null +++ b/powerpc/PrintAsm.mli @@ -0,0 +1,13 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +val print_program: out_channel -> Asm.program -> unit diff --git a/powerpc/Selection.v b/powerpc/Selection.v new file mode 100644 index 0000000..1de6ae3 --- /dev/null +++ b/powerpc/Selection.v @@ -0,0 +1,1196 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** 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) + | 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 + 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 *) + +Parameter use_fused_mul : unit -> bool. + +(* +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) := + if use_fused_mul tt then + match addf_match e1 e2 with + | addf_case1 t1 t2 t3 => + Eop Omuladdf (t1:::t2:::t3:::Enil) + | addf_case2 t1 t2 t3 => + Eop Omuladdf (t2:::t3:::t1:::Enil) + | addf_default e1 e2 => + Eop Oaddf (e1:::e2:::Enil) + end + else Eop Oaddf (e1:::e2:::Enil). + +(* +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) := + if use_fused_mul tt then + 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 + else Eop Osubf (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 *) + +Inductive comp_cases: forall (e1: expr) (e2: expr), Set := + | comp_case1: + forall n1 t2, + comp_cases (Eop (Ointconst n1) Enil) (t2) + | comp_case2: + forall t1 n2, + comp_cases (t1) (Eop (Ointconst n2) Enil) + | comp_default: + forall (e1: expr) (e2: expr), + comp_cases e1 e2. + +Definition comp_match (e1: expr) (e2: expr) := + match e1 as z1, e2 as z2 return comp_cases z1 z2 with + | Eop (Ointconst n1) Enil, t2 => + comp_case1 n1 t2 + | t1, Eop (Ointconst n2) Enil => + comp_case2 t1 n2 + | e1, e2 => + comp_default e1 e2 + end. + +Definition comp (c: comparison) (e1: expr) (e2: expr) := + match comp_match e1 e2 with + | comp_case1 n1 t2 => + Eop (Ocmp (Ccompimm (swap_comparison c) n1)) (t2 ::: Enil) + | comp_case2 t1 n2 => + Eop (Ocmp (Ccompimm c n2)) (t1 ::: Enil) + | comp_default e1 e2 => + Eop (Ocmp (Ccomp c)) (e1 ::: e2 ::: Enil) + end. + +Definition compu (c: comparison) (e1: expr) (e2: expr) := + match comp_match e1 e2 with + | comp_case1 n1 t2 => + Eop (Ocmp (Ccompuimm (swap_comparison c) n1)) (t2 ::: Enil) + | comp_case2 t1 n2 => + Eop (Ocmp (Ccompuimm c n2)) (t1 ::: Enil) + | comp_default e1 e2 => + Eop (Ocmp (Ccompu c)) (e1 ::: e2 ::: Enil) + end. + +Definition compf (c: comparison) (e1: expr) (e2: expr) := + Eop (Ocmp (Ccompf c)) (e1 ::: e2 ::: Enil). + +(** ** Conditional expressions *) + +Fixpoint negate_condexpr (e: condexpr): condexpr := + match e with + | CEtrue => CEfalse + | CEfalse => CEtrue + | CEcond c el => CEcond (negate_condition c) el + | CEcondition e1 e2 e3 => + CEcondition e1 (negate_condexpr e2) (negate_condexpr e3) + end. + + +Definition is_compare_neq_zero (c: condition) : bool := + match c with + | Ccompimm Cne n => Int.eq n Int.zero + | Ccompuimm Cne n => Int.eq n Int.zero + | _ => false + end. + +Definition is_compare_eq_zero (c: condition) : bool := + match c with + | Ccompimm Ceq n => Int.eq n Int.zero + | Ccompuimm Ceq n => Int.eq n Int.zero + | _ => false + end. + +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) (e1 ::: Enil) => + if is_compare_neq_zero c then + condexpr_of_expr e1 + else if is_compare_eq_zero c then + negate_condexpr (condexpr_of_expr e1) + else + CEcond c (e1 ::: Enil) + | Eop (Ocmp c) el => + CEcond c el + | Econdition ce e1 e2 => + CEcondition ce (condexpr_of_expr e1) (condexpr_of_expr e2) + | _ => + 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) => Sstore 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.Ointuoffloat => Eop Ointuoffloat (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 => comp c arg1 arg2 + | Cminor.Ocmpu c => compu c arg1 arg2 + | Cminor.Ocmpf c => compf c arg1 arg2 + 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.Econdition cond ifso ifnot => + Econdition (condexpr_of_expr (sel_expr cond)) + (sel_expr ifso) (sel_expr ifnot) + end. + +Fixpoint sel_exprlist (al: list Cminor.expr) : exprlist := + match al with + | nil => Enil + | 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.Sassign id e => Sassign id (sel_expr e) + | Cminor.Sstore chunk addr rhs => store chunk (sel_expr addr) (sel_expr rhs) + | Cminor.Scall optid sg fn args => + Scall optid sg (sel_expr fn) (sel_exprlist args) + | Cminor.Stailcall sg fn args => + Stailcall sg (sel_expr fn) (sel_exprlist args) + | Cminor.Salloc id b => Salloc id (sel_expr b) + | 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.Slabel lbl body => Slabel lbl (sel_stmt body) + | Cminor.Sgoto lbl => Sgoto lbl + 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/powerpc/Selectionproof.v b/powerpc/Selectionproof.v new file mode 100644 index 0000000..6d62979 --- /dev/null +++ b/powerpc/Selectionproof.v @@ -0,0 +1,1398 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** 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 Smallstep. +Require Import Cminor. +Require Import Op. +Require Import CminorSel. +Require Import Selection. + +Open Local Scope selection_scope. + +Section CMCONSTR. + +Variable ge: genv. +Variable sp: val. +Variable e: env. +Variable m: mem. + +(** * 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. + +Hint Resolve eval_Evar eval_Eop eval_Eload eval_Econdition + eval_Elet eval_Eletvar + eval_CEtrue eval_CEfalse eval_CEcond + eval_CEcondition eval_Enil eval_Econs: evalexpr. + +Lemma eval_lift_expr: + forall w le a v, + eval_expr ge sp e m le a v -> + forall p le', insert_lenv le p w le' -> + eval_expr ge sp e m le' (lift_expr p a) v. +Proof. + intro w. + apply (eval_expr_ind3 ge sp e m + (fun le a v => + forall p le', insert_lenv le p w le' -> + eval_expr ge sp e m le' (lift_expr p a) v) + (fun le a v => + forall p le', insert_lenv le p w le' -> + eval_condexpr ge sp e m le' (lift_condexpr p a) v) + (fun le al vl => + forall p le', insert_lenv le p w le' -> + eval_exprlist ge sp e m le' (lift_exprlist p al) 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. + + 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 le a v w, + eval_expr ge sp e m le a v -> + eval_expr ge sp e m (w::le) (lift a) 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. + +Ltac InvEval1 := + match goal with + | [ H: (eval_expr _ _ _ _ _ (Eop _ Enil) _) |- _ ] => + inv H; InvEval1 + | [ H: (eval_expr _ _ _ _ _ (Eop _ (_ ::: Enil)) _) |- _ ] => + inv H; InvEval1 + | [ H: (eval_expr _ _ _ _ _ (Eop _ (_ ::: _ ::: Enil)) _) |- _ ] => + inv H; InvEval1 + | [ H: (eval_exprlist _ _ _ _ _ Enil _) |- _ ] => + inv H; InvEval1 + | [ H: (eval_exprlist _ _ _ _ _ (_ ::: _) _) |- _ ] => + inv H; InvEval1 + | _ => + idtac + end. + +Ltac InvEval2 := + match goal with + | [ H: (eval_operation _ _ _ nil _ = Some _) |- _ ] => + simpl in H; inv H + | [ H: (eval_operation _ _ _ (_ :: nil) _ = Some _) |- _ ] => + simpl in H; FuncInv + | [ H: (eval_operation _ _ _ (_ :: _ :: nil) _ = Some _) |- _ ] => + simpl in H; FuncInv + | [ H: (eval_operation _ _ _ (_ :: _ :: _ :: nil) _ = Some _) |- _ ] => + simpl in H; FuncInv + | _ => + idtac + end. + +Ltac InvEval := InvEval1; InvEval2; InvEval2. + +(** * 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. +*) + +Theorem eval_notint: + forall le a x, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le (notint a) (Vint (Int.not x)). +Proof. + unfold notint; intros until x; case (notint_match a); intros; InvEval. + EvalOp. simpl. congruence. + EvalOp. simpl. congruence. + 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. + simpl. rewrite Int.or_idem. auto. +Qed. + +Lemma eval_notbool_base: + forall le a v b, + eval_expr ge sp e m le a v -> + Val.bool_of_val v b -> + eval_expr ge sp e m le (notbool_base a) (Val.of_bool (negb b)). +Proof. + TrivialOp notbool_base. simpl. + inv 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 le a v b, + eval_expr ge sp e m le a v -> + Val.bool_of_val v b -> + eval_expr ge sp e m le (notbool a) (Val.of_bool (negb b)). +Proof. + induction a; simpl; intros; try (eapply eval_notbool_base; eauto). + destruct o; try (eapply eval_notbool_base; eauto). + + destruct e0. InvEval. + inv H0. rewrite Int.eq_false; auto. + simpl; eauto with evalexpr. + rewrite Int.eq_true; simpl; eauto with evalexpr. + eapply eval_notbool_base; eauto. + + inv H. eapply eval_Eop; eauto. + simpl. assert (eval_condition c vl m = Some b). + generalize H6. simpl. + case (eval_condition c vl m); intros. + destruct b0; inv H1; inversion H0; auto; congruence. + congruence. + rewrite (Op.eval_negate_condition _ _ _ H). + destruct b; reflexivity. + + inv H. eapply eval_Econdition; eauto. + destruct v1; eauto. +Qed. + +Theorem eval_addimm: + forall le n a x, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le (addimm n a) (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; EvalOp; simpl. + rewrite Int.add_commut. auto. + destruct (Genv.find_symbol ge s); discriminate. + destruct sp; simpl in H1; discriminate. + subst x. rewrite Int.add_assoc. decEq; decEq; decEq. apply Int.add_commut. +Qed. + +Theorem eval_addimm_ptr: + forall le n a b ofs, + eval_expr ge sp e m le a (Vptr b ofs) -> + eval_expr ge sp e m le (addimm n a) (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; EvalOp; simpl. + destruct (Genv.find_symbol ge s). + rewrite Int.add_commut. congruence. + discriminate. + destruct sp; simpl in H1; try discriminate. + inv H1. simpl. decEq. decEq. + rewrite Int.add_assoc. decEq. apply Int.add_commut. + subst. rewrite (Int.add_commut n m0). rewrite Int.add_assoc. auto. +Qed. + +Theorem eval_add: + forall le a b x y, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le b (Vint y) -> + eval_expr ge sp e m le (add a b) (Vint (Int.add x y)). +Proof. + intros until y. + unfold add; case (add_match a b); intros; InvEval. + rewrite Int.add_commut. apply eval_addimm. auto. + replace (Int.add x y) with (Int.add (Int.add i0 i) (Int.add n1 n2)). + apply eval_addimm. EvalOp. + subst x; subst y. + repeat rewrite Int.add_assoc. decEq. apply Int.add_permut. + 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. + apply eval_addimm. auto. + 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 le a b p x y, + eval_expr ge sp e m le a (Vptr p x) -> + eval_expr ge sp e m le b (Vint y) -> + eval_expr ge sp e m le (add a b) (Vptr p (Int.add x y)). +Proof. + intros until y. unfold add; case (add_match a b); intros; InvEval. + replace (Int.add x y) 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. apply Int.add_permut. + 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. + apply eval_addimm_ptr. auto. + 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 le a b x p y, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le b (Vptr p y) -> + eval_expr ge sp e m le (add a b) (Vptr p (Int.add y x)). +Proof. + intros until y. unfold add; case (add_match a b); intros; InvEval. + apply eval_addimm_ptr. auto. + replace (Int.add y x) 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. + rewrite (Int.add_commut n1 n2). apply Int.add_permut. + 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. + 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 le a b x y, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le b (Vint y) -> + eval_expr ge sp e m le (sub a b) (Vint (Int.sub x y)). +Proof. + intros until y. + unfold sub; case (sub_match a b); intros; InvEval. + rewrite Int.sub_add_opp. + apply eval_addimm. assumption. + replace (Int.sub x y) with (Int.add (Int.sub i0 i) (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. + 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. + 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 le a b p x y, + eval_expr ge sp e m le a (Vptr p x) -> + eval_expr ge sp e m le b (Vint y) -> + eval_expr ge sp e m le (sub a b) (Vptr p (Int.sub x y)). +Proof. + intros until y. + unfold sub; case (sub_match a b); intros; InvEval. + rewrite Int.sub_add_opp. + apply eval_addimm_ptr. assumption. + subst b0. replace (Int.sub x y) with (Int.add (Int.sub i0 i) (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. + 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. + 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 le a b p x y, + eval_expr ge sp e m le a (Vptr p x) -> + eval_expr ge sp e m le b (Vptr p y) -> + eval_expr ge sp e m le (sub a b) (Vint (Int.sub x y)). +Proof. + intros until y. + unfold sub; case (sub_match a b); intros; InvEval. + replace (Int.sub x y) with (Int.add (Int.sub i0 i) (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. + 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. + 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 le a amount mask x, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le (rolm a amount mask) (Vint (Int.rolm x amount mask)). +Proof. + intros until x. unfold rolm; case (rolm_match a); intros; InvEval. + eauto with evalexpr. + case (Int.is_rlw_mask (Int.and (Int.rol mask1 amount) mask)). + 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. econstructor. EvalOp. simpl. rewrite H. reflexivity. constructor. auto. + EvalOp. +Qed. + +Theorem eval_shlimm: + forall le a n x, + eval_expr ge sp e m le a (Vint x) -> + Int.ltu n (Int.repr 32) = true -> + eval_expr ge sp e m le (shlimm a n) (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 le a n x, + eval_expr ge sp e m le a (Vint x) -> + Int.ltu n (Int.repr 32) = true -> + eval_expr ge sp e m le (shruimm a n) (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 le a n x, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le (mulimm_base n a) (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 (Vint x). 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. + intros. EvalOp. +Qed. + +Theorem eval_mulimm: + forall le a n x, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le (mulimm n a) (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. + 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. + EvalOp. rewrite Int.mul_commut. reflexivity. + 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 le a b x y, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le b (Vint y) -> + eval_expr ge sp e m le (mul a b) (Vint (Int.mul x y)). +Proof. + intros until y. + unfold mul; case (mul_match a b); intros; InvEval. + rewrite Int.mul_commut. apply eval_mulimm. auto. + apply eval_mulimm. auto. + EvalOp. +Qed. + +Theorem eval_divs: + forall le a b x y, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le b (Vint y) -> + y <> Int.zero -> + eval_expr ge sp e m le (divs a b) (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 le a b x y, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le b (Vint y) -> + y <> Int.zero -> + eval_expr ge sp e m le (mod_aux divop a b) + (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. + apply H. assumption. + eapply eval_Econs. apply eval_Eletvar. simpl; reflexivity. + apply eval_Enil. + simpl; reflexivity. apply eval_Enil. + reflexivity. +Qed. + +Theorem eval_mods: + forall le a b x y, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le b (Vint y) -> + y <> Int.zero -> + eval_expr ge sp e m le (mods a b) (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 le a x b y, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le b (Vint y) -> + y <> Int.zero -> + eval_expr ge sp e m le (Eop Odivu (a ::: b ::: Enil)) (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 le a x b y, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le b (Vint y) -> + y <> Int.zero -> + eval_expr ge sp e m le (divu a b) (Vint (Int.divu x y)). +Proof. + intros until y. + unfold divu; case (divu_match b); intros; InvEval. + caseEq (Int.is_power2 y). + intros. rewrite (Int.divu_pow2 x y i H0). + apply eval_shruimm. auto. + apply Int.is_power2_range with y. auto. + intros. apply eval_divu_base. auto. EvalOp. auto. + eapply eval_divu_base; eauto. +Qed. + +Theorem eval_modu: + forall le a x b y, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le b (Vint y) -> + y <> Int.zero -> + eval_expr ge sp e m le (modu a b) (Vint (Int.modu x y)). +Proof. + intros until y; unfold modu; case (divu_match b); intros; InvEval. + caseEq (Int.is_power2 y). + intros. rewrite (Int.modu_and x y i H0). + rewrite <- Int.rolm_zero. apply eval_rolm. auto. + intro. rewrite Int.modu_divu. eapply eval_mod_aux. + intros. simpl. predSpec Int.eq Int.eq_spec y0 Int.zero. + contradiction. auto. + auto. EvalOp. auto. auto. + rewrite Int.modu_divu. eapply eval_mod_aux. + intros. simpl. predSpec Int.eq Int.eq_spec y0 Int.zero. + contradiction. auto. auto. auto. auto. auto. +Qed. + +Theorem eval_andimm: + forall le n a x, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le (andimm n a) (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 le a x b y, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le b (Vint y) -> + eval_expr ge sp e m le (and a b) (Vint (Int.and x y)). +Proof. + intros until y; unfold and; case (mul_match a b); intros; InvEval. + rewrite Int.and_commut. apply eval_andimm; auto. + apply eval_andimm; auto. + EvalOp. +Qed. + +Remark eval_same_expr: + forall a1 a2 le v1 v2, + same_expr_pure a1 a2 = true -> + eval_expr ge sp e m le a1 v1 -> + eval_expr ge sp e m le a2 v2 -> + a1 = a2 /\ v1 = v2. +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. split. auto. congruence. + discriminate. +Qed. + +Lemma eval_or: + forall le a x b y, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le b (Vint y) -> + eval_expr ge sp e m le (or a b) (Vint (Int.or x y)). +Proof. + intros until y; unfold or; case (or_match a b); intros; InvEval. + caseEq (Int.eq amount1 amount2 + && Int.is_rlw_mask (Int.or mask1 mask2) + && same_expr_pure t1 t2); intro. + destruct (andb_prop _ _ H1). destruct (andb_prop _ _ H4). + generalize (Int.eq_spec amount1 amount2). rewrite H6. intro. subst amount2. + exploit eval_same_expr; eauto. intros [EQ1 EQ2]. inv EQ1. inv EQ2. + simpl. EvalOp. simpl. rewrite Int.or_rolm. auto. + simpl. apply eval_Eop with (Vint x :: Vint y :: nil). + econstructor. EvalOp. simpl. congruence. + econstructor. EvalOp. simpl. congruence. constructor. auto. + EvalOp. +Qed. + +Theorem eval_shl: + forall le a x b y, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le b (Vint y) -> + Int.ltu y (Int.repr 32) = true -> + eval_expr ge sp e m le (shl a b) (Vint (Int.shl x y)). +Proof. + intros until y; unfold shl; case (shift_match b); intros. + InvEval. apply eval_shlimm; auto. + EvalOp. simpl. rewrite H1. auto. +Qed. + +Theorem eval_shru: + forall le a x b y, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le b (Vint y) -> + Int.ltu y (Int.repr 32) = true -> + eval_expr ge sp e m le (shru a b) (Vint (Int.shru x y)). +Proof. + intros until y; unfold shru; case (shift_match b); intros. + InvEval. apply eval_shruimm; auto. + EvalOp. simpl. rewrite H1. auto. +Qed. + +Theorem eval_addf: + forall le a x b y, + eval_expr ge sp e m le a (Vfloat x) -> + eval_expr ge sp e m le b (Vfloat y) -> + eval_expr ge sp e m le (addf a b) (Vfloat (Float.add x y)). +Proof. + intros until y; unfold addf. + destruct (use_fused_mul tt). + case (addf_match a b); intros; InvEval. + EvalOp. simpl. congruence. + EvalOp. simpl. rewrite Float.addf_commut. congruence. + EvalOp. + intros. EvalOp. +Qed. + +Theorem eval_subf: + forall le a x b y, + eval_expr ge sp e m le a (Vfloat x) -> + eval_expr ge sp e m le b (Vfloat y) -> + eval_expr ge sp e m le (subf a b) (Vfloat (Float.sub x y)). +Proof. + intros until y; unfold subf. + destruct (use_fused_mul tt). + case (subf_match a b); intros. + InvEval. EvalOp. simpl. congruence. + EvalOp. + intros. EvalOp. +Qed. + +Theorem eval_cast8signed: + forall le a v, + eval_expr ge sp e m le a v -> + eval_expr ge sp e m le (cast8signed a) (Val.sign_ext 8 v). +Proof. + intros until v; unfold cast8signed; case (cast8signed_match a); intros; InvEval. + EvalOp. simpl. subst v. destruct v1; simpl; auto. + rewrite Int.sign_ext_idem. reflexivity. compute; auto. + EvalOp. +Qed. + +Theorem eval_cast8unsigned: + forall le a v, + eval_expr ge sp e m le a v -> + eval_expr ge sp e m le (cast8unsigned a) (Val.zero_ext 8 v). +Proof. + intros until v; unfold cast8unsigned; case (cast8unsigned_match a); intros; InvEval. + EvalOp. simpl. subst v. destruct v1; simpl; auto. + rewrite Int.zero_ext_idem. reflexivity. compute; auto. + EvalOp. +Qed. + +Theorem eval_cast16signed: + forall le a v, + eval_expr ge sp e m le a v -> + eval_expr ge sp e m le (cast16signed a) (Val.sign_ext 16 v). +Proof. + intros until v; unfold cast16signed; case (cast16signed_match a); intros; InvEval. + EvalOp. simpl. subst v. destruct v1; simpl; auto. + rewrite Int.sign_ext_idem. reflexivity. compute; auto. + EvalOp. +Qed. + +Theorem eval_cast16unsigned: + forall le a v, + eval_expr ge sp e m le a v -> + eval_expr ge sp e m le (cast16unsigned a) (Val.zero_ext 16 v). +Proof. + intros until v; unfold cast16unsigned; case (cast16unsigned_match a); intros; InvEval. + EvalOp. simpl. subst v. destruct v1; simpl; auto. + rewrite Int.zero_ext_idem. reflexivity. compute; auto. + EvalOp. +Qed. + +Theorem eval_singleoffloat: + forall le a v, + eval_expr ge sp e m le a v -> + eval_expr ge sp e m le (singleoffloat a) (Val.singleoffloat v). +Proof. + intros until v; unfold singleoffloat; case (singleoffloat_match a); intros; InvEval. + EvalOp. simpl. subst v. destruct v1; simpl; auto. rewrite Float.singleoffloat_idem. reflexivity. + EvalOp. +Qed. + +Theorem eval_comp_int: + forall le c a x b y, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le b (Vint y) -> + eval_expr ge sp e m le (comp c a b) (Val.of_bool(Int.cmp c x y)). +Proof. + intros until y. + unfold comp; case (comp_match a b); intros; InvEval. + EvalOp. simpl. rewrite Int.swap_cmp. destruct (Int.cmp c x y); reflexivity. + EvalOp. simpl. destruct (Int.cmp c x y); reflexivity. + EvalOp. simpl. destruct (Int.cmp c x y); reflexivity. +Qed. + +Theorem eval_comp_ptr_int: + forall le c a x1 x2 b y v, + eval_expr ge sp e m le a (Vptr x1 x2) -> + eval_expr ge sp e m le b (Vint y) -> + (if Int.eq y Int.zero then Cminor.eval_compare_mismatch c else None) = Some v -> + eval_expr ge sp e m le (comp c a b) v. +Proof. + intros until v. + unfold comp; case (comp_match a b); intros; InvEval. + EvalOp. simpl. destruct (Int.eq y Int.zero); try discriminate. + unfold Cminor.eval_compare_mismatch in H1. unfold eval_compare_mismatch. + destruct c; try discriminate; auto. + EvalOp. simpl. destruct (Int.eq y Int.zero); try discriminate. + unfold Cminor.eval_compare_mismatch in H1. unfold eval_compare_mismatch. + destruct c; try discriminate; auto. +Qed. + +Theorem eval_comp_int_ptr: + forall le c a x b y1 y2 v, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le b (Vptr y1 y2) -> + (if Int.eq x Int.zero then Cminor.eval_compare_mismatch c else None) = Some v -> + eval_expr ge sp e m le (comp c a b) v. +Proof. + intros until v. + unfold comp; case (comp_match a b); intros; InvEval. + EvalOp. simpl. destruct (Int.eq x Int.zero); try discriminate. + unfold Cminor.eval_compare_mismatch in H1. unfold eval_compare_mismatch. + destruct c; try discriminate; auto. + EvalOp. simpl. destruct (Int.eq x Int.zero); try discriminate. + unfold Cminor.eval_compare_mismatch in H1. unfold eval_compare_mismatch. + destruct c; try discriminate; auto. +Qed. + +Theorem eval_comp_ptr_ptr: + forall le c a x1 x2 b y1 y2, + eval_expr ge sp e m le a (Vptr x1 x2) -> + eval_expr ge sp e m le b (Vptr y1 y2) -> + valid_pointer m x1 (Int.signed x2) && + valid_pointer m y1 (Int.signed y2) = true -> + x1 = y1 -> + eval_expr ge sp e m le (comp c a b) (Val.of_bool(Int.cmp c x2 y2)). +Proof. + intros until y2. + unfold comp; case (comp_match a b); intros; InvEval. + EvalOp. simpl. rewrite H1. subst y1. rewrite dec_eq_true. + destruct (Int.cmp c x2 y2); reflexivity. +Qed. + +Theorem eval_comp_ptr_ptr_2: + forall le c a x1 x2 b y1 y2 v, + eval_expr ge sp e m le a (Vptr x1 x2) -> + eval_expr ge sp e m le b (Vptr y1 y2) -> + valid_pointer m x1 (Int.signed x2) && + valid_pointer m y1 (Int.signed y2) = true -> + x1 <> y1 -> + Cminor.eval_compare_mismatch c = Some v -> + eval_expr ge sp e m le (comp c a b) v. +Proof. + intros until y2. + unfold comp; case (comp_match a b); intros; InvEval. + EvalOp. simpl. rewrite H1. rewrite dec_eq_false; auto. + destruct c; simpl in H3; inv H3; auto. +Qed. + +Theorem eval_compu: + forall le c a x b y, + eval_expr ge sp e m le a (Vint x) -> + eval_expr ge sp e m le b (Vint y) -> + eval_expr ge sp e m le (compu c a b) (Val.of_bool(Int.cmpu c x y)). +Proof. + intros until y. + unfold compu; case (comp_match a b); intros; InvEval. + EvalOp. simpl. rewrite Int.swap_cmpu. destruct (Int.cmpu c x y); reflexivity. + EvalOp. simpl. destruct (Int.cmpu c x y); reflexivity. + EvalOp. simpl. destruct (Int.cmpu c x y); reflexivity. +Qed. + +Theorem eval_compf: + forall le c a x b y, + eval_expr ge sp e m le a (Vfloat x) -> + eval_expr ge sp e m le b (Vfloat y) -> + eval_expr ge sp e m le (compf c a b) (Val.of_bool(Float.cmp c x y)). +Proof. + intros. unfold compf. EvalOp. simpl. + destruct (Float.cmp c x y); reflexivity. +Qed. + +Lemma negate_condexpr_correct: + forall le a b, + eval_condexpr ge sp e m le a b -> + eval_condexpr ge sp e m le (negate_condexpr a) (negb b). +Proof. + induction 1; simpl. + constructor. + constructor. + econstructor. eauto. apply eval_negate_condition. auto. + econstructor. eauto. destruct vb1; auto. +Qed. + +Scheme expr_ind2 := Induction for expr Sort Prop + with exprlist_ind2 := Induction for exprlist Sort Prop. + +Fixpoint forall_exprlist (P: expr -> Prop) (el: exprlist) {struct el}: Prop := + match el with + | Enil => True + | Econs e el' => P e /\ forall_exprlist P el' + end. + +Lemma expr_induction_principle: + forall (P: expr -> Prop), + (forall i : ident, P (Evar i)) -> + (forall (o : operation) (e : exprlist), + forall_exprlist P e -> P (Eop o e)) -> + (forall (m : memory_chunk) (a : Op.addressing) (e : exprlist), + forall_exprlist P e -> P (Eload m a e)) -> + (forall (c : condexpr) (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. +Proof. + intros. apply expr_ind2 with (P := P) (P0 := forall_exprlist P); auto. + simpl. auto. + intros. simpl. auto. +Qed. + +Lemma eval_base_condition_of_expr: + forall le a v b, + eval_expr ge sp e m le a v -> + Val.bool_of_val v b -> + eval_condexpr ge sp e m le + (CEcond (Ccompimm Cne Int.zero) (a ::: Enil)) + b. +Proof. + intros. + eapply eval_CEcond. eauto with evalexpr. + inversion H0; simpl. rewrite Int.eq_false; auto. auto. auto. +Qed. + +Lemma is_compare_neq_zero_correct: + forall c v b, + is_compare_neq_zero c = true -> + eval_condition c (v :: nil) m = Some b -> + Val.bool_of_val v b. +Proof. + intros. + destruct c; simpl in H; try discriminate; + destruct c; simpl in H; try discriminate; + generalize (Int.eq_spec i Int.zero); rewrite H; intro; subst i. + + simpl in H0. destruct v; inv H0. + generalize (Int.eq_spec i Int.zero). destruct (Int.eq i Int.zero); intros; simpl. + subst i; constructor. constructor; auto. constructor. + + simpl in H0. destruct v; inv H0. + generalize (Int.eq_spec i Int.zero). destruct (Int.eq i Int.zero); intros; simpl. + subst i; constructor. constructor; auto. +Qed. + +Lemma is_compare_eq_zero_correct: + forall c v b, + is_compare_eq_zero c = true -> + eval_condition c (v :: nil) m = Some b -> + Val.bool_of_val v (negb b). +Proof. + intros. apply is_compare_neq_zero_correct with (negate_condition c). + destruct c; simpl in H; simpl; try discriminate; + destruct c; simpl; try discriminate; auto. + apply eval_negate_condition; auto. +Qed. + +Lemma eval_condition_of_expr: + forall a le v b, + eval_expr ge sp e m le a v -> + Val.bool_of_val v b -> + eval_condexpr ge sp e m le (condexpr_of_expr a) b. +Proof. + intro a0; pattern a0. + apply expr_induction_principle; simpl; intros; + try (eapply eval_base_condition_of_expr; eauto; fail). + + destruct o; try (eapply eval_base_condition_of_expr; eauto; fail). + + destruct e0. InvEval. + inversion H1. + rewrite Int.eq_false; auto. constructor. + subst i; rewrite Int.eq_true. constructor. + eapply eval_base_condition_of_expr; eauto. + + inv H0. simpl in H7. + assert (eval_condition c vl m = Some b). + destruct (eval_condition c vl m); try discriminate. + destruct b0; inv H7; inversion H1; congruence. + assert (eval_condexpr ge sp e m le (CEcond c e0) b). + eapply eval_CEcond; eauto. + destruct e0; auto. destruct e1; auto. + simpl in H. destruct H. + inv H5. inv H11. + + case_eq (is_compare_neq_zero c); intros. + eapply H; eauto. + apply is_compare_neq_zero_correct with c; auto. + + case_eq (is_compare_eq_zero c); intros. + replace b with (negb (negb b)). apply negate_condexpr_correct. + eapply H; eauto. + apply is_compare_eq_zero_correct with c; auto. + apply negb_involutive. + + auto. + + inv H1. destruct v1; eauto with evalexpr. +Qed. + +Lemma eval_addressing: + forall le a v b ofs, + eval_expr ge sp e m le a v -> + v = Vptr b ofs -> + match addressing a with (mode, args) => + exists vl, + eval_exprlist ge sp e m le args vl /\ + eval_addressing ge sp mode vl = Some v + end. +Proof. + intros until v. unfold addressing; case (addressing_match a); intros; InvEval. + exists (@nil val). split. eauto with evalexpr. simpl. auto. + exists (@nil val). split. eauto with evalexpr. simpl. auto. + destruct (Genv.find_symbol ge s); congruence. + exists (Vint i0 :: nil). split. eauto with evalexpr. + simpl. destruct (Genv.find_symbol ge s). congruence. discriminate. + exists (Vptr b0 i :: nil). split. eauto with evalexpr. + simpl. congruence. + exists (Vint i :: Vptr b0 i0 :: nil). + split. eauto with evalexpr. simpl. + 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 le a v chunk v', + eval_expr ge sp e m le a v -> + Mem.loadv chunk m v = Some v' -> + eval_expr ge sp e m le (load chunk a) 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 chunk a1 a2 v1 v2 f k m', + eval_expr ge sp e m nil a1 v1 -> + eval_expr ge sp e m nil a2 v2 -> + Mem.storev chunk m v1 v2 = Some m' -> + step ge (State f (store chunk a1 a2) k sp e m) + E0 (State f Sskip k sp e m'). +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 step_store; 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 le op a1 v1 v, + eval_expr ge sp e m le a1 v1 -> + eval_unop op v1 = Some v -> + eval_expr ge sp e m le (sel_unop op a1) 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. + EvalOp. +Qed. + +Lemma eval_sel_binop: + forall le op a1 a2 v1 v2 v, + eval_expr ge sp e m le a1 v1 -> + eval_expr ge sp e m le a2 v2 -> + eval_binop op v1 v2 m = Some v -> + eval_expr ge sp e m le (sel_binop op a1 a2) v. +Proof. + destruct op; simpl; intros; FuncInv; try subst v. + apply eval_add; auto. + apply eval_add_ptr_2; auto. + apply eval_add_ptr; auto. + apply eval_sub; auto. + apply eval_sub_ptr_int; auto. + destruct (eq_block b b0); inv H1. + eapply eval_sub_ptr_ptr; eauto. + apply eval_mul; eauto. + generalize (Int.eq_spec i0 Int.zero). destruct (Int.eq i0 Int.zero); inv H1. + apply eval_divs; eauto. + generalize (Int.eq_spec i0 Int.zero). destruct (Int.eq i0 Int.zero); inv H1. + apply eval_divu; eauto. + generalize (Int.eq_spec i0 Int.zero). destruct (Int.eq i0 Int.zero); inv H1. + apply eval_mods; eauto. + generalize (Int.eq_spec i0 Int.zero). destruct (Int.eq i0 Int.zero); inv H1. + apply eval_modu; eauto. + apply eval_and; auto. + apply eval_or; auto. + EvalOp. + caseEq (Int.ltu i0 (Int.repr 32)); intro; rewrite H2 in H1; inv H1. + apply eval_shl; auto. + EvalOp. + caseEq (Int.ltu i0 (Int.repr 32)); intro; rewrite H2 in H1; inv H1. + apply eval_shru; auto. + apply eval_addf; auto. + apply eval_subf; auto. + EvalOp. + EvalOp. + apply eval_comp_int; auto. + eapply eval_comp_int_ptr; eauto. + eapply eval_comp_ptr_int; eauto. + generalize H1; clear H1. + case_eq (valid_pointer m b (Int.signed i) && valid_pointer m b0 (Int.signed i0)); intros. + destruct (eq_block b b0); inv H2. + eapply eval_comp_ptr_ptr; eauto. + eapply eval_comp_ptr_ptr_2; eauto. + discriminate. + eapply eval_compu; eauto. + eapply eval_compf; eauto. +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. + +(** Semantic preservation for expressions. *) + +Lemma sel_expr_correct: + forall sp e m a v, + Cminor.eval_expr ge sp e m a v -> + forall le, + eval_expr tge sp e m le (sel_expr a) v. +Proof. + induction 1; 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 *) + eapply eval_sel_binop; eauto. + (* Eload *) + eapply eval_load; eauto. + (* Econdition *) + econstructor; eauto. eapply eval_condition_of_expr; eauto. + destruct b1; auto. +Qed. + +Hint Resolve sel_expr_correct: evalexpr. + +Lemma sel_exprlist_correct: + forall sp e m a v, + Cminor.eval_exprlist ge sp e m a v -> + forall le, + eval_exprlist tge sp e m le (sel_exprlist a) v. +Proof. + induction 1; intros; simpl; constructor; auto with evalexpr. +Qed. + +Hint Resolve sel_exprlist_correct: evalexpr. + +(** Semantic preservation for terminating function calls and statements. *) + +Fixpoint sel_cont (k: Cminor.cont) : CminorSel.cont := + match k with + | Cminor.Kstop => Kstop + | Cminor.Kseq s1 k1 => Kseq (sel_stmt s1) (sel_cont k1) + | Cminor.Kblock k1 => Kblock (sel_cont k1) + | Cminor.Kcall id f sp e k1 => + Kcall id (sel_function f) sp e (sel_cont k1) + end. + +Inductive match_states: Cminor.state -> CminorSel.state -> Prop := + | match_state: forall f s k s' k' sp e m, + s' = sel_stmt s -> + k' = sel_cont k -> + match_states + (Cminor.State f s k sp e m) + (State (sel_function f) s' k' sp e m) + | match_callstate: forall f args k k' m, + k' = sel_cont k -> + match_states + (Cminor.Callstate f args k m) + (Callstate (sel_fundef f) args k' m) + | match_returnstate: forall v k k' m, + k' = sel_cont k -> + match_states + (Cminor.Returnstate v k m) + (Returnstate v k' m). + +Remark call_cont_commut: + forall k, call_cont (sel_cont k) = sel_cont (Cminor.call_cont k). +Proof. + induction k; simpl; auto. +Qed. + +Remark find_label_commut: + forall lbl s k, + find_label lbl (sel_stmt s) (sel_cont k) = + option_map (fun sk => (sel_stmt (fst sk), sel_cont (snd sk))) + (Cminor.find_label lbl s k). +Proof. + induction s; intros; simpl; auto. + unfold store. destruct (addressing (sel_expr e)); auto. + change (Kseq (sel_stmt s2) (sel_cont k)) + with (sel_cont (Cminor.Kseq s2 k)). + rewrite IHs1. rewrite IHs2. + destruct (Cminor.find_label lbl s1 (Cminor.Kseq s2 k)); auto. + rewrite IHs1. rewrite IHs2. + destruct (Cminor.find_label lbl s1 k); auto. + change (Kseq (Sloop (sel_stmt s)) (sel_cont k)) + with (sel_cont (Cminor.Kseq (Cminor.Sloop s) k)). + auto. + change (Kblock (sel_cont k)) + with (sel_cont (Cminor.Kblock k)). + auto. + destruct o; auto. + destruct (ident_eq lbl l); auto. +Qed. + +Lemma sel_step_correct: + forall S1 t S2, Cminor.step ge S1 t S2 -> + forall T1, match_states S1 T1 -> + exists T2, step tge T1 t T2 /\ match_states S2 T2. +Proof. + induction 1; intros T1 ME; inv ME; simpl; + try (econstructor; split; [econstructor; eauto with evalexpr | econstructor; eauto]; fail). + + (* skip call *) + econstructor; split. + econstructor. destruct k; simpl in H; simpl; auto. + rewrite <- H0; reflexivity. + constructor; auto. + (* assign *) + exists (State (sel_function f) Sskip (sel_cont k) sp (PTree.set id v e) m); split. + constructor. auto with evalexpr. + constructor; auto. + (* store *) + econstructor; split. + eapply eval_store; eauto with evalexpr. + constructor; auto. + (* Scall *) + econstructor; split. + econstructor; eauto with evalexpr. + apply functions_translated; eauto. + apply sig_function_translated. + constructor; auto. + (* Stailcall *) + econstructor; split. + econstructor; eauto with evalexpr. + apply functions_translated; eauto. + apply sig_function_translated. + constructor; auto. apply call_cont_commut. + (* Salloc *) + exists (State (sel_function f) Sskip (sel_cont k) sp (PTree.set id (Vptr b Int.zero) e) m'); split. + econstructor; eauto with evalexpr. + constructor; auto. + (* Sifthenelse *) + exists (State (sel_function f) (if b then sel_stmt s1 else sel_stmt s2) (sel_cont k) sp e m); split. + constructor. eapply eval_condition_of_expr; eauto with evalexpr. + constructor; auto. destruct b; auto. + (* Sreturn None *) + econstructor; split. + econstructor. rewrite <- H; reflexivity. + constructor; auto. apply call_cont_commut. + (* Sreturn Some *) + econstructor; split. + econstructor. simpl. auto. eauto with evalexpr. + constructor; auto. apply call_cont_commut. + (* Sgoto *) + econstructor; split. + econstructor. simpl. rewrite call_cont_commut. rewrite find_label_commut. + rewrite H. simpl. reflexivity. + constructor; auto. +Qed. + +Lemma sel_initial_states: + forall S, Cminor.initial_state prog S -> + exists R, initial_state tprog R /\ match_states S R. +Proof. + induction 1. + econstructor; split. + econstructor. + simpl. fold tge. rewrite symbols_preserved. eexact H. + apply function_ptr_translated. eauto. + rewrite <- H1. apply sig_function_translated; auto. + unfold tprog, sel_program. rewrite Genv.init_mem_transf. + constructor; auto. +Qed. + +Lemma sel_final_states: + forall S R r, + match_states S R -> Cminor.final_state S r -> final_state R r. +Proof. + intros. inv H0. inv H. simpl. constructor. +Qed. + +Theorem transf_program_correct: + forall (beh: program_behavior), + Cminor.exec_program prog beh -> CminorSel.exec_program tprog beh. +Proof. + unfold CminorSel.exec_program, Cminor.exec_program; intros. + eapply simulation_step_preservation; eauto. + eexact sel_initial_states. + eexact sel_final_states. + exact sel_step_correct. +Qed. + +End PRESERVATION. diff --git a/powerpc/eabi/Conventions.v b/powerpc/eabi/Conventions.v new file mode 100644 index 0000000..6e27b9d --- /dev/null +++ b/powerpc/eabi/Conventions.v @@ -0,0 +1,798 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Function calling conventions and other conventions regarding the use of + machine registers and stack slots. *) + +Require Import Coqlib. +Require Import AST. +Require Import Locations. + +(** * Classification of machine registers *) + +(** Machine registers (type [mreg] in module [Locations]) are divided in + the following groups: +- Temporaries used for spilling, reloading, and parallel move operations. +- Allocatable registers, that can be assigned to RTL pseudo-registers. + These are further divided into: +-- Callee-save registers, whose value is preserved across a function call. +-- Caller-save registers that can be modified during a function call. + + We follow the PowerPC/EABI application binary interface (ABI) in our choice + of callee- and caller-save registers. +*) + +Definition int_caller_save_regs := + R3 :: R4 :: R5 :: R6 :: R7 :: R8 :: R9 :: R10 :: nil. + +Definition float_caller_save_regs := + F1 :: F2 :: F3 :: F4 :: F5 :: F6 :: F7 :: F8 :: F9 :: F10 :: nil. + +Definition int_callee_save_regs := + R13 :: R14 :: R15 :: R16 :: R17 :: R18 :: R19 :: R20 :: R21 :: R22 :: + R23 :: R24 :: R25 :: R26 :: R27 :: R28 :: R29 :: R30 :: R31 :: nil. + +Definition float_callee_save_regs := + F14 :: F15 :: F16 :: F17 :: F18 :: F19 :: F20 :: F21 :: F22 :: + F23 :: F24 :: F25 :: F26 :: F27 :: F28 :: F29 :: F30 :: F31 :: nil. + +Definition destroyed_at_call_regs := + int_caller_save_regs ++ float_caller_save_regs. + +Definition destroyed_at_call := + List.map R destroyed_at_call_regs. + +Definition int_temporaries := IT1 :: IT2 :: nil. + +Definition float_temporaries := FT1 :: FT2 :: FT3 :: nil. + +Definition temporaries := + R IT1 :: R IT2 :: R FT1 :: R FT2 :: R FT3 :: nil. + +(** The [index_int_callee_save] and [index_float_callee_save] associate + a unique positive integer to callee-save registers. This integer is + used in [Stacking] to determine where to save these registers in + the activation record if they are used by the current function. *) + +Definition index_int_callee_save (r: mreg) := + match r with + | R13 => 0 | R14 => 1 | R15 => 2 | R16 => 3 + | R17 => 4 | R18 => 5 | R19 => 6 | R20 => 7 + | R21 => 8 | R22 => 9 | R23 => 10 | R24 => 11 + | R25 => 12 | R26 => 13 | R27 => 14 | R28 => 15 + | R29 => 16 | R30 => 17 | R31 => 18 | _ => -1 + end. + +Definition index_float_callee_save (r: mreg) := + match r with + | F14 => 0 | F15 => 1 | F16 => 2 | F17 => 3 + | F18 => 4 | F19 => 5 | F20 => 6 | F21 => 7 + | F22 => 8 | F23 => 9 | F24 => 10 | F25 => 11 + | F26 => 12 | F27 => 13 | F28 => 14 | F29 => 15 + | F30 => 16 | F31 => 17 | _ => -1 + end. + +Ltac ElimOrEq := + match goal with + | |- (?x = ?y) \/ _ -> _ => + let H := fresh in + (intro H; elim H; clear H; + [intro H; rewrite <- H; clear H | ElimOrEq]) + | |- False -> _ => + let H := fresh in (intro H; contradiction) + end. + +Ltac OrEq := + match goal with + | |- (?x = ?x) \/ _ => left; reflexivity + | |- (?x = ?y) \/ _ => right; OrEq + | |- False => fail + end. + +Ltac NotOrEq := + match goal with + | |- (?x = ?y) \/ _ -> False => + let H := fresh in ( + intro H; elim H; clear H; [intro; discriminate | NotOrEq]) + | |- False -> False => + contradiction + end. + +Lemma index_int_callee_save_pos: + forall r, In r int_callee_save_regs -> index_int_callee_save r >= 0. +Proof. + intro r. simpl; ElimOrEq; unfold index_int_callee_save; omega. +Qed. + +Lemma index_float_callee_save_pos: + forall r, In r float_callee_save_regs -> index_float_callee_save r >= 0. +Proof. + intro r. simpl; ElimOrEq; unfold index_float_callee_save; omega. +Qed. + +Lemma index_int_callee_save_pos2: + forall r, index_int_callee_save r >= 0 -> In r int_callee_save_regs. +Proof. + destruct r; simpl; intro; omegaContradiction || OrEq. +Qed. + +Lemma index_float_callee_save_pos2: + forall r, index_float_callee_save r >= 0 -> In r float_callee_save_regs. +Proof. + destruct r; simpl; intro; omegaContradiction || OrEq. +Qed. + +Lemma index_int_callee_save_inj: + forall r1 r2, + In r1 int_callee_save_regs -> + In r2 int_callee_save_regs -> + r1 <> r2 -> + index_int_callee_save r1 <> index_int_callee_save r2. +Proof. + intros r1 r2. + simpl; ElimOrEq; ElimOrEq; unfold index_int_callee_save; + intros; congruence. +Qed. + +Lemma index_float_callee_save_inj: + forall r1 r2, + In r1 float_callee_save_regs -> + In r2 float_callee_save_regs -> + r1 <> r2 -> + index_float_callee_save r1 <> index_float_callee_save r2. +Proof. + intros r1 r2. + simpl; ElimOrEq; ElimOrEq; unfold index_float_callee_save; + intros; congruence. +Qed. + +(** The following lemmas show that + (temporaries, destroyed at call, integer callee-save, float callee-save) + is a partition of the set of machine registers. *) + +Lemma int_float_callee_save_disjoint: + list_disjoint int_callee_save_regs float_callee_save_regs. +Proof. + red; intros r1 r2. simpl; ElimOrEq; ElimOrEq; discriminate. +Qed. + +Lemma register_classification: + forall r, + (In (R r) temporaries \/ In (R r) destroyed_at_call) \/ + (In r int_callee_save_regs \/ In r float_callee_save_regs). +Proof. + destruct r; + try (left; left; simpl; OrEq); + try (left; right; simpl; OrEq); + try (right; left; simpl; OrEq); + try (right; right; simpl; OrEq). +Qed. + +Lemma int_callee_save_not_destroyed: + forall r, + In (R r) temporaries \/ In (R r) destroyed_at_call -> + ~(In r int_callee_save_regs). +Proof. + intros; red; intros. elim H. + generalize H0. simpl; ElimOrEq; NotOrEq. + generalize H0. simpl; ElimOrEq; NotOrEq. +Qed. + +Lemma float_callee_save_not_destroyed: + forall r, + In (R r) temporaries \/ In (R r) destroyed_at_call -> + ~(In r float_callee_save_regs). +Proof. + intros; red; intros. elim H. + generalize H0. simpl; ElimOrEq; NotOrEq. + generalize H0. simpl; ElimOrEq; NotOrEq. +Qed. + +Lemma int_callee_save_type: + forall r, In r int_callee_save_regs -> mreg_type r = Tint. +Proof. + intro. simpl; ElimOrEq; reflexivity. +Qed. + +Lemma float_callee_save_type: + forall r, In r float_callee_save_regs -> mreg_type r = Tfloat. +Proof. + intro. simpl; ElimOrEq; reflexivity. +Qed. + +Ltac NoRepet := + match goal with + | |- list_norepet nil => + apply list_norepet_nil + | |- list_norepet (?a :: ?b) => + apply list_norepet_cons; [simpl; intuition discriminate | NoRepet] + end. + +Lemma int_callee_save_norepet: + list_norepet int_callee_save_regs. +Proof. + unfold int_callee_save_regs; NoRepet. +Qed. + +Lemma float_callee_save_norepet: + list_norepet float_callee_save_regs. +Proof. + unfold float_callee_save_regs; NoRepet. +Qed. + +(** * Acceptable locations for register allocation *) + +(** The following predicate describes the locations that can be assigned + to an RTL pseudo-register during register allocation: a non-temporary + machine register or a [Local] stack slot are acceptable. *) + +Definition loc_acceptable (l: loc) : Prop := + match l with + | R r => ~(In l temporaries) + | S (Local ofs ty) => ofs >= 0 + | S (Incoming _ _) => False + | S (Outgoing _ _) => False + end. + +Definition locs_acceptable (ll: list loc) : Prop := + forall l, In l ll -> loc_acceptable l. + +Lemma temporaries_not_acceptable: + forall l, loc_acceptable l -> Loc.notin l temporaries. +Proof. + unfold loc_acceptable; destruct l. + simpl. intuition congruence. + destruct s; try contradiction. + intro. simpl. tauto. +Qed. +Hint Resolve temporaries_not_acceptable: locs. + +Lemma locs_acceptable_disj_temporaries: + forall ll, locs_acceptable ll -> Loc.disjoint ll temporaries. +Proof. + intros. apply Loc.notin_disjoint. intros. + 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 + and stack slots) used to communicate arguments and results between the + caller and the callee during function calls. These locations are functions + of the signature of the function and of the call instruction. + Agreement between the caller and the callee on the locations to use + is guaranteed by our dynamic semantics for Cminor and RTL, which demand + that the signature of the call instruction is identical to that of the + called function. + + Calling conventions are largely arbitrary: they must respect the properties + proved in this section (such as no overlapping between the locations + of function arguments), but this leaves much liberty in choosing actual + locations. To ensure binary interoperability of code generated by our + compiler with libraries compiled by another PowerPC compiler, we + implement the standard conventions defined in the PowerPC/EABI + application binary interface. *) + +(** ** Location of function result *) + +(** The result value of a function is passed back to the caller in + registers [R3] or [F1], depending on the type of the returned value. + We treat a function without result as a function with one integer result. *) + +Definition loc_result (s: signature) : mreg := + match s.(sig_res) with + | None => R3 + | Some Tint => R3 + | Some Tfloat => F1 + end. + +(** The result location has the type stated in the signature. *) + +Lemma loc_result_type: + forall sig, + mreg_type (loc_result sig) = + match sig.(sig_res) with None => Tint | Some ty => ty end. +Proof. + intros; unfold loc_result. + destruct (sig_res sig). + destruct t; reflexivity. + reflexivity. +Qed. + +(** 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. + destruct (sig_res s). + destruct t; simpl; OrEq. + simpl; OrEq. +Qed. + +(** The result location is not a callee-save register. *) + +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_caller_save s). + generalize (int_callee_save_not_destroyed (loc_result s)). + generalize (float_callee_save_not_destroyed (loc_result s)). + tauto. +Qed. + +(** ** Location of function arguments *) + +(** The PowerPC EABI states the following convention for passing arguments + to a function: +- The first 8 integer arguments are passed in registers [R3] to [R10]. +- The first 8 float arguments are passed in registers [F1] to [F8]. +- Extra arguments are passed on the stack, in [Outgoing] slots, consecutively + assigned (1 word for an integer argument, 2 words for a float), + starting at word offset 0. +- No stack space is reserved for the arguments that are passed in registers. +*) + +Fixpoint loc_arguments_rec + (tyl: list typ) (iregl: list mreg) (fregl: list mreg) + (ofs: Z) {struct tyl} : list loc := + match tyl with + | nil => nil + | Tint :: tys => + match iregl with + | 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) :: loc_arguments_rec tys iregl nil (ofs + 2) + | freg :: fregs => + R freg :: loc_arguments_rec tys iregl fregs ofs + end + end. + +Definition int_param_regs := + R3 :: R4 :: R5 :: R6 :: R7 :: R8 :: R9 :: R10 :: nil. +Definition float_param_regs := + F1 :: F2 :: F3 :: F4 :: F5 :: F6 :: F7 :: F8 :: nil. + +(** [loc_arguments s] returns the list of locations where to store arguments + 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 0. + +(** [size_arguments s] returns the number of [Outgoing] slots used + to call a function with signature [s]. *) + +Fixpoint size_arguments_rec + (tyl: list typ) (iregl: list mreg) (fregl: list mreg) + (ofs: Z) {struct tyl} : Z := + match tyl with + | 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 iregl fregs ofs + end + end. + +Definition size_arguments (s: signature) : Z := + size_arguments_rec s.(sig_args) int_param_regs float_param_regs 0. + +(** A tail-call is possible for a signature if the corresponding + arguments are all passed in registers. *) + +Definition tailcall_possible (s: signature) : Prop := + forall l, In l (loc_arguments s) -> + match l with R _ => True | S _ => False end. + +(** Argument locations are either non-temporary registers or [Outgoing] + stack slots at nonnegative offsets. *) + +Definition loc_argument_acceptable (l: loc) : Prop := + match l with + | R r => ~(In l temporaries) + | S (Outgoing ofs ty) => ofs >= 0 + | _ => False + end. + +Remark loc_arguments_rec_charact: + forall tyl iregl fregl ofs l, + In l (loc_arguments_rec tyl iregl fregl ofs) -> + match l with + | R r => In r iregl \/ In r fregl + | S (Outgoing ofs' ty) => ofs' >= ofs + | S _ => False + end. +Proof. + induction tyl; simpl loc_arguments_rec; intros. + elim H. + 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; auto. right; auto with coqlib. +Qed. + +Lemma loc_arguments_acceptable: + forall (s: signature) (r: loc), + In r (loc_arguments s) -> loc_argument_acceptable r. +Proof. + unfold loc_arguments; intros. + generalize (loc_arguments_rec_charact _ _ _ _ _ H). + destruct r. + intro H0; elim H0. simpl. unfold not. ElimOrEq; NotOrEq. + simpl. unfold not. ElimOrEq; NotOrEq. + destruct s0; try contradiction. + simpl. omega. +Qed. +Hint Resolve loc_arguments_acceptable: locs. + +(** Arguments are parwise disjoint (in the sense of [Loc.norepet]). *) + +Remark loc_arguments_rec_notin_reg: + forall tyl iregl fregl ofs r, + ~(In r iregl) -> ~(In r fregl) -> + Loc.notin (R r) (loc_arguments_rec tyl iregl fregl ofs). +Proof. + induction tyl; simpl; intros. + 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. auto. + tauto. +Qed. + +Remark loc_arguments_rec_notin_local: + forall tyl iregl fregl ofs ofs0 ty0, + Loc.notin (S (Local ofs0 ty0)) (loc_arguments_rec tyl iregl fregl ofs). +Proof. + induction tyl; simpl; intros. + auto. + destruct a. + destruct iregl; simpl; auto. + destruct fregl; simpl; auto. +Qed. + +Remark loc_arguments_rec_notin_outgoing: + forall tyl iregl fregl ofs ofs0 ty0, + ofs0 + typesize ty0 <= ofs -> + Loc.notin (S (Outgoing ofs0 ty0)) (loc_arguments_rec tyl iregl fregl ofs). +Proof. + induction tyl; simpl; intros. + auto. + 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: + forall (s: signature), Loc.norepet (loc_arguments s). +Proof. + assert (forall tyl iregl fregl ofs, + list_norepet iregl -> + list_norepet fregl -> + list_disjoint iregl fregl -> + Loc.norepet (loc_arguments_rec tyl iregl fregl ofs)). + induction tyl; simpl; intros. + constructor. + 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. 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). auto. + auto with coqlib. auto. inv H0; auto. + apply IHtyl. auto. + inv H0; auto. + red; intros. apply H1. auto. auto with coqlib. + + intro. unfold loc_arguments. apply H. + unfold int_param_regs. NoRepet. + unfold float_param_regs. NoRepet. + red; intros x y; simpl. ElimOrEq; ElimOrEq; discriminate. +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 >= 0. +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 iregl fregl ofs0, + In (S (Outgoing ofs ty)) (loc_arguments_rec tyl iregl fregl ofs0) -> + 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. *) + +Lemma loc_arguments_not_temporaries: + forall sig, Loc.disjoint (loc_arguments sig) temporaries. +Proof. + intros; red; intros x1 x2 H. + generalize (loc_arguments_rec_charact _ _ _ _ _ H). + destruct x1. + intro H0; elim H0; simpl; (ElimOrEq; ElimOrEq; congruence). + destruct s; try contradiction. intro. + simpl; ElimOrEq; auto. +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: + forall sig l, + Loc.notin l destroyed_at_call -> loc_acceptable l -> + Loc.notin l (loc_arguments sig). +Proof. + intros. unfold loc_arguments. destruct l. + apply loc_arguments_rec_notin_reg. + generalize (Loc.notin_not_in _ _ H). intro; red; intro. + apply H1. generalize H2. simpl. ElimOrEq; OrEq. + generalize (Loc.notin_not_in _ _ H). intro; red; intro. + apply H1. generalize H2. simpl. ElimOrEq; OrEq. + destruct s; simpl in H0; try contradiction. + apply loc_arguments_rec_notin_local. +Qed. +Hint Resolve arguments_not_preserved: locs. + +(** Argument locations agree in number with the function signature. *) + +Lemma loc_arguments_length: + forall sig, + List.length (loc_arguments sig) = List.length sig.(sig_args). +Proof. + assert (forall tyl iregl fregl ofs, + List.length (loc_arguments_rec tyl iregl fregl ofs) = List.length tyl). + induction tyl; simpl; intros. + auto. + destruct a. + destruct iregl; simpl; decEq; auto. + destruct fregl; simpl; decEq; auto. + intros. unfold loc_arguments. auto. +Qed. + +(** Argument locations agree in types with the function signature. *) + +Lemma loc_arguments_type: + forall sig, List.map Loc.type (loc_arguments sig) = sig.(sig_args). +Proof. + assert (forall tyl iregl fregl ofs, + (forall r, In r iregl -> mreg_type r = Tint) -> + (forall r, In r fregl -> mreg_type r = Tfloat) -> + List.map Loc.type (loc_arguments_rec tyl iregl fregl ofs) = tyl). + induction tyl; simpl; intros. + auto. + destruct a; [destruct iregl|destruct fregl]; simpl; + f_equal; eauto with coqlib. + + intros. unfold loc_arguments. apply H. + intro; simpl. ElimOrEq; reflexivity. + intro; simpl. ElimOrEq; reflexivity. +Qed. + +(** There is no partial overlap between an argument location and an + acceptable location: they are either identical or disjoint. *) + +Lemma no_overlap_arguments: + forall args sg, + locs_acceptable args -> + Loc.no_overlap args (loc_arguments sg). +Proof. + unfold Loc.no_overlap; intros. + generalize (H r H0). + generalize (loc_arguments_acceptable _ _ H1). + destruct s; destruct r; simpl. + intros. case (mreg_eq m0 m); intro. left; congruence. tauto. + intros. right; destruct s; auto. + intros. right. auto. + destruct s; try tauto. destruct s0; tauto. +Qed. + +(** Decide whether a tailcall is possible. *) + +Definition tailcall_is_possible (sg: signature) : bool := + let fix tcisp (l: list loc) := + match l with + | nil => true + | R _ :: l' => tcisp l' + | S _ :: l' => false + end + in tcisp (loc_arguments sg). + +Lemma tailcall_is_possible_correct: + forall s, tailcall_is_possible s = true -> tailcall_possible s. +Proof. + intro s. unfold tailcall_is_possible, tailcall_possible. + generalize (loc_arguments s). induction l; simpl; intros. + elim H0. + destruct a. + destruct H0. subst l0. auto. apply IHl. auto. auto. discriminate. +Qed. + +(** ** Location of function parameters *) + +(** A function finds the values of its parameter in the same locations + where its caller stored them, except that the stack-allocated arguments, + viewed as [Outgoing] slots by the caller, are accessed via [Incoming] + slots (at the same offsets and types) in the callee. *) + +Definition parameter_of_argument (l: loc) : loc := + match l with + | S (Outgoing n ty) => S (Incoming n ty) + | _ => l + end. + +Definition loc_parameters (s: signature) := + List.map parameter_of_argument (loc_arguments s). + +Lemma loc_parameters_type: + forall sig, List.map Loc.type (loc_parameters sig) = sig.(sig_args). +Proof. + intros. unfold loc_parameters. + rewrite list_map_compose. + rewrite <- loc_arguments_type. + apply list_map_exten. + intros. destruct x; simpl. auto. + 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. + intro; red; intros. + unfold loc_parameters in H. + elim (list_in_map_inv _ _ _ H). intros y [EQ IN]. + generalize (loc_arguments_not_temporaries sig y x2 IN H0). + subst x1. destruct x2. + destruct y; simpl. auto. destruct s; auto. + byContradiction. generalize H0. simpl. NotOrEq. +Qed. + +Lemma no_overlap_parameters: + forall params sg, + locs_acceptable params -> + Loc.no_overlap (loc_parameters sg) params. +Proof. + unfold Loc.no_overlap; intros. + unfold loc_parameters in H0. + elim (list_in_map_inv _ _ _ H0). intros t [EQ IN]. + rewrite EQ. + generalize (loc_arguments_acceptable _ _ IN). + generalize (H s H1). + destruct s; destruct t; simpl. + intros. case (mreg_eq m0 m); intro. left; congruence. tauto. + intros. right; destruct s; simpl; auto. + intros; right; auto. + destruct s; try tauto. destruct s0; try tauto. + intros; simpl. tauto. +Qed. + +(** ** Location of argument and result for dynamic memory allocation *) + +Definition loc_alloc_argument := R3. +Definition loc_alloc_result := R3. diff --git a/powerpc/eabi/Stacklayout.v b/powerpc/eabi/Stacklayout.v new file mode 100644 index 0000000..f641847 --- /dev/null +++ b/powerpc/eabi/Stacklayout.v @@ -0,0 +1,79 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Machine- and ABI-dependent layout information for activation records. *) + +Require Import Coqlib. +Require Import Bounds. + +(** In the PowerPC/EABI application binary interface, + the general shape of activation records is as follows, + from bottom (lowest offsets) to top: +- 8 reserved bytes. The first 4 bytes hold the back pointer to the + activation record of the caller. The next 4 bytes hold the + return address. +- Space for outgoing arguments to function calls. +- Local stack slots of integer type. +- Saved values of integer callee-save registers used by the function. +- One word of padding, if necessary to align the following data + on a 8-byte boundary. +- Local stack slots of float type. +- Saved values of float callee-save registers used by the function. +- Space for the stack-allocated data declared in Cminor. + +To facilitate some of the proofs, the Cminor stack-allocated data +starts at offset 0; the preceding areas in the activation record +therefore have negative offsets. This part (with negative offsets) +is called the ``frame'', by opposition with the ``Cminor stack data'' +which is the part with positive offsets. + +The [frame_env] compilation environment records the positions of +the boundaries between areas in the frame part. +*) + +Definition fe_ofs_arg := 8. + +Record frame_env : Set := mk_frame_env { + fe_size: Z; + fe_ofs_link: Z; + fe_ofs_retaddr: Z; + fe_ofs_int_local: Z; + fe_ofs_int_callee_save: Z; + fe_num_int_callee_save: Z; + fe_ofs_float_local: Z; + fe_ofs_float_callee_save: Z; + fe_num_float_callee_save: Z +}. + +(** Computation of the frame environment from the bounds of the current + function. *) + +Definition make_env (b: bounds) := + let oil := 8 + 4 * b.(bound_outgoing) in (* integer locals *) + let oics := oil + 4 * b.(bound_int_local) in (* integer callee-saves *) + let oendi := oics + 4 * b.(bound_int_callee_save) in + let ofl := align oendi 8 in (* float locals *) + let ofcs := ofl + 8 * b.(bound_float_local) in (* float callee-saves *) + let sz := ofcs + 8 * b.(bound_float_callee_save) in (* total frame size *) + mk_frame_env sz 0 4 + oil oics b.(bound_int_callee_save) + ofl ofcs b.(bound_float_callee_save). + + +Remark align_float_part: + forall b, + 8 + 4 * bound_outgoing b + 4 * bound_int_local b + 4 * bound_int_callee_save b <= + align (8 + 4 * bound_outgoing b + 4 * bound_int_local b + 4 * bound_int_callee_save b) 8. +Proof. + intros. apply align_le. omega. +Qed. + diff --git a/powerpc/macosx/Conventions.v b/powerpc/macosx/Conventions.v new file mode 100644 index 0000000..4f06b41 --- /dev/null +++ b/powerpc/macosx/Conventions.v @@ -0,0 +1,805 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Function calling conventions and other conventions regarding the use of + machine registers and stack slots. *) + +Require Import Coqlib. +Require Import AST. +Require Import Locations. + +(** * Classification of machine registers *) + +(** Machine registers (type [mreg] in module [Locations]) are divided in + the following groups: +- Temporaries used for spilling, reloading, and parallel move operations. +- Allocatable registers, that can be assigned to RTL pseudo-registers. + These are further divided into: +-- Callee-save registers, whose value is preserved across a function call. +-- Caller-save registers that can be modified during a function call. + + We follow the PowerPC/MacOSX application binary interface (ABI) in our choice + of callee- and caller-save registers. +*) + +Definition int_caller_save_regs := + R3 :: R4 :: R5 :: R6 :: R7 :: R8 :: R9 :: R10 :: nil. + +Definition float_caller_save_regs := + F1 :: F2 :: F3 :: F4 :: F5 :: F6 :: F7 :: F8 :: F9 :: F10 :: nil. + +Definition int_callee_save_regs := + R13 :: R14 :: R15 :: R16 :: R17 :: R18 :: R19 :: R20 :: R21 :: R22 :: + R23 :: R24 :: R25 :: R26 :: R27 :: R28 :: R29 :: R30 :: R31 :: nil. + +Definition float_callee_save_regs := + F14 :: F15 :: F16 :: F17 :: F18 :: F19 :: F20 :: F21 :: F22 :: + F23 :: F24 :: F25 :: F26 :: F27 :: F28 :: F29 :: F30 :: F31 :: nil. + +Definition destroyed_at_call_regs := + int_caller_save_regs ++ float_caller_save_regs. + +Definition destroyed_at_call := + List.map R destroyed_at_call_regs. + +Definition int_temporaries := IT1 :: IT2 :: nil. + +Definition float_temporaries := FT1 :: FT2 :: FT3 :: nil. + +Definition temporaries := + R IT1 :: R IT2 :: R FT1 :: R FT2 :: R FT3 :: nil. + +(** The [index_int_callee_save] and [index_float_callee_save] associate + a unique positive integer to callee-save registers. This integer is + used in [Stacking] to determine where to save these registers in + the activation record if they are used by the current function. *) + +Definition index_int_callee_save (r: mreg) := + match r with + | R13 => 0 | R14 => 1 | R15 => 2 | R16 => 3 + | R17 => 4 | R18 => 5 | R19 => 6 | R20 => 7 + | R21 => 8 | R22 => 9 | R23 => 10 | R24 => 11 + | R25 => 12 | R26 => 13 | R27 => 14 | R28 => 15 + | R29 => 16 | R30 => 17 | R31 => 18 | _ => -1 + end. + +Definition index_float_callee_save (r: mreg) := + match r with + | F14 => 0 | F15 => 1 | F16 => 2 | F17 => 3 + | F18 => 4 | F19 => 5 | F20 => 6 | F21 => 7 + | F22 => 8 | F23 => 9 | F24 => 10 | F25 => 11 + | F26 => 12 | F27 => 13 | F28 => 14 | F29 => 15 + | F30 => 16 | F31 => 17 | _ => -1 + end. + +Ltac ElimOrEq := + match goal with + | |- (?x = ?y) \/ _ -> _ => + let H := fresh in + (intro H; elim H; clear H; + [intro H; rewrite <- H; clear H | ElimOrEq]) + | |- False -> _ => + let H := fresh in (intro H; contradiction) + end. + +Ltac OrEq := + match goal with + | |- (?x = ?x) \/ _ => left; reflexivity + | |- (?x = ?y) \/ _ => right; OrEq + | |- False => fail + end. + +Ltac NotOrEq := + match goal with + | |- (?x = ?y) \/ _ -> False => + let H := fresh in ( + intro H; elim H; clear H; [intro; discriminate | NotOrEq]) + | |- False -> False => + contradiction + end. + +Lemma index_int_callee_save_pos: + forall r, In r int_callee_save_regs -> index_int_callee_save r >= 0. +Proof. + intro r. simpl; ElimOrEq; unfold index_int_callee_save; omega. +Qed. + +Lemma index_float_callee_save_pos: + forall r, In r float_callee_save_regs -> index_float_callee_save r >= 0. +Proof. + intro r. simpl; ElimOrEq; unfold index_float_callee_save; omega. +Qed. + +Lemma index_int_callee_save_pos2: + forall r, index_int_callee_save r >= 0 -> In r int_callee_save_regs. +Proof. + destruct r; simpl; intro; omegaContradiction || OrEq. +Qed. + +Lemma index_float_callee_save_pos2: + forall r, index_float_callee_save r >= 0 -> In r float_callee_save_regs. +Proof. + destruct r; simpl; intro; omegaContradiction || OrEq. +Qed. + +Lemma index_int_callee_save_inj: + forall r1 r2, + In r1 int_callee_save_regs -> + In r2 int_callee_save_regs -> + r1 <> r2 -> + index_int_callee_save r1 <> index_int_callee_save r2. +Proof. + intros r1 r2. + simpl; ElimOrEq; ElimOrEq; unfold index_int_callee_save; + intros; congruence. +Qed. + +Lemma index_float_callee_save_inj: + forall r1 r2, + In r1 float_callee_save_regs -> + In r2 float_callee_save_regs -> + r1 <> r2 -> + index_float_callee_save r1 <> index_float_callee_save r2. +Proof. + intros r1 r2. + simpl; ElimOrEq; ElimOrEq; unfold index_float_callee_save; + intros; congruence. +Qed. + +(** The following lemmas show that + (temporaries, destroyed at call, integer callee-save, float callee-save) + is a partition of the set of machine registers. *) + +Lemma int_float_callee_save_disjoint: + list_disjoint int_callee_save_regs float_callee_save_regs. +Proof. + red; intros r1 r2. simpl; ElimOrEq; ElimOrEq; discriminate. +Qed. + +Lemma register_classification: + forall r, + (In (R r) temporaries \/ In (R r) destroyed_at_call) \/ + (In r int_callee_save_regs \/ In r float_callee_save_regs). +Proof. + destruct r; + try (left; left; simpl; OrEq); + try (left; right; simpl; OrEq); + try (right; left; simpl; OrEq); + try (right; right; simpl; OrEq). +Qed. + +Lemma int_callee_save_not_destroyed: + forall r, + In (R r) temporaries \/ In (R r) destroyed_at_call -> + ~(In r int_callee_save_regs). +Proof. + intros; red; intros. elim H. + generalize H0. simpl; ElimOrEq; NotOrEq. + generalize H0. simpl; ElimOrEq; NotOrEq. +Qed. + +Lemma float_callee_save_not_destroyed: + forall r, + In (R r) temporaries \/ In (R r) destroyed_at_call -> + ~(In r float_callee_save_regs). +Proof. + intros; red; intros. elim H. + generalize H0. simpl; ElimOrEq; NotOrEq. + generalize H0. simpl; ElimOrEq; NotOrEq. +Qed. + +Lemma int_callee_save_type: + forall r, In r int_callee_save_regs -> mreg_type r = Tint. +Proof. + intro. simpl; ElimOrEq; reflexivity. +Qed. + +Lemma float_callee_save_type: + forall r, In r float_callee_save_regs -> mreg_type r = Tfloat. +Proof. + intro. simpl; ElimOrEq; reflexivity. +Qed. + +Ltac NoRepet := + match goal with + | |- list_norepet nil => + apply list_norepet_nil + | |- list_norepet (?a :: ?b) => + apply list_norepet_cons; [simpl; intuition discriminate | NoRepet] + end. + +Lemma int_callee_save_norepet: + list_norepet int_callee_save_regs. +Proof. + unfold int_callee_save_regs; NoRepet. +Qed. + +Lemma float_callee_save_norepet: + list_norepet float_callee_save_regs. +Proof. + unfold float_callee_save_regs; NoRepet. +Qed. + +(** * Acceptable locations for register allocation *) + +(** The following predicate describes the locations that can be assigned + to an RTL pseudo-register during register allocation: a non-temporary + machine register or a [Local] stack slot are acceptable. *) + +Definition loc_acceptable (l: loc) : Prop := + match l with + | R r => ~(In l temporaries) + | S (Local ofs ty) => ofs >= 0 + | S (Incoming _ _) => False + | S (Outgoing _ _) => False + end. + +Definition locs_acceptable (ll: list loc) : Prop := + forall l, In l ll -> loc_acceptable l. + +Lemma temporaries_not_acceptable: + forall l, loc_acceptable l -> Loc.notin l temporaries. +Proof. + unfold loc_acceptable; destruct l. + simpl. intuition congruence. + destruct s; try contradiction. + intro. simpl. tauto. +Qed. +Hint Resolve temporaries_not_acceptable: locs. + +Lemma locs_acceptable_disj_temporaries: + forall ll, locs_acceptable ll -> Loc.disjoint ll temporaries. +Proof. + intros. apply Loc.notin_disjoint. intros. + 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 + and stack slots) used to communicate arguments and results between the + caller and the callee during function calls. These locations are functions + of the signature of the function and of the call instruction. + Agreement between the caller and the callee on the locations to use + is guaranteed by our dynamic semantics for Cminor and RTL, which demand + that the signature of the call instruction is identical to that of the + called function. + + Calling conventions are largely arbitrary: they must respect the properties + proved in this section (such as no overlapping between the locations + of function arguments), but this leaves much liberty in choosing actual + locations. To ensure binary interoperability of code generated by our + compiler with libraries compiled by another PowerPC compiler, we + implement the standard conventions defined in the PowerPC/MacOS X + application binary interface. *) + +(** ** Location of function result *) + +(** The result value of a function is passed back to the caller in + registers [R3] or [F1], depending on the type of the returned value. + We treat a function without result as a function with one integer result. *) + +Definition loc_result (s: signature) : mreg := + match s.(sig_res) with + | None => R3 + | Some Tint => R3 + | Some Tfloat => F1 + end. + +(** The result location has the type stated in the signature. *) + +Lemma loc_result_type: + forall sig, + mreg_type (loc_result sig) = + match sig.(sig_res) with None => Tint | Some ty => ty end. +Proof. + intros; unfold loc_result. + destruct (sig_res sig). + destruct t; reflexivity. + reflexivity. +Qed. + +(** 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. + destruct (sig_res s). + destruct t; simpl; OrEq. + simpl; OrEq. +Qed. + +(** The result location is not a callee-save register. *) + +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_caller_save s). + generalize (int_callee_save_not_destroyed (loc_result s)). + generalize (float_callee_save_not_destroyed (loc_result s)). + tauto. +Qed. + +(** ** Location of function arguments *) + +(** The PowerPC ABI states the following convention for passing arguments + to a function: +- The first 8 integer arguments are passed in registers [R3] to [R10]. +- The first 10 float arguments are passed in registers [F1] to [F10]. +- Each float argument passed in a float register ``consumes'' two + integer arguments. +- Extra arguments are passed on the stack, in [Outgoing] slots, consecutively + assigned (1 word for an integer argument, 2 words for a float), + starting at word offset 0. +- Stack space is reserved (as unused [Outgoing] slots) for the arguments + that are passed in registers. + +These conventions are somewhat baroque, but they are mandated by the ABI. +*) + +Fixpoint loc_arguments_rec + (tyl: list typ) (iregl: list mreg) (fregl: list mreg) + (ofs: Z) {struct tyl} : list loc := + match tyl with + | nil => nil + | Tint :: tys => + match iregl with + | 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) :: 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 := + R3 :: R4 :: R5 :: R6 :: R7 :: R8 :: R9 :: R10 :: nil. +Definition float_param_regs := + F1 :: F2 :: F3 :: F4 :: F5 :: F6 :: F7 :: F8 :: F9 :: F10 :: nil. + +(** [loc_arguments s] returns the list of locations where to store arguments + 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 8. + +(** [size_arguments s] returns the number of [Outgoing] slots used + to call a function with signature [s]. *) + +Fixpoint size_arguments_rec + (tyl: list typ) (iregl: list mreg) (fregl: list mreg) + (ofs: Z) {struct tyl} : Z := + match tyl with + | 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) int_param_regs float_param_regs 8. + +(** 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 nonnegative offsets. *) + +Definition loc_argument_acceptable (l: loc) : Prop := + match l with + | R r => ~(In l temporaries) + | S (Outgoing ofs ty) => ofs >= 0 + | _ => False + end. + +Remark loc_arguments_rec_charact: + forall tyl iregl fregl ofs l, + In l (loc_arguments_rec tyl iregl fregl ofs) -> + match l with + | R r => In r iregl \/ In r fregl + | S (Outgoing ofs' ty) => ofs' >= ofs + | S _ => False + end. +Proof. + induction tyl; simpl loc_arguments_rec; intros. + elim H. + 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: + forall (s: signature) (r: loc), + In r (loc_arguments s) -> loc_argument_acceptable r. +Proof. + unfold loc_arguments; intros. + generalize (loc_arguments_rec_charact _ _ _ _ _ H). + destruct r. + intro H0; elim H0. simpl. unfold not. ElimOrEq; NotOrEq. + simpl. unfold not. ElimOrEq; NotOrEq. + destruct s0; try contradiction. + simpl. omega. +Qed. +Hint Resolve loc_arguments_acceptable: locs. + +(** Arguments are parwise disjoint (in the sense of [Loc.norepet]). *) + +Remark loc_arguments_rec_notin_reg: + forall tyl iregl fregl ofs r, + ~(In r iregl) -> ~(In r fregl) -> + Loc.notin (R r) (loc_arguments_rec tyl iregl fregl ofs). +Proof. + induction tyl; simpl; intros. + 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: + forall tyl iregl fregl ofs ofs0 ty0, + Loc.notin (S (Local ofs0 ty0)) (loc_arguments_rec tyl iregl fregl ofs). +Proof. + induction tyl; simpl; intros. + auto. + destruct a. + destruct iregl; simpl; auto. + destruct fregl; simpl; auto. +Qed. + +Remark loc_arguments_rec_notin_outgoing: + forall tyl iregl fregl ofs ofs0 ty0, + ofs0 + typesize ty0 <= ofs -> + Loc.notin (S (Outgoing ofs0 ty0)) (loc_arguments_rec tyl iregl fregl ofs). +Proof. + induction tyl; simpl; intros. + auto. + 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: + forall (s: signature), Loc.norepet (loc_arguments s). +Proof. + assert (forall tyl iregl fregl ofs, + list_norepet iregl -> + list_norepet fregl -> + list_disjoint iregl fregl -> + Loc.norepet (loc_arguments_rec tyl iregl fregl ofs)). + induction tyl; simpl; intros. + constructor. + 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. 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. 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. + unfold float_param_regs. NoRepet. + red; intros x y; simpl. ElimOrEq; ElimOrEq; discriminate. +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 >= 0. +Proof. + intros; unfold size_arguments. apply Zle_ge. apply Zle_trans with 8. omega. + 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 iregl fregl ofs0, + In (S (Outgoing ofs ty)) (loc_arguments_rec tyl iregl fregl ofs0) -> + 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. *) + +Lemma loc_arguments_not_temporaries: + forall sig, Loc.disjoint (loc_arguments sig) temporaries. +Proof. + intros; red; intros x1 x2 H. + generalize (loc_arguments_rec_charact _ _ _ _ _ H). + destruct x1. + intro H0; elim H0; simpl; (ElimOrEq; ElimOrEq; congruence). + destruct s; try contradiction. intro. + simpl; ElimOrEq; auto. +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: + forall sig l, + Loc.notin l destroyed_at_call -> loc_acceptable l -> + Loc.notin l (loc_arguments sig). +Proof. + intros. unfold loc_arguments. destruct l. + apply loc_arguments_rec_notin_reg. + generalize (Loc.notin_not_in _ _ H). intro; red; intro. + apply H1. generalize H2. simpl. ElimOrEq; OrEq. + generalize (Loc.notin_not_in _ _ H). intro; red; intro. + apply H1. generalize H2. simpl. ElimOrEq; OrEq. + destruct s; simpl in H0; try contradiction. + apply loc_arguments_rec_notin_local. +Qed. +Hint Resolve arguments_not_preserved: locs. + +(** Argument locations agree in number with the function signature. *) + +Lemma loc_arguments_length: + forall sig, + List.length (loc_arguments sig) = List.length sig.(sig_args). +Proof. + assert (forall tyl iregl fregl ofs, + List.length (loc_arguments_rec tyl iregl fregl ofs) = List.length tyl). + induction tyl; simpl; intros. + auto. + destruct a. + destruct iregl; simpl; decEq; auto. + destruct fregl; simpl; decEq; auto. + intros. unfold loc_arguments. auto. +Qed. + +(** Argument locations agree in types with the function signature. *) + +Lemma loc_arguments_type: + forall sig, List.map Loc.type (loc_arguments sig) = sig.(sig_args). +Proof. + assert (forall tyl iregl fregl ofs, + (forall r, In r iregl -> mreg_type r = Tint) -> + (forall r, In r fregl -> mreg_type r = Tfloat) -> + List.map Loc.type (loc_arguments_rec tyl iregl fregl ofs) = tyl). + induction tyl; simpl; intros. + 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. + intro; simpl. ElimOrEq; reflexivity. +Qed. + +(** There is no partial overlap between an argument location and an + acceptable location: they are either identical or disjoint. *) + +Lemma no_overlap_arguments: + forall args sg, + locs_acceptable args -> + Loc.no_overlap args (loc_arguments sg). +Proof. + unfold Loc.no_overlap; intros. + generalize (H r H0). + generalize (loc_arguments_acceptable _ _ H1). + destruct s; destruct r; simpl. + intros. case (mreg_eq m0 m); intro. left; congruence. tauto. + intros. right; destruct s; auto. + intros. right. auto. + destruct s; try tauto. destruct s0; tauto. +Qed. + +(** Decide whether a tailcall is possible. *) + +Definition tailcall_is_possible (sg: signature) : bool := + let fix tcisp (l: list loc) := + match l with + | nil => true + | R _ :: l' => tcisp l' + | S _ :: l' => false + end + in tcisp (loc_arguments sg). + +Lemma tailcall_is_possible_correct: + forall s, tailcall_is_possible s = true -> tailcall_possible s. +Proof. + intro s. unfold tailcall_is_possible, tailcall_possible. + generalize (loc_arguments s). induction l; simpl; intros. + elim H0. + destruct a. + destruct H0. subst l0. auto. apply IHl. auto. auto. discriminate. +Qed. + +(** ** Location of function parameters *) + +(** A function finds the values of its parameter in the same locations + where its caller stored them, except that the stack-allocated arguments, + viewed as [Outgoing] slots by the caller, are accessed via [Incoming] + slots (at the same offsets and types) in the callee. *) + +Definition parameter_of_argument (l: loc) : loc := + match l with + | S (Outgoing n ty) => S (Incoming n ty) + | _ => l + end. + +Definition loc_parameters (s: signature) := + List.map parameter_of_argument (loc_arguments s). + +Lemma loc_parameters_type: + forall sig, List.map Loc.type (loc_parameters sig) = sig.(sig_args). +Proof. + intros. unfold loc_parameters. + rewrite list_map_compose. + rewrite <- loc_arguments_type. + apply list_map_exten. + intros. destruct x; simpl. auto. + 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. + intro; red; intros. + unfold loc_parameters in H. + elim (list_in_map_inv _ _ _ H). intros y [EQ IN]. + generalize (loc_arguments_not_temporaries sig y x2 IN H0). + subst x1. destruct x2. + destruct y; simpl. auto. destruct s; auto. + byContradiction. generalize H0. simpl. NotOrEq. +Qed. + +Lemma no_overlap_parameters: + forall params sg, + locs_acceptable params -> + Loc.no_overlap (loc_parameters sg) params. +Proof. + unfold Loc.no_overlap; intros. + unfold loc_parameters in H0. + elim (list_in_map_inv _ _ _ H0). intros t [EQ IN]. + rewrite EQ. + generalize (loc_arguments_acceptable _ _ IN). + generalize (H s H1). + destruct s; destruct t; simpl. + intros. case (mreg_eq m0 m); intro. left; congruence. tauto. + intros. right; destruct s; simpl; auto. + intros; right; auto. + destruct s; try tauto. destruct s0; try tauto. + intros; simpl. tauto. +Qed. + +(** ** Location of argument and result for dynamic memory allocation *) + +Definition loc_alloc_argument := R3. +Definition loc_alloc_result := R3. diff --git a/powerpc/macosx/Stacklayout.v b/powerpc/macosx/Stacklayout.v new file mode 100644 index 0000000..0e9be22 --- /dev/null +++ b/powerpc/macosx/Stacklayout.v @@ -0,0 +1,79 @@ +(* *********************************************************************) +(* *) +(* The Compcert verified compiler *) +(* *) +(* Xavier Leroy, INRIA Paris-Rocquencourt *) +(* *) +(* Copyright Institut National de Recherche en Informatique et en *) +(* Automatique. All rights reserved. This file is distributed *) +(* under the terms of the INRIA Non-Commercial License Agreement. *) +(* *) +(* *********************************************************************) + +(** Machine- and ABI-dependent layout information for activation records. *) + +Require Import Coqlib. +Require Import Bounds. + +(** The general shape of activation records is as follows, + from bottom (lowest offsets) to top: +- 24 reserved bytes. The first 4 bytes hold the back pointer to the + activation record of the caller. We use the 4 bytes at offset 12 + to store the return address. (These are reserved by the PowerPC + application binary interface.) The remaining bytes are unused. +- Space for outgoing arguments to function calls. +- Local stack slots of integer type. +- Saved values of integer callee-save registers used by the function. +- One word of padding, if necessary to align the following data + on a 8-byte boundary. +- Local stack slots of float type. +- Saved values of float callee-save registers used by the function. +- Space for the stack-allocated data declared in Cminor. + +To facilitate some of the proofs, the Cminor stack-allocated data +starts at offset 0; the preceding areas in the activation record +therefore have negative offsets. This part (with negative offsets) +is called the ``frame'', by opposition with the ``Cminor stack data'' +which is the part with positive offsets. + +The [frame_env] compilation environment records the positions of +the boundaries between areas in the frame part. +*) + +Definition fe_ofs_arg := 24. + +Record frame_env : Set := mk_frame_env { + fe_size: Z; + fe_ofs_link: Z; + fe_ofs_retaddr: Z; + fe_ofs_int_local: Z; + fe_ofs_int_callee_save: Z; + fe_num_int_callee_save: Z; + fe_ofs_float_local: Z; + fe_ofs_float_callee_save: Z; + fe_num_float_callee_save: Z +}. + +(** Computation of the frame environment from the bounds of the current + function. *) + +Definition make_env (b: bounds) := + let oil := 24 + 4 * b.(bound_outgoing) in (* integer locals *) + let oics := oil + 4 * b.(bound_int_local) in (* integer callee-saves *) + let oendi := oics + 4 * b.(bound_int_callee_save) in + let ofl := align oendi 8 in (* float locals *) + let ofcs := ofl + 8 * b.(bound_float_local) in (* float callee-saves *) + let sz := ofcs + 8 * b.(bound_float_callee_save) in (* total frame size *) + mk_frame_env sz 0 12 + oil oics b.(bound_int_callee_save) + ofl ofcs b.(bound_float_callee_save). + + +Remark align_float_part: + forall b, + 24 + 4 * bound_outgoing b + 4 * bound_int_local b + 4 * bound_int_callee_save b <= + align (24 + 4 * bound_outgoing b + 4 * bound_int_local b + 4 * bound_int_callee_save b) 8. +Proof. + intros. apply align_le. omega. +Qed. + -- cgit v1.2.3